diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,17 @@ +language-puppet (1.4.1) artful; urgency=medium + + * Add the `with` function. + * Add the `assert_type` function. + * Add casting string into integer with Integer("12") (See #255) + * Add hiera environment layer lookup + * Change [Puppet 4] empty strings in boolean context are true (See #205). + * Fix regex variable resolution (See #248). + * Fix missing fail on extra spaces (See #187) + * Fix read multiple hierachies in hiera format v5 + * Fix #260, #261, #262, #263 + + -- Bartavelle Sun, 04 Nov 2018 09:32:48 +0100 + language-puppet (1.4.0) xenial; urgency=medium * Now supporting megaparsec-7.0.0 diff --git a/README.adoc b/README.adoc --- a/README.adoc +++ b/README.adoc @@ -4,31 +4,29 @@ image:https://www.stackage.org/package/language-puppet/badge/lts[link="https://www.stackage.org/lts/package/language-puppet"] image:https://www.stackage.org/package/language-puppet/badge/nightly[link="https://www.stackage.org/nightly/package/language-puppet"] image:https://travis-ci.org/bartavelle/language-puppet.svg?branch=master["Build Status", link="https://travis-ci.org/bartavelle/language-puppet"] +image:https://img.shields.io/badge/cachix-cachix-orange.svg[link="https://language-puppet.cachix.org"] A library to work with Puppet manifests, test them and eventually replace everything ruby. -.Basic usage: -``` -puppetresources -p /where/your/puppet/files/are -o node.name.com -``` +== Install -.Quick install instruction with stack: +.Install with stack: ```bash stack install language-puppet ``` -.Quick install instruction with nix: +.Install with nix: ```bash -nix-env -i -f https://github.com/pierrer/language-puppet/tarball/7d48bca894d41d1c52ee31c0858714e7795d70b3 +nix-env -i -f https://github.com/bartavelle/language-puppet/tarball/1.4.1 <1> ``` +<1> replace `1.4.1` with any commit ref or tag .Build instructions: ```bash git clone https://github.com/bartavelle/language-puppet.git cd language-puppet # Using nix -cabal2nix . > default.nix -nix-build shell.nix +nix build # Using stack ln -s stack-10.yaml stack.yaml stack build @@ -36,6 +34,11 @@ == Puppetresources +.Basic usage: +``` +puppetresources --puppetdir /where/your/puppet/files/are --node node.name.com +``` + The `puppetresources` command is a command line utility that let you interactively compute catalogs on your local computer. It is much faster than its ruby counterpart, and has been designed for giving assistance to the Puppet catalog writer. @@ -59,7 +62,7 @@ Enable the `node mode`. This let you specify the name of the node you wish to compute the catalog for. -`-a` or `-all`:: +`-a` or `--all`:: Enable the `stats mode`. If you specify `allnodes` it will compute the catalogs for all nodes that are specified in `site.pp` (this will not work for regexp-specified or the default nodes). You can also specify a list of nodes separated by a comma. + @@ -185,14 +188,19 @@ `--version`:: Output version information and exit. -== Unsupported Puppet idioms or features +== Supported and unsupported idioms or features -OS:: - * `OS X` is supported when using the latest `filecache-0.3`. +Supported version:: +puppet 4 is mostly supported. Please look at the list of issues for details. -puppet functions:: +Custom ruby functions:: +The tool might bark when resolving custom ruby functions. +These function can easily be mocked or implemented in Haskell if necessary. + +Puppet functions:: * the `require` function is not supported (see https://github.com/bartavelle/language-puppet/issues/17[issue #17]) * the deprecated `import` function is not supported * the deprecated node inheritance feature is not supported -custom ruby functions:: +OS:: + Linux is the default OS. The tool has also been successfully installed and used on `OS X`. Windows is not supported. 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.0 +version: 1.4.1 synopsis: Tools to parse and evaluate the Puppet DSL. description: This is a set of tools that is supposed to fill all your Puppet needs : syntax checks, catalog compilation, PuppetDB queries, simulation of complex interactions between nodes, Puppet master replacement, and more ! homepage: http://lpuppet.banquise.net/ @@ -16,7 +16,7 @@ cabal-version: >=1.8 bug-reports: https://github.com/bartavelle/language-puppet/issues -Tested-With: GHC == 8.0.2, GHC == 8.2.2 +Tested-With: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4 extra-source-files: CHANGELOG @@ -24,6 +24,7 @@ HLint.hs tests/hiera/*.yaml tests/hiera/*.com.json + tests/Parser/lexer/*.pp Data-Files: ruby/hrubyerb.rb @@ -41,6 +42,8 @@ , PuppetDB , Puppet.Language , Puppet.Parser + -- exposed internal to ease testing + , Puppet.Parser.Internal , Puppet.Interpreter , Puppet.Runner other-modules: XPrelude.Extra @@ -100,10 +103,9 @@ , base16-bytestring == 0.1.* , bytestring , case-insensitive == 1.2.* - , containers == 0.5.* + , containers >= 0.5 && < 0.7 , cryptonite >= 0.6 , directory >= 1.2 && < 1.4 - , exceptions >= 0.8 && < 0.11 , filecache >= 0.2.9 && < 0.5 , filepath >= 1.4 , formatting @@ -112,7 +114,6 @@ , http-client >= 0.4.30 && < 0.6 , hruby >= 0.3.2 && < 0.4 , hslogger == 1.2.* - , hspec , lens >= 4.12 && < 5 , lens-aeson >= 1.0 , megaparsec >= 7 && < 8 @@ -122,7 +123,6 @@ , parsec == 3.1.* , parser-combinators == 1.* , pcre-utils >= 0.1.7 && < 0.2 - , process >= 1.2 , protolude >= 0.2 , random , regex-pcre-builtin >= 0.94.4 @@ -130,7 +130,7 @@ , servant >= 0.9 && < 0.15 , servant-client >= 0.9 && < 0.15 , split == 0.2.* - , stm == 2.4.* + , stm >= 2.4 && < 2.6 , strict-base-types >= 0.3 , text >= 0.11 , time >= 1.5 && < 2 @@ -154,7 +154,6 @@ , lens , mtl , scientific - , protolude , strict-base-types , text , temporary @@ -162,27 +161,28 @@ , unordered-containers , vector , pcre-utils - other-modules: DT.Parser - ErbSpec - EvalSpec - ExprSpec - HieraSpec - Function.ShellquoteSpec - Function.SprintfSpec - Function.SizeSpec - Function.MergeSpec - Function.EachSpec - Function.DeleteAtSpec - Function.AssertPrivateSpec - Function.JoinKeysToValuesSpec - Function.LookupSpec - Function.SuffixSpec - Function.PrefixSpec - Helpers - InterpreterSpec + other-modules: Helpers + Parser.DT + Parser.ExprSpec + Parser.LexerSpec + Interpreter.ClassSpec Interpreter.CollectorSpec Interpreter.IfSpec - LexerSpec + Interpreter.EvalSpec + Interpreter.Function.ShellquoteSpec + Interpreter.Function.SprintfSpec + Interpreter.Function.SizeSpec + Interpreter.Function.MergeSpec + Interpreter.Function.EachSpec + Interpreter.Function.WithSpec + Interpreter.Function.DeleteAtSpec + Interpreter.Function.AssertPrivateSpec + Interpreter.Function.JoinKeysToValuesSpec + Interpreter.Function.LookupSpec + Interpreter.Function.SuffixSpec + Interpreter.Function.PrefixSpec + HieraSpec + ErbSpec PuppetdbSpec main-is: Spec.hs @@ -196,6 +196,7 @@ build-depends: base , Glob , aeson + , async , bytestring , containers , transformers @@ -204,11 +205,8 @@ , http-client , language-puppet , lens - , megaparsec , optparse-applicative - , parallel-io , regex-pcre-builtin - , strict-base-types , text , unordered-containers , vector @@ -241,7 +239,6 @@ , lens , mtl , optparse-applicative - , strict-base-types , text , transformers , unordered-containers diff --git a/progs/PuppetResources.hs b/progs/PuppetResources.hs --- a/progs/PuppetResources.hs +++ b/progs/PuppetResources.hs @@ -8,7 +8,7 @@ import XPrelude hiding (option, (<>)) -import Control.Concurrent.ParallelIO (parallel) +import qualified Control.Concurrent.Async as Async import qualified Data.Aeson as Aeson import qualified Data.HashMap.Strict as Map import qualified Data.HashSet as HS @@ -42,7 +42,7 @@ readMultNodes:: String -> Maybe MultNodes readMultNodes "allnodes" = Just AllNodes -readMultNodes n = Just (MultNodes (Text.splitOn "," (toS n))) +readMultNodes n = Just (MultNodes (Text.splitOn "," (toS n))) data Options = Options { _optShowjson :: Bool @@ -239,7 +239,7 @@ putText "" allparses <- do let parsefp fp = runPuppetParser fp <$> readFile fp - parallel (map parsefp (Set.toList usedfiles)) + Async.mapConcurrently parsefp (Set.toList usedfiles) let (parseFailed, parseSucceeded) = partitionEithers allparses unless (null parseFailed) $ do putDoc ("The following" <+> pretty (length parseFailed) <+> "files could not be parsed:" <> softline <> indent 4 (vcat (map (ppstring . show) parseFailed))) @@ -280,7 +280,7 @@ queryfunc (parsingStats, catalogStats, templateStats) topnodes = do -- the parsing statistics, so that we known which files - (cats, Sum failures) <- catMaybesCount <$> parallel (map (compute queryfunc) topnodes) + (cats, Sum failures) <- catMaybesCount <$> Async.mapConcurrently (compute queryfunc) topnodes pStats <- getStats parsingStats cStats <- getStats catalogStats tStats <- getStats templateStats diff --git a/progs/pdbQuery.hs b/progs/pdbQuery.hs --- a/progs/pdbQuery.hs +++ b/progs/pdbQuery.hs @@ -112,14 +112,14 @@ DumpFacts -> if _pdbtype == PDBDummy then puppetDBFacts "dummy" pdbapi >>= mapM_ print . HM.toList else do - allfacts <- runCheck "get facts" (getFacts pdbapi QEmpty) + allfacts <- runCheck "get facts" (getPDBFacts pdbapi QEmpty) tmpdb <- loadTestDB "/tmp/allfacts.yaml" >>= unwrapError "load test db" let groupfacts = foldl' groupfact HM.empty allfacts groupfact curmap (FactInfo ndname fctname fctval) = curmap & at ndname . non HM.empty %~ (at fctname ?~ fctval) runCheck "replace facts in dummy db" (replaceFacts tmpdb (HM.toList groupfacts)) runCheck "commit db" (commitDB tmpdb) - DumpFact n -> runExceptT (getFacts pdbapi (QEqual FCertname n ) ) >>= display "dump fact" + DumpFact n -> runExceptT (getPDBFacts pdbapi (QEqual FCertname n ) ) >>= display "dump fact" DumpNodes -> runExceptT (getNodes pdbapi QEmpty) >>= display "dump nodes" DumpResources n -> runExceptT (getResourcesOfNode pdbapi n QEmpty) >>= display "get resources" AddFacts n -> do @@ -130,7 +130,7 @@ CreateTestDB destfile -> do ndb <- loadTestDB destfile >>= unwrapError "puppetdb load" allnodes <- runCheck "get nodes" (getNodes pdbapi QEmpty) - allfacts <- runCheck "get facts" (getFacts pdbapi QEmpty) + allfacts <- runCheck "get facts" (getPDBFacts pdbapi QEmpty) let factsGrouped = HM.toList $ HM.fromListWith (<>) $ map (\x -> (x ^. factInfoNodename, HM.singleton (x ^. factInfoName) (x ^. factInfoVal))) allfacts runCheck "replace facts" (replaceFacts ndb factsGrouped) forM_ allnodes $ \pnodename -> do diff --git a/progs/yera.hs b/progs/yera.hs --- a/progs/yera.hs +++ b/progs/yera.hs @@ -41,7 +41,7 @@ main :: IO () main = do Config fp query qtype vars <- execParser configInfo - hiera <- startHiera fp + hiera <- startHiera "yera" fp hiera (Map.fromList vars) (toS query) qtype >>= \case S.Left rr -> panic (show rr) S.Right Nothing -> die "no match" diff --git a/src/Erb/Parser.hs b/src/Erb/Parser.hs --- a/src/Erb/Parser.hs +++ b/src/Erb/Parser.hs @@ -132,7 +132,7 @@ variablereference = fmap (Object . Value . Literal . Text.pack) identifier rubystatement :: Parser RubyStatement -rubystatement = fmap Puts rubyexpression +rubystatement = fail "statements not supported yet" textblockW :: Maybe Char -> Parser [RubyStatement] textblockW c = do diff --git a/src/Hiera/Server.hs b/src/Hiera/Server.hs --- a/src/Hiera/Server.hs +++ b/src/Hiera/Server.hs @@ -123,16 +123,24 @@ instance FromJSON HieraConfigFile where parseJSON = let + mkHiera5 :: Object -> Yaml.Parser HieraConfigFile mkHiera5 v = do - [hierarchy_value] <- v .: "hierarchy" - datadir <- case Object v ^? key "defaults" . key "datadir" of + -- we currently only read the first hierarchy entry to get the hiera path + -- TODO: change the definition of HieraConfigFile to be [(Backend, InterpolableHieraString)] + -- to allow defining a Backend per hierarchies + let paths = Object v ^.. key "hierarchy" . values . key "paths" . values + path = Object v ^.. key "hierarchy" .values .key "path" + hierarchy_value <- case Object v ^? key "hierarchy" . nth 0 of + Just (Object h) -> pure h + _ -> fail "Hiera config should define at least one hierarchy" + datadir <- hierarchy_value .:? "datadir" >>= \case Just (String dir) -> pure dir Just _ -> fail "datadir should be a string" - Nothing -> hierarchy_value .: "datadir" .!= "hieradata" + Nothing -> pure $ Object v ^. key "defaults" . key "datadir" . _String HieraConfigFile <$> pure 5 <*> pure [ YamlBackend (toS datadir) ] -- TODO: support other backends if needed - <*> (hierarchy_value .:? "paths" .!= [InterpolableHieraString [HPString "common.yaml"]]) + <*> mapM parseJSON (paths <> path) mkHiera3 v = HieraConfigFile <$> pure 3 @@ -162,15 +170,15 @@ -- | The only method you'll ever need. It runs a Hiera server and gives you a querying function. -- | All IO exceptions are thrown directly including ParsingException. -startHiera :: FilePath -> IO (HieraQueryFunc IO) -startHiera fp = +startHiera :: String -> FilePath -> IO (HieraQueryFunc IO) +startHiera layer fp = Yaml.decodeFileEither fp >>= \case Left (Yaml.AesonException "Error in $: Hiera configuration version different than 5 is not supported.") -> do logInfoStr ("Detect a hiera configuration format in " <> fp <> " at version 4. This format is not recognized. Using a dummy hiera.") pure dummyHiera Left ex -> panic (show ex) Right cfg@HieraConfigFile{..} -> do - logInfoStr ("Detect a hiera configuration format in " <> fp <> " at version " <> show _version) + logInfoStr ("Detect a hiera " <> layer <> " configuration format in " <> fp <> " at version " <> show _version) cache <- Cache.newFileCache pure (query cfg fp cache) @@ -191,7 +199,7 @@ case backend of JsonBackend dir -> (fmap (strictifyEither . Aeson.eitherDecode') . BS.readFile , dir, ".json") YamlBackend dir -> (fmap (strictifyEither . (_Left %~ show)) . Yaml.decodeFileEither, dir, ".yaml") - return (decodeInfo, Text.unpack h) + pure (decodeInfo, toS h) -- step 2, read all the files, returning a raw data structure mvals <- forM searchin $ \((decodefunction, datadir, extension), h) -> do let extension' = if snd (FilePath.splitExtension h) == ".yaml" @@ -207,12 +215,14 @@ S.Left r -> do logWarningStr $ "Hiera: error when reading file " <> filename <> ": "<> r pure Nothing - S.Right val -> pure (Just val) + S.Right val -> do + 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)) type QM a = ExceptT PrettyError (Reader QRead) a @@ -234,7 +244,7 @@ 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 (show rr)) + Right (Aeson.Error rr) -> throwError ("Something horrible happened in recursiveQuery: " <> fromString rr) resolveValue :: [Text] -> Value -> QM Value resolveValue prevqueries value = diff --git a/src/Puppet/Interpreter.hs b/src/Puppet/Interpreter.hs --- a/src/Puppet/Interpreter.hs +++ b/src/Puppet/Interpreter.hs @@ -6,8 +6,9 @@ , evaluateStatement -- * Utils , initialState - , extractFromState + , extractScope , containerModName + , askFact , module Puppet.Interpreter.Types , module Puppet.Interpreter.Resolve , module Puppet.Interpreter.IO @@ -54,18 +55,18 @@ -> Container Text -- ^ Server settings -> m (Pair (Either PrettyError (FinalCatalog, EdgeMap, FinalCatalog, [Resource])) [Pair Log.Priority Doc]) interpretCatalog r node facts settings = do - (output, _, warnings) <- interpretMonad r (initialState facts settings) (computeCatalog node) - pure (output :!: warnings) + (output, _, warnings) <- interpretMonad r (initialState facts settings) (computeCatalog node) + pure (output :!: warnings) isParent :: Text -> CurContainerDesc -> InterpreterMonad Bool isParent cur (ContClass possibleparent) = preuse (scopes . ix cur . scopeParent) >>= \case Nothing -> throwPosError ("Internal error: could not find scope" <+> ppline cur <+> "possible parent" <+> ppline possibleparent) - Just S.Nothing -> return False + Just S.Nothing -> pure False Just (S.Just p) -> if p == possibleparent - then return True + then pure True else isParent p (ContClass possibleparent) -isParent _ _ = return False +isParent _ _ = pure False -- | Apply resource defaults, references overrides and expand defines finalize :: [Resource] -> InterpreterMonad [Resource] @@ -90,10 +91,10 @@ overrideType <- case r ^. rscope of [] -> forb "Could not find the current resource context" -- we could not get the current resource context (x:_) -> if x == s - then return CantOverride -- we are in the same context : can't replace, but add stuff + then pure CantOverride -- we are in the same context : can't replace, but add stuff else isParent (scopeName s) x >>= \i -> if i || (r ^. rid . itype == "class") - then return Replace -- we can override what's defined in a parent + then pure Replace -- we can override what's defined in a parent else forb "Can't override something that was not defined in the parent." ifoldlM (addAttribute overrideType) r prms -- step 1, apply resDefaults and resRefOverride @@ -106,17 +107,17 @@ where appended = ResourceModifier (resid ^. itype) ModifierMustMatch DontRealize (REqualitySearch "title" (PString (resid ^. iname))) overrider ropos overrider r = do - -- we must define if we can override the value - let canOverride = CantOverride -- TODO check inheritance - ifoldlM (addAttribute canOverride) r resprms + -- we must define if we can override the value + let canOverride = CantOverride -- TODO check inheritance + ifoldlM (addAttribute canOverride) r resprms void $ getOver >>= mapM keepforlater let expandableDefine r = do n <- isNativeType (r ^. rid . itype) -- if we have a native type, or a virtual/exported resource it -- should not be expanded ! if n || r ^. rvirtuality /= Normal - then return [r] - else expandDefine r + then pure [r] + else expandDefine r -- Now that all defaults / override have been applied, the defines can -- finally be expanded. -- The reason it has to be there is that parameters of the define could @@ -126,42 +127,41 @@ expandDefine :: Resource -> InterpreterMonad [Resource] expandDefine r = let modulename = getModulename (r ^. rid) - in isIgnoredModule modulename >>= \i -> - if i - then return mempty - else do - let deftype = dropInitialColons (r ^. rid . itype) - defname = r ^. rid . iname - curContType = ContDefine deftype defname (r ^. rpos) - p <- use curPos - -- we add the relations of this define to the global list of relations - -- before dropping it, so that they are stored for the final - -- relationship resolving - let extr = do - (dstid, linkset) <- itoList (r ^. rrelations) - linktype <- toList linkset - return (LinkInformation (r ^. rid) dstid linktype p) - extraRelations <>= extr - void $ enterScope SENormal curContType modulename p - (spurious, stmt) <- interpretTopLevel TopDefine deftype - DefineDecl _ defineParams stmts cp <- extractPrism "expandDefine" _DefineDecl stmt - let isImported (ContImported _) = True - isImported _ = False - isImportedDefine <- isImported <$> getScope - curPos .= r ^. rpos - curscp <- getScope - when isImportedDefine (pushScope (ContImport (r ^. rnode) curscp )) - pushScope curContType - loadVariable "title" (PString defname) - loadVariable "name" (PString defname) - -- not done through loadvariable because of override errors - loadParameters (r ^. rattributes) defineParams cp S.Nothing - curPos .= cp - res <- evaluateStatementsFoldable stmts - out <- finalize (spurious ++ res) - when isImportedDefine popScope - popScope - return out + in isIgnoredModule modulename >>= \case + True -> pure mempty + False -> do + let deftype = dropInitialColons (r ^. rid . itype) + defname = r ^. rid . iname + curContType = ContDefine deftype defname (r ^. rpos) + p <- use curPos + -- we add the relations of this define to the global list of relations + -- before dropping it, so that they are stored for the final + -- relationship resolving + let extr = do + (dstid, linkset) <- itoList (r ^. rrelations) + linktype <- toList linkset + pure (LinkInformation (r ^. rid) dstid linktype p) + extraRelations <>= extr + void $ enterScope SENormal curContType modulename p + (spurious, stmt) <- interpretTopLevel TopDefine deftype + DefineDecl _ defineParams stmts cp <- extractPrism "expandDefine" _DefineDecl stmt + let isImported (ContImported _) = True + isImported _ = False + isImportedDefine <- isImported <$> getScope + curPos .= r ^. rpos + curscp <- getScope + when isImportedDefine (pushScope (ContImport (r ^. rnode) curscp )) + pushScope curContType + loadVariable "title" (PString defname) + loadVariable "name" (PString defname) + -- not done through loadvariable because of override errors + loadParameters (r ^. rattributes) defineParams cp Nothing + curPos .= cp + res <- evaluateStatementsFoldable stmts + out <- finalize (spurious <> res) + when isImportedDefine popScope + popScope + pure out -- | Given a toplevel (type, name), -- return the associated parsed statement together with its evaluated resources @@ -169,26 +169,25 @@ interpretTopLevel toptype topname = -- check if this is a known toplevel use (nestedDeclarations . at (toptype, topname)) >>= \case - Just x -> return ([], x) -- it is known ! + Just x -> pure ([], x) -- it is known ! Nothing -> singleton (GetStatement toptype topname) >>= evalTopLevel where evalTopLevel :: Statement -> InterpreterMonad ([Resource], Statement) evalTopLevel (TopContainer tops s) = do - pushScope ContRoot - r <- mapM evaluateStatement tops >>= finalize . concat - -- popScope - (nr, ns) <- evalTopLevel s - popScope - return (r <> nr, ns) - evalTopLevel x = return ([], x) + pushScope ContRoot + r <- mapM evaluateStatement tops >>= finalize . concat + -- popScope + (nr, ns) <- evalTopLevel s + popScope + pure (r <> nr, ns) + evalTopLevel x = pure ([], x) -- | Main internal entry point, this function completes the interpretation --- TODO: add some doc here computeCatalog :: NodeName -> InterpreterMonad (FinalCatalog, EdgeMap, FinalCatalog, [Resource]) computeCatalog nodename = do (topres, stmt) <- interpretTopLevel TopNode nodename nd <- extractPrism "computeCatalog" _NodeDecl stmt - let finalStep [] = return [] + let finalStep [] = pure [] finalStep allres = do -- collect stuff and apply thingies (realized :!: modified) <- realize allres @@ -197,7 +196,7 @@ refinalized <- finalize (toList modified) >>= finalStep -- replace the modified stuff let res = foldl' (\curm e -> curm & at (e ^. rid) ?~ e) realized refinalized - return (toList res) + pure (toList res) mainstage = Resource (RIdentifier "stage" "main") mempty mempty mempty [ContRoot] Normal mempty (initialPPos mempty) nodename @@ -217,19 +216,19 @@ -> Resource -> Pair (HashMap RIdentifier Resource) (HashMap RIdentifier Resource) classify (curr :!: cure) r = - let i curm = curm & at (r ^. rid) ?~ r - in case r ^. rvirtuality of - Normal -> i curr :!: cure - Exported -> curr :!: i cure - ExportedRealized -> i curr :!: i cure - _ -> curr :!: cure + let i curm = curm & at (r ^. rid) ?~ r + in case r ^. rvirtuality of + Normal -> i curr :!: cure + Exported -> curr :!: i cure + ExportedRealized -> i curr :!: i cure + _ -> curr :!: cure verified <- Map.fromList . map (\r -> (r ^. rid, r)) <$> mapM validateNativeType (Map.elems real) withResourceDependentRelations <- traverse getResourceDependentRelations verified edgemap <- makeEdgeMap withResourceDependentRelations definedRes <- use definedResources - return (withResourceDependentRelations, edgemap, exported, Map.elems definedRes) + pure (withResourceDependentRelations, edgemap, exported, Map.elems definedRes) --- | This extracts additional relationships between resources, that are +-- This extracts additional relationships between resources, that are -- dependent on whether some resources are defined. A canonical example is -- is the owner field in a File, that can create problems if it's -- defined! @@ -247,18 +246,18 @@ where extract actions = do newrelations <- fmap (foldl' (Map.unionWith (<>)) (res ^. rrelations)) (sequence actions) - return (res & rrelations .~ newrelations) + pure (res & rrelations .~ newrelations) depOn :: Text -> Text -> InterpreterMonad (HashMap RIdentifier (HashSet LinkType)) depOn resType attributeName = case res ^? rattributes . ix attributeName of Just (PString usr) -> do let targetResourceId = RIdentifier resType usr existing <- has (ix targetResourceId) <$> use definedResources - return $ + pure $ if existing then Map.singleton targetResourceId (Set.singleton RRequire) else Map.empty - _ -> return Map.empty + _ -> pure Map.empty makeEdgeMap :: FinalCatalog -> InterpreterMonad EdgeMap makeEdgeMap ct = do @@ -271,10 +270,10 @@ aliases' = ifromList $ do r <- ct ^.. traversed :: [Resource] extraAliases <- r ^.. ralias . folded . filtered (/= r ^. rid . iname) :: [Text] - return (r ^. rid & iname .~ extraAliases, r ^. rpos) + pure (r ^. rid & iname .~ extraAliases, r ^. rpos) classes' = ifromList $ do (cn, _ :!: cp) <- itoList clss' - return (RIdentifier "class" cn, cp) + pure (RIdentifier "class" cn, cp) -- Preparation step : all relations to a container become relations to -- the stuff that's contained. We build a map of resources, stored by -- container. @@ -294,7 +293,7 @@ (rawdst, lts) <- itoList (r ^. rrelations) lt <- toList lts let (nsrc, ndst, nlt) = reorderlink (resid, rawdst, lt) - return (nsrc, [LinkInformation nsrc ndst nlt respos]) + pure (nsrc, [LinkInformation nsrc ndst nlt respos]) step1 :: HashMap RIdentifier [LinkInformation] step1 = foldl' addRR mempty ct -- step 2 - add other relations (mainly stuff made from the "->" @@ -317,9 +316,9 @@ genlnk lif = do let d = lif ^. linkdst checkExists d ("Unknown resource" <+> pretty d <+> "used in a relation at" <+> showPPos (lif ^. linkPos)) - return d + pure d ds <- mapM genlnk lifs - return (ri, ri, ds) + pure (ri, ri, ds) edgeList <- mapM checkResDef (itoList step2) let (graph, gresolver) = Graph.graphFromEdges' edgeList -- now check for scc @@ -336,9 +335,9 @@ throwPosError $ "Dependency error, the following resources are strongly connected!" trees -- let edgePairs = concatMap (\(_,k,ls) -> [(k,l) | l <- ls]) edgeList -- throwPosError (vcat (map (\(RIdentifier st sn, RIdentifier dt dn) -> "\"" <> pretty st <> ttext sn <> "\" -> \"" <> ttext dt <> ttext dn <> "\"") edgePairs)) - return step2 + pure step2 --- | This functions performs all the actions triggered by calls to the +-- This functions performs all the actions triggered by calls to the -- realize function or other collectors. It returns a pair of -- 'FinalCatalog', where the first part is the new catalog, and the second -- part the map of all modified resources. The second part is needed so @@ -356,27 +355,27 @@ let filtrd = curmap ^.. folded . filtered fmod -- all the resources that match the selector/realize criteria vcheck f r = f (r ^. rvirtuality) (isGoodvirtuality, alterVirtuality) = case rmod ^. rmType of - RealizeVirtual -> (vcheck (/= Exported), \r -> return (r & rvirtuality .~ Normal)) - RealizeCollected -> (vcheck (`elem` [Exported, ExportedRealized]), \r -> return (r & rvirtuality .~ ExportedRealized)) - DontRealize -> (vcheck (`elem` [Normal, ExportedRealized]), return) + RealizeVirtual -> (vcheck (/= Exported), \r -> pure (r & rvirtuality .~ Normal)) + RealizeCollected -> (vcheck (`elem` [Exported, ExportedRealized]), \r -> pure (r & rvirtuality .~ ExportedRealized)) + DontRealize -> (vcheck (`elem` [Normal, ExportedRealized]), pure) fmod r = (r ^. rid . itype == rmod ^. rmResType) && checkSearchExpression (rmod ^. rmSearch) r && isGoodvirtuality r mutation = alterVirtuality >=> rmod ^. rmMutation applyModification :: Pair FinalCatalog FinalCatalog -> Resource -> InterpreterMonad (Pair FinalCatalog FinalCatalog) applyModification (cma :!: cmo) r = do nr <- mutation r let i m = m & at (nr ^. rid) ?~ nr - return $ if nr /= r + pure $ if nr /= r then i cma :!: i cmo else cma :!: cmo result <- foldM applyModification (curmap :!: modified) filtrd -- apply the modifiation to all the matching resources when (rmod ^. rmModifierType == ModifierMustMatch && null filtrd) (throwError (PrettyError ("Could not apply this resource override :" <+> pretty rmod <> ",no matching resource was found."))) - return result + pure result equalModifier (ResourceModifier a1 b1 c1 d1 _ e1) (ResourceModifier a2 b2 c2 d2 _ e2) = a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2 && e1 == e2 result <- use resModifiers >>= foldM mutate (rma :!: mempty) . reverse . List.nubBy equalModifier resModifiers .= [] pure result --- | Fold all attribute declarations +-- Fold all attribute declarations -- checking for duplicates key locally inside a same resource. fromAttributeDecls :: Vector AttributeDecl -> InterpreterMonad (Container PValue) fromAttributeDecls = @@ -393,13 +392,13 @@ go acc k pv = case acc ^. at k of Just _ -> throwPosError ("Parameter" <+> dullyellow (ppline k) <+> "already defined!") - Nothing -> return (acc & at k ?~ pv) + Nothing -> pure (acc & at k ?~ pv) saveCaptureVariables :: InterpreterMonad (HashMap Text (Pair (Pair PValue PPosition) CurContainerDesc)) saveCaptureVariables = do scp <- getScopeName vars <- use (scopes . ix scp . scopeVariables) - return $ Map.filterWithKey (\k _ -> Text.all Char.isDigit k) vars + pure $ Map.filterWithKey (\k _ -> Text.all Char.isDigit k) vars restoreCaptureVariables :: HashMap Text (Pair (Pair PValue PPosition) CurContainerDesc) -> InterpreterMonad () restoreCaptureVariables vars = do @@ -409,25 +408,25 @@ evaluateStatement :: Statement -> InterpreterMonad [Resource] evaluateStatement r@(ClassDeclaration (ClassDecl cname _ _ _ _)) = if "::" `Text.isInfixOf` cname - then nestedDeclarations . at (TopClass, cname) ?= r >> return [] + then nestedDeclarations . at (TopClass, cname) ?= r >> pure [] else do scp <- getScopeName let rcname = if scp == "::" then cname else scp <> "::" <> cname nestedDeclarations . at (TopClass, rcname) ?= r - return [] + pure [] evaluateStatement r@(DefineDeclaration (DefineDecl dname _ _ _)) = if "::" `Text.isInfixOf` dname - then nestedDeclarations . at (TopDefine, dname) ?= r >> return [] + then nestedDeclarations . at (TopDefine, dname) ?= r >> pure [] else do scp <- getScopeName if scp == "::" - then nestedDeclarations . at (TopDefine, dname) ?= r >> return [] - else nestedDeclarations . at (TopDefine, scp <> "::" <> dname) ?= r >> return [] + then nestedDeclarations . at (TopDefine, dname) ?= r >> pure [] + else nestedDeclarations . at (TopDefine, scp <> "::" <> dname) ?= r >> pure [] evaluateStatement r@(ResourceCollectionDeclaration (ResCollDecl ct rtype searchexp mods p)) = do curPos .= p - unless (isEmpty mods || ct == Collector) + unless (null mods || ct == Collector) (throwPosError ("It doesn't seem possible to amend attributes with an exported resource collector:" pretty r)) when (rtype == "class") (throwPosError "Classes cannot be collected") rsearch <- resolveSearchExpression searchexp @@ -451,14 +450,14 @@ pushScope scpdesc o <- finalize res popScope - return o - else return [] + pure o + else pure [] evaluateStatement (DependencyDeclaration (DepDecl (t1 :!: n1) (t2 :!: n2) lt p)) = do curPos .= p rn1 <- map (fixResourceName t1) <$> resolveExpressionStrings n1 rn2 <- map (fixResourceName t2) <$> resolveExpressionStrings n2 extraRelations <>= [ LinkInformation (normalizeRIdentifier t1 an1) (normalizeRIdentifier t2 an2) lt p | an1 <- rn1, an2 <- rn2 ] - return [] + pure [] evaluateStatement (ResourceDeclaration (ResDecl t ern eargs virt p)) = do curPos .= p resnames <- resolveExpressionStrings ern @@ -472,10 +471,10 @@ varval <- resolveExpression varexpr mapM_ (resolveDataType >=> (`checkMatch` varval)) mt loadVariable varname varval - return [] + pure [] evaluateStatement (ConditionalDeclaration (ConditionalDecl conds p)) = do curPos .= p - let checkCond [] = return [] + let checkCond [] = pure [] checkCond ((e :!: stmts) : xs) = do sv <- saveCaptureVariables result <- pValue2Bool <$> resolveExpression e @@ -489,7 +488,7 @@ scp <- getScopeName -- invariant that must be respected : the current scope must be created -- in "scopes", or nothing gets saved - preuse (scopes . ix scp) >>= maybe (throwPosError ("INTERNAL ERROR in evaluateStatement ResourceDefaultDeclaration: scope wasn't created - " <> ppline scp)) (const (return ())) + preuse (scopes . ix scp) >>= maybe (throwPosError ("INTERNAL ERROR in evaluateStatement ResourceDefaultDeclaration: scope wasn't created - " <> ppline scp)) (const (pure ())) let newDefaults = ResDefaults rtype scp rdecls p addDefaults x = scopes . ix scp . scopeResDefaults . at rtype ?= x -- default merging with parent @@ -499,7 +498,7 @@ Just d -> if d ^. resDefSrcScope == scp then throwPosError ("Defaults for resource" <+> ppline rtype <+> "already declared at" <+> showPPos (d ^. resDefPos)) else addDefaults (mergedDefaults d) - return [] + pure [] evaluateStatement (ResourceOverrideDeclaration (ResOverrideDecl t urn eargs p)) = do curPos .= p raassignements <- fromAttributeDecls eargs @@ -511,26 +510,65 @@ withAssignements <- case curoverrides ^. at rident of Just (ResRefOverride _ prevass prevpos) -> do let cm = prevass `Map.intersection` raassignements - unless (isEmpty cm) + unless (null cm) (throwPosError ("The following parameters were already overriden at" <+> showPPos prevpos <+> ":" <+> pretty cm)) - return (prevass <> raassignements) - Nothing -> return raassignements + pure (prevass <> raassignements) + Nothing -> pure raassignements scopes . ix scp . scopeOverrides . at rident ?= ResRefOverride rident withAssignements p - return [] + pure [] evaluateStatement (HigherOrderLambdaDeclaration (HigherOrderLambdaDecl c p)) = curPos .= p >> evaluateHFC c where evaluateHFC :: HOLambdaCall -> InterpreterMonad [Resource] - evaluateHFC hf = do - varassocs <- hfGenerateAssociations hf + evaluateHFC hf = let runblock :: [(Text, PValue)] -> InterpreterMonad [Resource] runblock assocs = do saved <- hfSetvars assocs res <- evaluateStatementsFoldable (hf ^. hoLambdaStatements) hfRestorevars saved - return res - results <- mapM runblock varassocs - return (concat results) + pure res + in case hf ^. hoLambdaFunc of + LambdaFunc "each" -> do + varassocs <- hfGenerateAssociations hf + concat <$> mapM runblock varassocs + -- we associate each pair of expressions and arguments, and + -- run the inner code in this scope + LambdaFunc "assert_type" -> + case (hf ^.. hoLambdaExpr . folded, hf ^.. hoLambdaParams . folded) of + ( [utp, uval], [a, b] ) -> do + let typecheck_lambda (LambdaParam ltype lvar) + = case ltype of + Nothing -> pure lvar + Just udt -> do + dt <- resolveDataType udt + if dt == DTType + then pure lvar + else throwPosError ("The lambda value can only be a type in assert_type, not" <+> pretty dt) + mtp <- resolveExpression utp + val <- resolveExpression uval + varexpected <- typecheck_lambda a + varactual <- typecheck_lambda b + case mtp of + PType expectedType -> + if datatypeMatch expectedType val + then pure [] + else runblock [(varexpected, PType expectedType), (varactual, PType (typeOf val))] + _ -> throwPosError ("The first argument to assert_type should be a data type, not" <+> pretty mtp) + _ -> throwPosError "assert_types requires two parameters, and two lambda parameters" + LambdaFunc "with" -> do + let expressions = hf ^. hoLambdaExpr + parameters = hf ^. hoLambdaParams + unless (V.length expressions == V.length parameters) + (throwPosError ("Mismatched number of arguments and lambda parameters in" <> pretty hf)) + assocs <- forM (V.zip expressions parameters) $ \(uval, LambdaParam mt name) -> do + val <- resolveExpression uval + -- type checking + forM_ mt $ \ut -> do + t <- resolveDataType ut + checkMatch t val + pure (name, val) + runblock (V.toList assocs) + fn -> throwPosError ("This lambda function is unknown:" pretty fn) evaluateStatement r = throwError (PrettyError ("Do not know how to evaluate this statement:" pretty r)) ----------------------------------------------------------- @@ -561,57 +599,61 @@ ) _ -> scopes . ix scp . scopeVariables . at varname ?= (varval :!: p :!: curcont ^. cctype) --- | This function loads class and define parameters into scope. It checks --- that all mandatory parameters are set, that no extra parameter is --- declared. +-- This function loads class and define parameters into scope. It checks +-- that all mandatory parameters are set, that no extra parameter is declared. -- --- It is able to fill unset parameters with values from Hiera (for classes --- only) or default values. -loadParameters :: Foldable f => Container PValue -> f (Pair (Pair Text (S.Maybe UDataType)) (S.Maybe Expression)) -> PPosition -> S.Maybe Text -> InterpreterMonad () -loadParameters params classParams defaultPos wHiera = do +-- It is able to fill unset parameters with values from Hiera (for classes only) or default values. +loadParameters :: Container PValue -- Resource attributes (resolved) + -> Parameters -- List of parameters as declared (unresolved) + -> PPosition -- Current position + -> Maybe Text -- class name + -> InterpreterMonad () +loadParameters attrs classParams defaultPos classname = do p <- use curPos curPos .= defaultPos - let classParamSet = Set.fromList (classParams ^.. folded . _1 . _1) - spuriousParams = ikeys params `Set.difference` classParamSet - mclassdesc = S.maybe mempty ((\x -> mempty <+> "when including class" <+> x) . ppline) wHiera + let class_params = Set.fromList (classParams ^.. folded . _1 . _1) + spurious_params = ikeys attrs `Set.difference` class_params + pp_classdesc = maybe mempty (\x -> " when including class" <+> ppline x) classname - -- the following functions `throwE (Max False)` when there is no value, and `throwE (Max True)` when this value - -- in PUndef. - checkUndef :: Maybe PValue -> ExceptT (Max Bool) InterpreterMonad PValue - checkUndef Nothing = throwE (Max False) - checkUndef (Just PUndef) = throwE (Max True) - checkUndef (Just v) = return v + -- the following functions `throwE (Max False)` when there is no value, and `throwE (Max True)` when this value in PUndef. + check_undef :: S.Maybe UDataType -> Maybe PValue -> ExceptT (Max Bool) InterpreterMonad PValue + check_undef (S.Just (UDTOptional _)) Nothing = throwE (Max True) + check_undef _ Nothing = throwE (Max False) + check_undef _ (Just PUndef) = throwE (Max True) + check_undef _ (Just v) = pure v - checkHiera :: Text -> ExceptT (Max Bool) InterpreterMonad PValue - checkHiera k = case wHiera of - S.Nothing -> throwE (Max False) - S.Just classname -> lift (runHiera (classname <> "::" <> k) QFirst) >>= checkUndef + check_hiera :: Text -> S.Maybe UDataType -> ExceptT (Max Bool) InterpreterMonad PValue + check_hiera k dt = case classname of + Nothing -> throwE (Max False) + Just n -> lift (runHiera (n <> "::" <> k) QFirst) >>= check_undef dt - checkDef :: Text -> ExceptT (Max Bool) InterpreterMonad PValue - checkDef k = checkUndef (params ^. at k) + check_def :: Text -> ExceptT (Max Bool) InterpreterMonad PValue + check_def k = check_undef S.Nothing (attrs ^. at k) - checkDefault :: S.Maybe Expression -> ExceptT (Max Bool) InterpreterMonad PValue - checkDefault S.Nothing = throwE (Max False) - checkDefault (S.Just expr) = lift (resolveExpression expr) + check_default :: S.Maybe Expression -> ExceptT (Max Bool) InterpreterMonad PValue + check_default S.Nothing = throwE (Max False) + check_default (S.Just expr) = lift (resolveExpression expr) - unless (isEmpty spuriousParams) $ throwPosError ("The following parameters are unknown:" <+> tupled (map (dullyellow . ppline) $ toList spuriousParams) <> mclassdesc) + unless (null spurious_params) + $ throwPosError ("The following parameters are unknown:" <+> tupled (map (dullyellow . ppline) $ toList spurious_params) <> pp_classdesc) -- try to set a value to all parameters -- The order of evaluation is defined / hiera / default - unsetParams <- fmap concat $ for (toList classParams) $ \(k :!: mtype :!: defValue) -> do - ev <- runExceptT (checkDef k <|> checkHiera k <|> checkDefault defValue) - case ev of - Right v -> do - forM_ mtype $ \udt -> do - dt <- resolveDataType udt - unless (datatypeMatch dt v) (throwPosError ("Expected type" <+> pretty dt <+> "for parameter" <+> ppline k <+> "but its value was:" <+> pretty v)) - loadVariable k v >> return [] - Left (Max True) -> loadVariable k PUndef >> return [] - Left (Max False) -> return [k] + unset_params <- fmap concat $ for classParams $ \(varname :!: vartype :!: valexpr) -> do + runExceptT (check_def varname <|> check_hiera varname vartype <|> check_default valexpr) >>= \case + Right val -> do + forM_ vartype $ \utype -> do + dt <- resolveDataType utype + unless (datatypeMatch dt val) + $ throwPosError ("Expected type" <+> pretty dt <+> "for parameter" <+> ppline varname <+> "but its value was:" <+> pretty val) + loadVariable varname val >> pure [] + Left (Max True) -> loadVariable varname PUndef >> pure [] + Left (Max False) -> pure [varname] curPos .= p - unless (isEmpty unsetParams) $ throwPosError ("The following mandatory parameters were not set:" <+> tupled (map ppline $ toList unsetParams) <> mclassdesc) + unless (null unset_params) + $ throwPosError ("The following mandatory parameters were not set:" <+> tupled (map ppline $ toList unset_params) <> pp_classdesc) --- | Enters a new scope, checks it is not already defined, and inherits the +-- Enters a new scope, checks it is not already defined, and inherits the -- defaults from the current scope -- -- Inheriting the defaults is necessary for non native types, because they @@ -627,7 +669,7 @@ -- This is a special hack for inheritance, because at this time we -- have not properly stacked the scopes. curcaller <- case secontext of - SEParent l -> return (PString $ Text.takeWhile (/=':') l) + SEParent l -> pure (PString $ Text.takeWhile (/=':') l) _ -> resolveVariable "module_name" scopeAlreadyDefined <- has (ix scopename) <$> use scopes let isImported = case cont of @@ -643,93 +685,94 @@ parentscope <- use (scopes . at prt) when (isNothing parentscope) (throwPosError ("Internal error: could not find parent scope" <+> ppline prt)) let Just psc = parentscope - return (psc & scopeParent .~ S.Just prt) + pure (psc & scopeParent .~ S.Just prt) _ -> do curdefs <- use (scopes . ix scp . scopeResDefaults) - return $ ScopeInformation mempty curdefs mempty (CurContainer cont mempty) mempty S.Nothing + pure $ ScopeInformation mempty curdefs mempty (CurContainer cont mempty) mempty S.Nothing scopes . at scopename ?= basescope scopes . ix scopename . scopeVariables . at "caller_module_name" ?= (curcaller :!: p :!: cont) scopes . ix "::" . scopeVariables . at "calling_module" ?= (curcaller :!: p :!: cont) scopes . ix scopename . scopeVariables . at "module_name" ?= (PString modulename :!: p :!: cont) debug ("enterScope, scopename=" <> ppline scopename <+> "caller_module_name=" <> pretty curcaller <+> "module_name=" <> ppline modulename) - return scopename + pure scopename +-- Instantiate/declare a class loadClass :: Text - -> S.Maybe Text -- ^ Set if this is an inheritance load, so that we can set calling module properly - -> Container PValue + -> S.Maybe Text -- Set if this is an inheritance load, so that we can set calling module properly + -> Container PValue -- Resource attributes -> ClassIncludeType -> InterpreterMonad [Resource] -loadClass name loadedfrom params incltype = do +loadClass name loadedfrom attrs incltype = do let name' = dropInitialColons name - ndn <- getNodeName - singleton (TraceEvent ('[' : Text.unpack ndn ++ "] loadClass " ++ Text.unpack name')) - p <- use curPos + nodename <- getNodeName + singleton (TraceEvent ('[' : toS nodename <> "] loadClass " <> toS name')) + pos <- use curPos -- check if the class has already been loaded -- http://docs.puppetlabs.com/puppet/3/reference/lang_classes.html#using-resource-like-declarations preuse (loadedClasses . ix name' . _2) >>= \case Just pp -> case incltype of - ClassIncludeLike -> return [] + ClassIncludeLike -> pure [] _ -> throwPosError $ "Can't include class" <+> ppline name' <+> "twice when using the resource-like syntax (first occurence at" <+> showPPos pp <> ")" Nothing -> do - loadedClasses . at name' ?= (incltype :!: p) + loadedClasses . at name' ?= (incltype :!: pos) -- set the position of the loaded class let modulename = getModulename (RIdentifier "class" name') is_ignored <- isIgnoredModule modulename if is_ignored - then return mempty + then pure mempty else do -- load the actual class, note we are not changing the current position right now (spurious, stmt) <- interpretTopLevel TopClass name' - ClassDecl _ classParams inh stmts cp <- extractPrism "loadClass" _ClassDecl stmt + ClassDecl _ params inh stmts curpos <- extractPrism "loadClass" _ClassDecl stmt -- check if we need to define a resource representing the class -- This will be the case for the first standard include inhstmts <- case inh of - S.Nothing -> return [] + S.Nothing -> pure [] S.Just ihname -> loadClass ihname (S.Just name') mempty ClassIncludeLike let !scopedesc = ContClass name' secontext = case (inh, loadedfrom) of (S.Just x,_) -> SEChild (dropInitialColons x) (_,S.Just x) -> SEParent (dropInitialColons x) _ -> SENormal - void $ enterScope secontext scopedesc modulename p + void $ enterScope secontext scopedesc modulename pos classresource <- if incltype == ClassIncludeLike then do scp <- use curScope fqdn <- getNodeName - return [Resource (RIdentifier "class" name') (Set.singleton name') mempty mempty scp Normal mempty p fqdn] - else return [] + pure [Resource (RIdentifier "class" name') (Set.singleton name') mempty mempty scp Normal mempty pos fqdn] + else pure [] pushScope scopedesc loadVariable "title" (PString name') loadVariable "name" (PString name') - loadParameters params classParams cp (S.Just name') - curPos .= cp + loadParameters attrs params curpos (Just name') + curPos .= curpos res <- evaluateStatementsFoldable stmts - out <- finalize (classresource ++ spurious ++ inhstmts ++ res) + out <- finalize (classresource <> spurious <> inhstmts <> res) popScope - return out + pure out ----------------------------------------------------------- -- Resource stuff ----------------------------------------------------------- addRelationship :: LinkType -> PValue -> Resource -> InterpreterMonad Resource -addRelationship lt (PResourceReference dt dn) r = return (r & rrelations %~ insertLt) +addRelationship lt (PResourceReference dt dn) r = pure (r & rrelations %~ insertLt) where insertLt = iinsertWith (<>) (normalizeRIdentifier dt dn) (Set.singleton lt) -addRelationship lt (PArray vals) r = foldlM (flip (addRelationship lt)) r vals -addRelationship _ PUndef r = return r -addRelationship _ notrr _ = throwPosError ("Expected a resource reference, not:" <+> pretty notrr) +addRelationship lt (PArray xs) r = foldlM (flip (addRelationship lt)) r xs +addRelationship _ PUndef r = pure r +addRelationship _ s _ = throwPosError ("Expected a resource reference, not:" <+> pretty s) addTagResource :: Resource -> Text -> Resource addTagResource r rv = r & rtags . contains rv .~ True addAttribute :: OverrideType -> Text -> Resource -> PValue -> InterpreterMonad Resource addAttribute _ "alias" r v = (\rv -> r & ralias . contains rv .~ True) <$> resolvePValueString v -addAttribute _ "audit" r _ = use curPos >>= \p -> warn ("Metaparameter audit ignored at" <+> showPPos p) >> return r -addAttribute _ "loglevel" r _ = use curPos >>= \p -> warn ("Metaparameter loglevel ignored at" <+> showPPos p) >> return r -addAttribute _ "schedule" r _ = use curPos >>= \p -> warn ("Metaparameter schedule ignored at" <+> showPPos p) >> return r -addAttribute _ "stage" r _ = use curPos >>= \p -> warn ("Metaparameter stage ignored at" <+> showPPos p) >> return r +addAttribute _ "audit" r _ = use curPos >>= \p -> warn ("Metaparameter audit ignored at" <+> showPPos p) >> pure r +addAttribute _ "loglevel" r _ = use curPos >>= \p -> warn ("Metaparameter loglevel ignored at" <+> showPPos p) >> pure r +addAttribute _ "schedule" r _ = use curPos >>= \p -> warn ("Metaparameter schedule ignored at" <+> showPPos p) >> pure r +addAttribute _ "stage" r _ = use curPos >>= \p -> warn ("Metaparameter stage ignored at" <+> showPPos p) >> pure r addAttribute _ "tag" r (PArray v) = foldM (\cr cv -> addTagResource cr <$> resolvePValueString cv) r (toList v) addAttribute _ "tag" r v = addTagResource r <$> resolvePValueString v addAttribute _ "before" r d = addRelationship RBefore d r @@ -738,23 +781,22 @@ addAttribute _ "subscribe" r d = addRelationship RSubscribe d r addAttribute b t r v = go t r v where - go = - case b of - CantOverride -> setAttribute - Replace -> overrideAttribute - CantReplace -> defaultAttribute - AppendAttribute -> appendAttribute + go = case b of + CantOverride -> setAttribute + Replace -> overrideAttribute + CantReplace -> defaultAttribute + AppendAttribute -> appendAttribute setAttribute :: Text -> Resource -> PValue -> InterpreterMonad Resource setAttribute attributename res value = case res ^. rattributes . at attributename of - Nothing -> return (res & rattributes . at attributename ?~ value) + Nothing -> pure (res & rattributes . at attributename ?~ value) Just curval -> do -- we must check if the resource scope is a parent of the current scope curscope <- getScopeName i <- isParent curscope (rcurcontainer res) if i -- TODO check why this is set - then return (res & rattributes . at attributename ?~ value) + then pure (res & rattributes . at attributename ?~ value) else do -- We will not bark if the same attribute is -- defined multiple times with identical values. @@ -762,42 +804,42 @@ if curval == value then checkStrict errmsg errmsg else throwPosError errmsg - return res + pure res overrideAttribute :: Text -> Resource -> PValue -> InterpreterMonad Resource -overrideAttribute attributename res value = return (res & rattributes . at attributename ?~ value) +overrideAttribute attributename res value = pure (res & rattributes . at attributename ?~ value) appendAttribute :: Text -> Resource -> PValue -> InterpreterMonad Resource appendAttribute attributename res value = do nvalue <- case (res ^. rattributes . at attributename, value) of - (Nothing, _) -> return value - (Just (PArray a), PArray b) -> return (PArray (a <> b)) - (Just (PArray a), b) -> return (PArray (V.snoc a b)) - (Just a, PArray b) -> return (PArray (V.cons a b)) - (Just a, b) -> return (PArray (V.fromList [a,b])) - return (res & rattributes . at attributename ?~ nvalue) + (Nothing, _) -> pure value + (Just (PArray a), PArray b) -> pure (PArray (a <> b)) + (Just (PArray a), b) -> pure (PArray (V.snoc a b)) + (Just a, PArray b) -> pure (PArray (V.cons a b)) + (Just a, b) -> pure (PArray (V.fromList [a,b])) + pure (res & rattributes . at attributename ?~ nvalue) defaultAttribute :: Text -> Resource -> PValue -> InterpreterMonad Resource defaultAttribute attributename res value = - return $ case res ^. rattributes . at attributename of + pure $ case res ^. rattributes . at attributename of Nothing -> res & rattributes . at attributename ?~ value Just _ -> res modifyCollectedAttribute :: Resource -> AttributeDecl -> InterpreterMonad Resource -modifyCollectedAttribute res adecl - = case adecl of - AttributeDecl attributename arrowop expr -> do - value <- resolveExpression expr - let optype = case arrowop of - AppendArrow -> AppendAttribute - AssignArrow -> Replace - addAttribute optype attributename res value - AttributeWildcard expr -> do - resolved <- resolveExpression expr - case resolved of - PHash hash -> - foldM (\curres (attrname, attrval) -> addAttribute Replace attrname curres attrval) res (itoList hash) - _ -> throwPosError ("A hash was expected, not" <+> pretty resolved) +modifyCollectedAttribute res attrdecl = + case attrdecl of + AttributeDecl attributename arrowop expr -> do + value <- resolveExpression expr + let optype = case arrowop of + AppendArrow -> AppendAttribute + AssignArrow -> Replace + addAttribute optype attributename res value + AttributeWildcard expr -> do + resolved <- resolveExpression expr + case resolved of + PHash hash -> + foldM (\curres (attrname, attrval) -> addAttribute Replace attrname curres attrval) res (itoList hash) + _ -> throwPosError ("A hash was expected, not" <+> pretty resolved) registerResource :: Text -> Text -> Container PValue -> Virtuality -> PPosition -> InterpreterMonad [Resource] registerResource "class" _ _ Virtual p = curPos .= p >> throwPosError "Cannot declare a virtual class (or perhaps you can, but I do not know what this means)" @@ -825,8 +867,7 @@ case t of "class" -> {-# SCC "rrClass" #-} do definedResources . at resid ?= r - let attrs = r ^. rattributes - (r:) <$> loadClass rn S.Nothing attrs ClassResourceLike + (r:) <$> loadClass rn S.Nothing (r^.rattributes) ClassResourceLike _ -> {-# SCC "rrGeneralCase" #-} use (definedResources . at resid) >>= \case Just otheres -> throwPosError @@ -834,13 +875,13 @@ pretty r pretty otheres Nothing -> do definedResources . at resid ?= r - return [r] + pure [r] -- functions : this can't really be exported as it uses a lot of stuff from -- this module ... mainFunctionCall :: Text -> [PValue] -> InterpreterMonad [Resource] -mainFunctionCall "showscope" _ = use curScope >>= warn . pretty >> return [] +mainFunctionCall "showscope" _ = use curScope >>= warn . pretty >> pure [] -- The logging functions mainFunctionCall "alert" a = logWithModifier Log.ALERT red a mainFunctionCall "crit" a = logWithModifier Log.CRITICAL red a @@ -857,7 +898,7 @@ classname <- resolvePValueString e use (loadedClasses . at classname) >>= \case Nothing -> loadClass classname S.Nothing mempty ClassIncludeLike - Just _ -> return [] -- TODO check that this happened after class declaration + Just _ -> pure [] -- TODO check that this happened after class declaration mainFunctionCall "include" includes = concat <$> mapM doInclude includes where @@ -868,9 +909,9 @@ mainFunctionCall "create_resources" [PString t, PHash hs, PHash defparams] = do let (ats, t') = Text.span (== '@') t virtuality <- case Text.length ats of - 0 -> return Normal - 1 -> return Virtual - 2 -> return Exported + 0 -> pure Normal + 1 -> pure Virtual + 2 -> pure Exported _ -> throwPosError "Too many @'s" p <- use curPos let genRes rname (PHash rargs) = registerResource t' rname (rargs <> defparams) virtuality p @@ -882,15 +923,15 @@ mainFunctionCall "realize" args = do pos <- use curPos let updateMod (PResourceReference t rn) = - resModifiers %= (ResourceModifier t ModifierMustMatch RealizeVirtual (REqualitySearch "title" (PString rn)) return pos : ) + resModifiers %= (ResourceModifier t ModifierMustMatch RealizeVirtual (REqualitySearch "title" (PString rn)) pure pos : ) updateMod x = throwPosError ("realize(): all arguments must be resource references, not" <+> pretty x) mapM_ updateMod args - return [] + pure [] mainFunctionCall "tag" args = do scp <- getScopeName let addTag x = scopes . ix scp . scopeExtraTags . contains x .= True mapM_ (resolvePValueString >=> addTag) args - return [] + pure [] mainFunctionCall "fail" [x] = ("fail:" <+>) . dullred . ppline <$> resolvePValueString x >>= throwPosError mainFunctionCall "fail" _ = throwPosError "fail(): This function takes a single argument" -- hiera_include does a unique merge lookup for the requested key, then calls the include function on the resulting array. @@ -901,7 +942,7 @@ curPos . _1 . _sourceName <>= " [hiera_include call]" o <- mainFunctionCall "include" classes curPos .= p - return o + pure o mainFunctionCall "hiera_include" _ = throwPosError "hiera_include(): This function takes a single argument" -- dumpinfos is a debugging function specific to language-puppet mainFunctionCall "dumpinfos" _ = do @@ -924,7 +965,7 @@ p <- use curPos let representation = MainFunctionDeclaration (MainFuncDecl fname mempty p) rs <- singleton (ExternalFunction fname args) - unless (rs == PUndef) $ throwPosError ("This function call should return" <+> pretty PUndef <+> "and not" <+> pretty rs pretty representation) + unless (rs == PUndef) $ throwPosError ("This function call should pure" <+> pretty PUndef <+> "and not" <+> pretty rs pretty representation) pure [] ensurePackages :: [PValue] -> InterpreterMonad [Resource] @@ -939,7 +980,7 @@ ensurePackages [_,_] = throwPosError "ensure_packages(): the first argument must be a string or an array of strings." ensurePackages _ = throwPosError "ensure_packages(): requires one or two arguments." --- | Takes a resource type, title, and a hash of attributes that describe the resource. +-- Takes a resource type, title, and a hash of attributes that describe the resource. -- Create the resource if it does not exist already. -- Takes a resource type, title, and a hash of attributes that describe the resource(s). ensureResource :: [PValue] -> InterpreterMonad [Resource] @@ -959,7 +1000,7 @@ ensureResource' t params title = do isdefined <- has (ix (normalizeRIdentifier t title)) <$> use definedResources if isdefined - then return [] + then pure [] else use curPos >>= registerResource t title params Normal @@ -976,15 +1017,15 @@ p <- use curPos v' <- resolvePValueString v logWriter prio (m (ppline v') <+> showPPos p) - return [] + pure [] logWithModifier _ _ _ = throwPosError "This function takes a single argument" --- | Contrary to the previous iteration, this will let non native types pass. +-- Contrary to the previous iteration, this will let non native types pass. validateNativeType :: Resource -> InterpreterMonad Resource validateNativeType r = do - tps <- singleton GetNativeTypes - case tps ^. at (r ^. rid . itype) of - Just x -> case (x ^. puppetValidate) r of - Right nr -> return nr - Left err -> throwPosError ("Invalid resource" <+> pretty r getError err) - Nothing -> return r + tps <- singleton GetNativeTypes + case tps ^. at (r ^. rid . itype) of + Just x -> case (x ^. puppetValidate) r of + Right nr -> pure nr + Left err -> throwPosError ("Invalid resource" <+> pretty r getError err) + Nothing -> pure r 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 @@ -103,6 +103,13 @@ getNodeName:: InterpreterMonad NodeName getNodeName = singleton GetNodeName +-- | Ask the value of a fact given a specified key +-- The fact set comes from the reader used by the interpreter monad. +askFact :: Text -> InterpreterMonad (Maybe PValue) +askFact key = do + facts <- singleton Facts + pure $ Map.lookup key facts + isIgnoredModule :: Text -> InterpreterMonad Bool isIgnoredModule m = singleton (IsIgnoredModule m) @@ -115,7 +122,7 @@ extMod <- isExternalModule let priority = if extMod - then Log.NOTICE + then Log.INFO else Log.WARNING str <- singleton IsStrict if str && not extMod @@ -145,20 +152,19 @@ safeDecodeUtf8 :: ByteString -> InterpreterMonad Text {-# INLINABLE safeDecodeUtf8 #-} -safeDecodeUtf8 i = return (Text.decodeUtf8 i) +safeDecodeUtf8 i = pure (Text.decodeUtf8 i) normalizeRIdentifier :: Text -> Text -> RIdentifier normalizeRIdentifier = RIdentifier . dropInitialColons - -extractFromState :: InterpreterState -> Maybe (Text, Container ScopeInformation) -extractFromState s = - let cscope = s ^. curScope - in if null cscope - then Nothing - else let scope_name = scopeName (List.head cscope) - classes = (PArray . Vector.fromList . map PString . Map.keys) (s ^. loadedClasses) - scps = s ^. scopes - container_desc = fromMaybe ContRoot (scps ^? ix scope_name . scopeContainer . cctype) -- get the current containder description - cscps = scps & ix scope_name . scopeVariables . at "classes" ?~ ( classes :!: (initialPPos mempty) :!: container_desc ) - in Just (scope_name, cscps) +extractScope :: InterpreterState -> Maybe (Text, Container ScopeInformation) +extractScope s = + let cscope = s ^. curScope in + if null cscope + then Nothing + else let scope_name = scopeName (List.head cscope) + classes = (PArray . Vector.fromList . map PString . Map.keys) (s ^. loadedClasses) + scps = s ^. scopes + container_desc = fromMaybe ContRoot (scps ^? ix scope_name . scopeContainer . cctype) -- get the current containder description + cscps = scps & ix scope_name . scopeVariables . at "classes" ?~ ( classes :!: (initialPPos mempty) :!: container_desc ) + in Just (scope_name, cscps) 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 @@ -60,6 +60,7 @@ WriterPass _ -> thpe "WriterPass" WriterListen _ -> thpe "WriterListen" PuppetPaths -> runInstr (r ^. readerPuppetPaths) + Facts -> runInstr (r ^. readerFacts) RebaseFile -> runInstr (r ^. readerRebaseFile) GetNativeTypes -> runInstr (r ^. readerNativeTypes) ErrorThrow d -> return (Left d, s, mempty) @@ -69,7 +70,7 @@ PDBReplaceCatalog w -> canFailX (replaceCatalog pdb w) PDBReplaceFacts fcts -> canFailX (replaceFacts pdb fcts) PDBDeactivateNode nn -> canFailX (deactivateNode pdb nn) - PDBGetFacts q -> canFailX (getFacts pdb q) + PDBGetFacts q -> canFailX (getPDBFacts pdb q) PDBGetResources q -> canFailX (getResources pdb q) PDBGetNodes q -> canFailX (getNodes pdb q) PDBCommitDB -> canFailX (commitDB pdb) @@ -90,9 +91,16 @@ -- query all hiera layers queryHiera :: Monad m => HieraQueryLayers m -> Container Text -> Text -> HieraQueryType -> m (S.Either PrettyError (Maybe PValue)) queryHiera layers scps q t = do - val <- (layers^.globalLayer) scps q t - case val of + 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 @@ -100,5 +108,4 @@ [_] -> Nothing (m:_) -> Just m layer = modname >>= (\n -> layers ^.moduleLayer.at n) - maybe (pure val) (\hq -> hq scps q t) layer - _ -> pure val + maybe (pure $ S.Right Nothing) (\hq -> hq scps q t) layer diff --git a/src/Puppet/Interpreter/PrettyPrinter.hs b/src/Puppet/Interpreter/PrettyPrinter.hs --- a/src/Puppet/Interpreter/PrettyPrinter.hs +++ b/src/Puppet/Interpreter/PrettyPrinter.hs @@ -68,6 +68,7 @@ pretty (TraceEvent e) = pf "TraceEvent" [ppstring e] pretty (IsIgnoredModule m) = pf "IsIgnoredModule" [ppline m] pretty (IsExternalModule m) = pf "IsExternalModule" [ppline m] + pretty Facts = pf "Facts" [] instance Pretty LinkInformation where pretty (LinkInformation lsrc ldst ltype lpos) = pretty lsrc <+> pretty ltype <+> pretty ldst <+> showPPos lpos 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 @@ -32,7 +32,8 @@ hfRestorevars, fixResourceName, datatypeMatch, - checkMatch + checkMatch, + typeOf ) where import XPrelude.Extra @@ -100,7 +101,7 @@ vars = HM.fromList (toplevels <> locals) Operational.singleton (HieraQuery vars q t) --- | The implementation of all hiera_* functions +-- | The implementation of all lookup functions hieraCall :: HieraQueryType -> PValue -> Maybe PValue -> Maybe DataType -> Maybe PValue -> InterpreterMonad PValue hieraCall _ _ _ _ (Just _) = throwPosError "Overriding the hierarchy is not supported (and deprecated in puppet)" hieraCall qt q df dt _ = do @@ -194,6 +195,26 @@ -- for case insensitive matching _ -> ra == rb +-- Match a left expression with a regex +-- Return a contextual True/False or Error after executing against the regex +matchExpression :: Expression -> (Regex, Expression) -> InterpreterMonad PValue +matchExpression a (rv, rexpr) = do + ra <- Text.encodeUtf8 <$> resolveExpressionString a + case Regex.execute' rv ra of + Left (_,rr) -> throwPosError ("Error when executing regex" <+> pretty rexpr <+> ":" <+> pretty rr) + Right Nothing -> pure $ PBoolean False + Right (Just matches) -> do + -- A bit of logic to save the capture variables. + -- Note that this will pollute the namespace, as it should only + -- happen in conditional expressions ... + p <- use curPos + ctype <- view cctype <$> getCurContainer + let captures = zip (map (Text.pack . show) [(0 :: Int)..]) (map mkMatch (toList matches)) + mkMatch (offset, len) = PString (Text.decodeUtf8 (BS.take len (BS.drop offset ra))) :!: p :!: ctype + scp <- getScopeName + scopes . ix scp . scopeVariables %= HM.union (HM.fromList captures) + pure $ PBoolean True + -- | The main resolution function : turns an 'Expression' into a 'PValue', -- if possible. resolveExpression :: Expression -> InterpreterMonad PValue @@ -207,7 +228,7 @@ pure (PBoolean (ra && rb)) else pure (PBoolean False) resolveExpression (Or a b) = do - ra <- fmap pValue2Bool (resolveExpression a) + ra <- pValue2Bool <$> resolveExpression a if ra then pure (PBoolean True) else do @@ -218,22 +239,11 @@ resolveExpression (LessEqualThan a b) = numberCompare a b (<=) resolveExpression (MoreEqualThan a b) = numberCompare a b (>=) resolveExpression (RegexMatch a v@(Terminal (URegexp (CompRegex _ rv)))) = do - ra <- fmap Text.encodeUtf8 (resolveExpressionString a) - case Regex.execute' rv ra of - Left (_,rr) -> throwPosError ("Error when evaluating" <+> pretty v <+> ":" <+> ppstring rr) - Right Nothing -> pure $ PBoolean False - Right (Just matches) -> do - -- A bit of logic to save the capture variables. - -- Note that this will pollute the namespace, as it should only - -- happen in conditional expressions ... - p <- use curPos - ctype <- view cctype <$> getCurContainer - let captures = zip (map (Text.pack . show) [(0 :: Int)..]) (map mkMatch (toList matches)) - mkMatch (offset, len) = PString (Text.decodeUtf8 (BS.take len (BS.drop offset ra))) :!: p :!: ctype - scp <- getScopeName - scopes . ix scp . scopeVariables %= HM.union (HM.fromList captures) - pure $ PBoolean True -resolveExpression (RegexMatch _ t) = throwPosError ("The regexp matching operator expects a regular expression, not" <+> pretty t) + matchExpression a (rv, v) +resolveExpression (RegexMatch a b) = do + resolveExpression b >>= \case + PRegexp (CompRegex _ rv) -> matchExpression a (rv, b) + _ -> throwPosError ("The regexp matching operator expects a regular expression, not" <+> pretty b) resolveExpression (NotRegexMatch a v) = resolveExpression (Not (RegexMatch a v)) resolveExpression (Equal a b) = do ra <- resolveExpression a @@ -274,7 +284,7 @@ if arl <= i then throwPosError ("Out of bound indexing, array size is" <+> pretty arl <+> "index is" <+> pretty i) else pure (ar V.! i) - src -> throwPosError ("This data can't be indexed:" <+> pretty src) + _ -> throwPosError ("Enable to resolve a 'Lookup' expression. Cannot index:" <+> pretty a <+> "at" <+> pretty idx) resolveExpression stmt@(ConditionalValue e conds) = do rese <- resolveExpression e let checkCond [] = throwPosError ("The selector didn't match anything for input" <+> pretty rese pretty stmt) @@ -322,9 +332,9 @@ (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 (S.isNothing (hol ^. hoLambdaExpr)) + 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 .~ S.Just e)) + 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 @@ -332,7 +342,7 @@ -- a 'PValue' resolveValue :: UnresolvedValue -> InterpreterMonad PValue resolveValue (UNumber n) = pure (PNumber n) -resolveValue n@(URegexp _) = throwPosError ("Regular expressions are not allowed in this context: " <+> pretty n) +resolveValue (URegexp r) = pure (PRegexp r) resolveValue (UBoolean x) = pure (PBoolean x) resolveValue (UString x) = pure (PString x) resolveValue UUndef = pure PUndef @@ -390,7 +400,7 @@ -- | Turns a 'PValue' into a 'Bool' as explained in the reference documentation. pValue2Bool :: PValue -> Bool pValue2Bool PUndef = False -pValue2Bool (PString "") = False +pValue2Bool (PString "") = True pValue2Bool (PBoolean x) = x pValue2Bool _ = True @@ -571,10 +581,10 @@ Aeson.Success x -> pure x Aeson.Error rr -> throwPosError ("For some reason we could not convert a resource list to Puppet internal values!!" <+> ppstring rr <+> pretty rrv) let extractSubHash :: Text -> PValue -> InterpreterMonad PValue - extractSubHash ky (PHash h) = - case h ^. at ky of + extractSubHash k (PHash h) = + case h ^. at k of Just val -> pure val - Nothing -> throwPosError ("pdbresourcequery strange error, could not find key" <+> ppline ky <+> "in" <+> pretty (PHash h)) + Nothing -> throwPosError ("pdbresourcequery strange error, could not find key" <+> ppline k <+> "in" <+> pretty (PHash h)) extractSubHash _ x = throwPosError ("pdbresourcequery strange error, expected a hash, had" <+> pretty x) case mkey of Nothing -> pure (PArray rv) @@ -674,25 +684,26 @@ -- Each item corresponds to an iteration in the calling block. hfGenerateAssociations :: HOLambdaCall -> InterpreterMonad [[(Text, PValue)]] hfGenerateAssociations hol = do - sourceexpression <- case hol ^. hoLambdaExpr of - S.Just x -> pure x - S.Nothing -> throwPosError ("No expression to run the function on" <+> pretty hol) + sourceexpression <- case hol ^.. hoLambdaExpr . folded of + [x] -> pure x + [] -> throwPosError ("No expression to run the function on" <+> pretty hol) + _ -> throwPosError ("Too many expressions to run the function on" <+> pretty hol) sourcevalue <- resolveExpression sourceexpression let check Nothing _ = pure () check (Just udtype) tocheck = do dtype <- resolveDataType udtype mapM_ (\v -> unless (datatypeMatch dtype v) (throwPosError (pretty v <+> "isn't of type" <+> pretty dtype))) tocheck - case (sourcevalue, hol ^. hoLambdaParams) of - (PArray pr, BPSingle (LParam mvtype varname)) -> do + case (sourcevalue, V.toList (hol ^. hoLambdaParams)) of + (PArray pr, [LambdaParam mvtype varname]) -> do check mvtype pr pure (map (\x -> [(varname, x)]) (V.toList pr)) - (PArray pr, BPPair (LParam _ idx) (LParam mvtype var)) -> do + (PArray pr, [LambdaParam _ idx, LambdaParam mvtype var] ) -> do check mvtype pr pure [ [(idx,PString (Text.pack (show i))),(var,v)] | (i,v) <- zip ([0..] :: [Int]) (V.toList pr) ] - (PHash hh, BPSingle (LParam mvtype varname)) -> do + (PHash hh, [LambdaParam mvtype varname]) -> do check mvtype hh pure [ [(varname, PArray (V.fromList [PString k,v]))] | (k,v) <- HM.toList hh] - (PHash hh, BPPair (LParam midxtype idx) (LParam mvtype var)) -> do + (PHash hh, [LambdaParam midxtype idx, LambdaParam mvtype var]) -> do check mvtype hh check midxtype (PString <$> HM.keys hh) pure [ [(idx,PString k),(var,v)] | (k,v) <- HM.toList hh] @@ -748,7 +759,6 @@ evaluateHFCPure :: HOLambdaCall -> InterpreterMonad PValue evaluateHFCPure hol' = do (hol, finalexpression) <- transformPureHf hol' - varassocs <- hfGenerateAssociations hol let runblock :: [(Text, PValue)] -> InterpreterMonad PValue runblock assocs = do saved <- hfSetvars assocs @@ -757,18 +767,34 @@ hfRestorevars saved pure r case hol ^. hoLambdaFunc of - LambEach -> throwPosError "The 'each' function can't be used at the value level in language-puppet. Please use map." - LambMap -> fmap (PArray . V.fromList) (mapM runblock varassocs) - LambFilter -> do + LambdaFunc "each" -> throwPosError "The 'each' function can't be used at the value level in language-puppet. Please use map." + LambdaFunc "map" -> do + varassocs <- hfGenerateAssociations hol + fmap (PArray . V.fromList) (mapM runblock varassocs) + LambdaFunc "with" -> do + let expressions = hol ^. hoLambdaExpr + parameters = hol ^. hoLambdaParams + unless (V.length expressions == V.length parameters) + (throwPosError ("Mismatched number of arguments and lambda parameters in" <> pretty hol)) + assocs <- forM (V.zip expressions parameters) $ \(uval, LambdaParam mt name) -> do + val <- resolveExpression uval + -- type checking + forM_ mt $ \ut -> do + t <- resolveDataType ut + checkMatch t val + return (name, val) + runblock (V.toList assocs) + LambdaFunc "filter" -> do + varassocs <- hfGenerateAssociations hol res <- mapM (fmap pValue2Bool . runblock) varassocs - sourcevalue <- case hol ^. hoLambdaExpr of - S.Just x -> resolveExpression x - S.Nothing -> throwPosError "Internal error evaluateHFCPure 1" + sourcevalue <- case hol ^.. hoLambdaExpr . folded of + [x] -> resolveExpression x + _ -> throwPosError "Internal error evaluateHFCPure 1" case sourcevalue of 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) - x -> throwPosError ("This type of function is not supported yet by language-puppet!" <+> pretty x) + x -> throwPosError ("This type of lambda function is not supported yet by language-puppet!" <+> pretty x) -- | Checks that a value matches a puppet datatype datatypeMatch :: DataType -> PValue -> Bool @@ -812,3 +838,18 @@ checkMatch :: DataType -> PValue -> InterpreterMonad () checkMatch dt pv = unless (datatypeMatch dt pv) (throwPosError (pretty pv <+> "does not match type" <+> pretty dt)) + +typeOf :: PValue -> DataType +typeOf pv = + case pv of + PBoolean _ -> DTBoolean + PUndef -> DTUndef + PString _ -> DTString Nothing Nothing + PResourceReference _ _ -> DTType -- ??? + PArray _ -> DTArray DTAny 0 Nothing + PHash _ -> DTHash DTAny DTAny 0 Nothing + PType _ -> DTType + PRegexp _ -> DTRegexp Nothing + PNumber n -> if Scientific.isInteger n + then DTInteger Nothing Nothing + else DTFloat Nothing Nothing diff --git a/src/Puppet/Interpreter/RubyRandom.hs b/src/Puppet/Interpreter/RubyRandom.hs --- a/src/Puppet/Interpreter/RubyRandom.hs +++ b/src/Puppet/Interpreter/RubyRandom.hs @@ -1,6 +1,5 @@ module Puppet.Interpreter.RubyRandom - ( rbGenrandInt32 - , randInit + ( randInit , limitedRand ) where @@ -99,20 +98,6 @@ then initGenrand x else initGenrandBigint x -rbGenrandInt32 :: RandState -> (Int, RandState) -rbGenrandInt32 st = - let rst = if _left st == 1 - then nextState st - else st { _left = _left st - 1 } - next = _next rst - cv = _array rst V.! next - nst = rst { _next = next + 1 } - y1 = cv `xor` (cv `shiftR` 11) - y2 = y1 `xor` ((y1 `shiftL` 7) .&. 0x9d2c5680) - y3 = y2 `xor` ((y2 `shiftL` 15) .&. 0xefc60000) - y4 = y3 `xor` (y3 `shiftR` 18) - in (y4,nst) - limitedRand :: RandState -> Int -> (Int, RandState) limitedRand s n | n <= 0 = (0, s) | otherwise = limitedRand' s @@ -124,3 +109,16 @@ in if n <= val then limitedRand' ns else (val, ns) + rbGenrandInt32 :: RandState -> (Int, RandState) + rbGenrandInt32 st = + let rst = if _left st == 1 + then nextState st + else st { _left = _left st - 1 } + next = _next rst + cv = _array rst V.! next + nst = rst { _next = next + 1 } + y1 = cv `xor` (cv `shiftR` 11) + y2 = y1 `xor` ((y1 `shiftL` 7) .&. 0x9d2c5680) + y3 = y2 `xor` ((y2 `shiftL` 15) .&. 0xefc60000) + y4 = y3 `xor` (y3 `shiftR` 18) + in (y4,nst) 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 @@ -31,6 +31,7 @@ , readerExternalModules , readerIsStrict , readerPuppetPaths + , readerFacts , readerRebaseFile -- * Interpreter monad , InterpreterMonad @@ -79,6 +80,7 @@ -- * Hiera , HieraQueryLayers(..) , globalLayer + , environmentLayer , moduleLayer -- * Template , TemplateSource(..) @@ -89,6 +91,7 @@ import XPrelude.Extra import XPrelude.PP +import qualified Control.Monad.Fail as Fail import Control.Monad.Operational import Control.Monad.State.Strict import Control.Monad.Writer.Class @@ -203,6 +206,7 @@ -- The datatype belongs to the "Puppet.Interpreter" module because it serves to implement how Hiera is used within Puppet. data HieraQueryLayers m = HieraQueryLayers { _globalLayer :: HieraQueryFunc m + , _environmentLayer :: HieraQueryFunc m , _moduleLayer :: Container (HieraQueryFunc m) } @@ -210,71 +214,75 @@ data TemplateSource= Inline Text | Filename FilePath data InterpreterReader m = InterpreterReader - { _readerNativeTypes :: !(Container NativeTypeMethods) - , _readerGetStatement :: TopLevelType -> Text -> m (S.Either PrettyError Statement) - , _readerGetTemplate :: TemplateSource-> InterpreterState -> InterpreterReader m -> m (S.Either PrettyError Text) - , _readerPdbApi :: PuppetDBAPI m - , _readerExternalFunc :: Container ([PValue] -> InterpreterMonad PValue) -- ^ External func such as stdlib or puppetlabs - , _readerNodename :: Text - , _readerHieraQuery :: HieraQueryLayers m - , _readerIoMethods :: IoMethods m - , _readerIgnoredModules :: HashSet Text + { _readerNativeTypes :: !(Container NativeTypeMethods) + , _readerGetStatement :: TopLevelType -> Text -> m (S.Either PrettyError Statement) -- ^ Access to parsed statements + , _readerGetTemplate :: TemplateSource -> InterpreterState -> InterpreterReader m -> m (S.Either PrettyError Text) + , _readerPdbApi :: PuppetDBAPI m + , _readerExternalFunc :: Container ([PValue] -> InterpreterMonad PValue) -- ^ External func such as stdlib or puppetlabs + , _readerNodename :: Text + , _readerHieraQuery :: HieraQueryLayers m + , _readerIoMethods :: IoMethods m + , _readerIgnoredModules :: HashSet Text , _readerExternalModules :: HashSet Text - , _readerIsStrict :: Bool - , _readerPuppetPaths :: PuppetDirPaths - , _readerRebaseFile :: Maybe FilePath + , _readerIsStrict :: Bool + , _readerPuppetPaths :: PuppetDirPaths + , _readerRebaseFile :: Maybe FilePath + , _readerFacts :: Container PValue -- ^ Access to the list of facts that were given to the 'Preferences' module } data InterpreterInstr a where -- Utility for using what's in 'InterpreterReader' - GetNativeTypes :: InterpreterInstr (Container NativeTypeMethods) - GetStatement :: TopLevelType -> Text -> InterpreterInstr Statement - ComputeTemplate :: TemplateSource-> InterpreterState -> InterpreterInstr Text - ExternalFunction :: Text -> [PValue] -> InterpreterInstr PValue - GetNodeName :: InterpreterInstr Text - HieraQuery :: Container Text -> Text -> HieraQueryType -> InterpreterInstr (Maybe PValue) - GetCurrentCallStack :: InterpreterInstr [String] - IsIgnoredModule :: Text -> InterpreterInstr Bool - IsExternalModule :: Text -> InterpreterInstr Bool - IsStrict :: InterpreterInstr Bool - PuppetPaths :: InterpreterInstr PuppetDirPaths - RebaseFile :: InterpreterInstr (Maybe FilePath) + GetNativeTypes :: InterpreterInstr (Container NativeTypeMethods) + GetStatement :: TopLevelType -> Text -> InterpreterInstr Statement + ComputeTemplate :: TemplateSource-> InterpreterState -> InterpreterInstr Text + ExternalFunction :: Text -> [PValue] -> InterpreterInstr PValue + Facts :: InterpreterInstr (Container PValue) + GetNodeName :: InterpreterInstr Text + HieraQuery :: Container Text -> Text -> HieraQueryType -> InterpreterInstr (Maybe PValue) + GetCurrentCallStack :: InterpreterInstr [String] + IsIgnoredModule :: Text -> InterpreterInstr Bool + IsExternalModule :: Text -> InterpreterInstr Bool + IsStrict :: InterpreterInstr Bool + PuppetPaths :: InterpreterInstr PuppetDirPaths + RebaseFile :: InterpreterInstr (Maybe FilePath) -- error - ErrorThrow :: PrettyError -> InterpreterInstr a - ErrorCatch :: InterpreterMonad a -> (PrettyError -> InterpreterMonad a) -> InterpreterInstr a + ErrorThrow :: PrettyError -> InterpreterInstr a + ErrorCatch :: InterpreterMonad a -> (PrettyError -> InterpreterMonad a) -> InterpreterInstr a -- writer - WriterTell :: InterpreterWriter -> InterpreterInstr () - WriterPass :: InterpreterMonad (a, InterpreterWriter -> InterpreterWriter) -> InterpreterInstr a - WriterListen :: InterpreterMonad a -> InterpreterInstr (a, InterpreterWriter) - -- puppetdb wrappers, see 'PuppetDBAPI' for details - PDBInformation :: InterpreterInstr Doc - PDBReplaceCatalog :: WireCatalog -> InterpreterInstr () - PDBReplaceFacts :: [(NodeName, Facts)] -> InterpreterInstr () - PDBDeactivateNode :: NodeName -> InterpreterInstr () - PDBGetFacts :: Query FactField -> InterpreterInstr [FactInfo] - PDBGetResources :: Query ResourceField -> InterpreterInstr [Resource] - PDBGetNodes :: Query NodeField -> InterpreterInstr [NodeInfo] - PDBCommitDB :: InterpreterInstr () + WriterTell :: InterpreterWriter -> InterpreterInstr () + WriterPass :: InterpreterMonad (a, InterpreterWriter -> InterpreterWriter) -> InterpreterInstr a + WriterListen :: InterpreterMonad a -> InterpreterInstr (a, InterpreterWriter) + -- puppetdb wrappers , see 'PuppetDBAPI' for details + PDBInformation :: InterpreterInstr Doc + PDBReplaceCatalog :: WireCatalog -> InterpreterInstr () + PDBReplaceFacts :: [(NodeName, Facts)] -> InterpreterInstr () + PDBDeactivateNode :: NodeName -> InterpreterInstr () + PDBGetFacts :: Query FactField -> InterpreterInstr [FactInfo] + PDBGetResources :: Query ResourceField -> InterpreterInstr [Resource] + PDBGetNodes :: Query NodeField -> InterpreterInstr [NodeInfo] + PDBCommitDB :: InterpreterInstr () PDBGetResourcesOfNode :: NodeName -> Query ResourceField -> InterpreterInstr [Resource] -- Reading the first file that can be read in a list - ReadFile :: [Text] -> InterpreterInstr Text + ReadFile :: [Text] -> InterpreterInstr Text -- Tracing events - TraceEvent :: String -> InterpreterInstr () + TraceEvent :: String -> InterpreterInstr () -- | The main monad type InterpreterMonad = ProgramT InterpreterInstr (State InterpreterState) +instance Fail.MonadFail InterpreterMonad where + fail = throwError . PrettyError . ppstring + instance MonadError PrettyError InterpreterMonad where - throwError = singleton . ErrorThrow - catchError a c = singleton (ErrorCatch a c) + throwError = singleton . ErrorThrow + catchError a c = singleton (ErrorCatch a c) -- | Log type InterpreterWriter = [Pair Log.Priority Doc] instance MonadWriter InterpreterWriter InterpreterMonad where - tell = singleton . WriterTell - pass = singleton . WriterPass - listen = singleton . WriterListen - + tell = singleton . WriterTell + pass = singleton . WriterPass + listen = singleton . WriterListen data ResourceModifier = ResourceModifier { _rmResType :: !Text diff --git a/src/Puppet/Language/NativeTypes/Helpers.hs b/src/Puppet/Language/NativeTypes/Helpers.hs --- a/src/Puppet/Language/NativeTypes/Helpers.hs +++ b/src/Puppet/Language/NativeTypes/Helpers.hs @@ -19,10 +19,8 @@ , fullyQualifieds , values , defaultvalue - , concattype , nameval , defaultValidate - , parameterFunctions , integer , integers , mandatory @@ -82,9 +80,6 @@ faketype :: NativeTypeName -> (NativeTypeName, NativeTypeMethods) faketype tname = (tname, NativeTypeMethods Right HS.empty) -concattype :: NativeTypeName -> (NativeTypeName, NativeTypeMethods) -concattype tname = (tname, NativeTypeMethods (defaultValidate HS.empty) HS.empty) - defaulttype :: NativeTypeName -> (NativeTypeName, NativeTypeMethods) defaulttype tname = (tname, NativeTypeMethods (defaultValidate HS.empty) HS.empty) @@ -146,8 +141,6 @@ PNumber n -> Right (res & rattributes . at param ?~ PString (scientific2text n)) x -> perror $ "Parameter" <+> paramname param <+> "should be a string, and not" <+> pretty x - - -- | Makes sure that the parameter, if defined, has a value among this list. values :: [Text] -> Text -> NativeTypeValidate values valuelist param res = case res ^. rattributes . at param of @@ -203,7 +196,7 @@ Just _ -> Right res Nothing -> perror $ "Parameter" <+> paramname param <+> "should be set." --- | Helper that takes a list of stuff and will generate a validator. +-- Helper that takes a list of stuff and will generate a validator. parameterFunctions :: [(Text, [Text -> NativeTypeValidate])] -> NativeTypeValidate parameterFunctions argrules rs = foldM parameterFunctions' rs argrules where diff --git a/src/Puppet/Parser.hs b/src/Puppet/Parser.hs --- a/src/Puppet/Parser.hs +++ b/src/Puppet/Parser.hs @@ -1,46 +1,25 @@ -{-# LANGUAGE TupleSections #-} - {-| Parse puppet source code from text. -} module Puppet.Parser ( -- * Runner runPuppetParser -- * Parsers - , Parser , puppetParser - , PuppetParseError , prettyParseError - -- ** exposed to ease testing - , expression - , datatype -- * Pretty Print , module Puppet.Parser.PrettyPrinter , module Puppet.Parser.Types , module Puppet.Parser.Lens ) where -import XPrelude.Extra hiding (option, try, many, some) -import XPrelude.PP hiding (braces, comma, brackets, parens, sep) +import XPrelude -import qualified Data.Char as Char -import qualified Data.List as List -import qualified Data.List.NonEmpty as NE -import qualified Data.Maybe.Strict as S -import qualified Data.Scientific as Scientific -import qualified Data.Text as Text -import qualified Data.Vector as V import Text.Megaparsec -import Text.Megaparsec.Char -import qualified Text.Megaparsec.Char.Lexer as Lexer -import Control.Monad.Combinators.Expr -import qualified Text.Regex.PCRE.ByteString.Utils as Regex -import Puppet.Language -import Puppet.Parser.Lens import Puppet.Parser.PrettyPrinter +import Puppet.Parser.Lens +import Puppet.Parser.Internal import Puppet.Parser.Types -type PuppetParseError = ParseError Char Void -type Parser = Parsec Void Text -- | Build a 'PrettyError' from a 'ParseError' given the text source. -- The source is used to display the line on which the error occurs. @@ -51,759 +30,6 @@ runPuppetParser :: String -> Text -> Either (ParseErrorBundle Text Void) (Vector Statement) runPuppetParser = parse puppetParser --- space consumer -sc :: Parser () -sc = Lexer.space space1 (Lexer.skipLineComment "#") (Lexer.skipBlockComment "/*" "*/") - -lexeme :: Parser a -> Parser a -lexeme = Lexer.lexeme sc - -symbol :: Text -> Parser () -symbol = void . Lexer.symbol sc - -symbolic :: Char -> Parser () -symbolic = symbol . Text.singleton - -integerOrDouble :: Parser (Either Integer Double) -integerOrDouble = fmap Left hex <|> (either Right Left . Scientific.floatingOrInteger <$> Lexer.scientific) - where - hex = string "0x" *> Lexer.hexadecimal - -braces :: Parser a -> Parser a -braces = between (symbol "{") (symbol "}") - -parens :: Parser a -> Parser a -parens = between (symbol "(") (symbol ")") - -brackets :: Parser a -> Parser a -brackets = between (symbol "[") (symbol "]") - -comma :: Parser () -comma = symbol "," - -sepComma :: Parser a -> Parser [a] -sepComma p = p `sepEndBy` comma - -sepComma1 :: Parser a -> Parser [a] -sepComma1 p = p `sepEndBy1` comma - -- | Parse a collection of puppet 'Statement'. puppetParser :: Parser (Vector Statement) puppetParser = optional sc >> statementList - --- | Parse an 'Expression'. -expression :: Parser Expression -expression = - condExpression - <|> makeExprParser (lexeme terminal) expressionTable - "expression" - where - condExpression = do - selectedExpression <- try $ do - trm <- lexeme terminal - lookups <- optional indexLookupChain - symbolic '?' - return $ maybe trm ($ trm) lookups - let cas = do - c <- (SelectorDefault <$ symbol "default") -- default case - <|> fmap SelectorType (try datatype) - <|> fmap SelectorValue - ( fmap UVariableReference variableReference - <|> fmap UBoolean puppetBool - <|> (UUndef <$ symbol "undef") - <|> literalValue - <|> fmap UInterpolable interpolableString - <|> (URegexp <$> termRegexp) - ) - void $ symbol "=>" - e <- expression - return (c :!: e) - cases <- braces (sepComma1 cas) - return (ConditionalValue selectedExpression (V.fromList cases)) - -variable :: Parser Expression -variable = Terminal . UVariableReference <$> variableReference - -stringLiteral' :: Parser Text -stringLiteral' = char '\'' *> interior <* symbolic '\'' - where - interior = Text.pack . concat <$> many (some (noneOf ['\'', '\\']) <|> (char '\\' *> fmap escape anySingle)) - escape '\'' = "'" - escape x = ['\\',x] - -identifier :: Parser String -identifier = some (satisfy identifierPart) - -identifierPart :: Char -> Bool -identifierPart x = Char.isAsciiLower x || Char.isAsciiUpper x || Char.isDigit x || (x == '_') - -identl :: Parser Char -> Parser Char -> Parser Text -identl fstl nxtl = do - f <- fstl - nxt <- lexeme $ many nxtl - return $ Text.pack $ f : nxt - -operator :: Text -> Parser () -operator = void . try . symbol - -reserved :: Text -> Parser () -reserved s = - try $ do - void (string s) - notFollowedBy (satisfy identifierPart) - sc - -variableName :: Parser Text -variableName = do - let acceptablePart = Text.pack <$> many (satisfy identifierAcceptable) - identifierAcceptable x = Char.isAsciiLower x || Char.isAsciiUpper x || Char.isDigit x || (x == '_') - out <- qualif acceptablePart - when (out == "string") (panic "The special variable $string should never be used") - return out - -qualif :: Parser Text -> Parser Text -qualif p = lexeme $ do - header <- option "" (string "::") - ( header <> ) . Text.intercalate "::" <$> p `sepBy1` string "::" - -qualif1 :: Parser Text -> Parser Text -qualif1 p = try $ do - r <- qualif p - unless ("::" `Text.isInfixOf` r) (fail "This parser is not qualified") - return r - -className :: Parser Text -className = qualif moduleName - --- yay with reserved words -typeName :: Parser Text -typeName = className - -moduleName :: Parser Text -moduleName = genericModuleName False - -resourceNameRef :: Parser Text -resourceNameRef = qualif (genericModuleName True) - -genericModuleName :: Bool -> Parser Text -genericModuleName isReference = do - let acceptable x = Char.isAsciiLower x || Char.isDigit x || (x == '_') - firstletter = if isReference - then fmap Char.toLower (satisfy Char.isAsciiUpper) - else satisfy Char.isAsciiLower - identl firstletter (satisfy acceptable) - -parameterName :: Parser Text -parameterName = moduleName - -variableReference :: Parser Text -variableReference = char '$' *> variableName - -interpolableString :: Parser (Vector Expression) -interpolableString = V.fromList <$> between (char '"') (symbolic '"') - ( many (interpolableVariableReference <|> doubleQuotedStringContent <|> fmap (Terminal . UString . Text.singleton) (char '$')) ) - where - doubleQuotedStringContent = Terminal . UString . Text.pack . concat <$> - some ((char '\\' *> fmap escaper anySingle) <|> some (noneOf [ '"', '\\', '$' ])) - escaper :: Char -> String - escaper 'n' = "\n" - escaper 't' = "\t" - escaper 'r' = "\r" - escaper '"' = "\"" - escaper '\\' = "\\" - escaper '$' = "$" - escaper x = ['\\',x] - -- this is specialized because we can't be "tokenized" here - variableAccept x = Char.isAsciiLower x || Char.isAsciiUpper x || Char.isDigit x || x == '_' - rvariableName = do - v <- Text.concat <$> some (string "::" <|> fmap Text.pack (some (satisfy variableAccept))) - when (v == "string") (fail "The special variable $string must not be used") - return v - rvariable = Terminal . UVariableReference <$> rvariableName - simpleIndexing = Lookup <$> rvariable <*> between (symbolic '[') (symbolic ']') expression - interpolableVariableReference = do - void (char '$') - let fenced = try (simpleIndexing <* char '}') - <|> try (rvariable <* char '}') - <|> (expression <* char '}') - (symbolic '{' *> fenced) <|> try rvariable <|> pure (Terminal (UString (Text.singleton '$'))) - -regexp :: Parser Text -regexp = do - void (char '/') - Text.pack . concat <$> many ( do { void (char '\\') ; x <- anySingle; return ['\\', x] } <|> some (noneOf [ '/', '\\' ]) ) - <* symbolic '/' - -puppetArray :: Parser UnresolvedValue -puppetArray = fmap (UArray . V.fromList) (brackets (sepComma expression)) "Array" - -puppetHash :: Parser UnresolvedValue -puppetHash = fmap (UHash . V.fromList) (braces (sepComma hashPart)) "Hash" - where - hashPart = (:!:) <$> (expression <* operator "=>") - <*> expression - -puppetBool :: Parser Bool -puppetBool = (reserved "true" >> return True) - <|> (reserved "false" >> return False) - "Boolean" - -resourceReferenceRaw :: Parser (Text, [Expression]) -resourceReferenceRaw = do - restype <- resourceNameRef "Resource reference type" - resnames <- brackets (expression `sepBy1` comma) "Resource reference values" - return (restype, resnames) - -resourceReference :: Parser UnresolvedValue -resourceReference = do - (restype, resnames) <- resourceReferenceRaw - return $ UResourceReference restype $ case resnames of - [x] -> x - _ -> Terminal $ UArray (V.fromList resnames) - -bareword :: Parser Text -bareword = identl (satisfy Char.isAsciiLower) (satisfy acceptable) "Bare word" - where - acceptable x = Char.isAsciiLower x || Char.isAsciiUpper x || Char.isDigit x || (x == '_') || (x == '-') - --- The first argument defines if non-parenthesized arguments are acceptable -genFunctionCall :: Bool -> Parser (Text, Vector Expression) -genFunctionCall nonparens = do - fname <- moduleName "Function name" - -- this is a hack. Contrary to what the documentation says, - -- a "bareword" can perfectly be a qualified name : - -- include foo::bar - let argsc sep e = (fmap (Terminal . UString) (qualif1 className) <|> e "Function argument A") `sep` comma - terminalF = terminalG (fail "function hack") - expressionF = makeExprParser (lexeme terminalF) expressionTable "function expression" - withparens = parens (argsc sepEndBy expression) - withoutparens = argsc sepEndBy1 expressionF - args <- withparens <|> if nonparens - then withoutparens "Function arguments B" - else fail "Function arguments C" - return (fname, V.fromList args) - - -literalValue :: Parser UnresolvedValue -literalValue = lexeme (fmap UString stringLiteral' <|> fmap UString bareword <|> fmap UNumber numericalvalue "Literal Value") - where - numericalvalue = integerOrDouble >>= \i -> case i of - Left x -> return (fromIntegral x) - Right y -> return (Scientific.fromFloatDigits y) - --- this is a hack for functions :( -terminalG :: Parser Expression -> Parser Expression -terminalG g = parens expression - <|> fmap (Terminal . UInterpolable) interpolableString - <|> (Terminal UUndef <$ reserved "undef") - <|> fmap (Terminal . URegexp) termRegexp - <|> variable - <|> fmap Terminal puppetArray - <|> fmap Terminal puppetHash - <|> fmap (Terminal . UBoolean) puppetBool - <|> fmap (Terminal . UDataType) datatype - <|> fmap Terminal resourceReference - <|> g - <|> fmap Terminal literalValue - -compileRegexp :: Text -> Parser CompRegex -compileRegexp p = case Regex.compile' Regex.compBlank Regex.execBlank (encodeUtf8 p) of - Right r -> return $ CompRegex p r - Left ms -> fail ("Can't parse regexp /" ++ Text.unpack p ++ "/ : " ++ show ms) - -termRegexp :: Parser CompRegex -termRegexp = regexp >>= compileRegexp - -terminal :: Parser Expression -terminal = terminalG (fmap Terminal (fmap UHOLambdaCall (try lambdaCall) <|> try funcCall)) - where - funcCall :: Parser UnresolvedValue - funcCall = do - (fname, args) <- genFunctionCall False - return $ UFunctionCall fname args - -expressionTable :: [[Operator Parser Expression]] -expressionTable = [ [ Postfix indexLookupChain ] -- http://stackoverflow.com/questions/10475337/parsec-expr-repeated-prefix-postfix-operator-not-supported - , [ Prefix ( operator "-" >> return Negate ) ] - , [ Prefix ( operator "!" >> return Not ) ] - , [ InfixL ( operator "." >> return FunctionApplication ) ] - , [ InfixL ( reserved "in" >> return Contains ) ] - , [ InfixL ( operator "/" >> return Division ) - , InfixL ( operator "*" >> return Multiplication ) - ] - , [ InfixL ( operator "+" >> return Addition ) - , InfixL ( operator "-" >> return Substraction ) - ] - , [ InfixL ( operator "<<" >> return LeftShift ) - , InfixL ( operator ">>" >> return RightShift ) - ] - , [ InfixL ( operator "==" >> return Equal ) - , InfixL ( operator "!=" >> return Different ) - ] - , [ InfixL ( operator "=~" >> return RegexMatch ) - , InfixL ( operator "!~" >> return NotRegexMatch ) - ] - , [ InfixL ( operator ">=" >> return MoreEqualThan ) - , InfixL ( operator "<=" >> return LessEqualThan ) - , InfixL ( operator ">" >> return MoreThan ) - , InfixL ( operator "<" >> return LessThan ) - ] - , [ InfixL ( reserved "and" >> return And ) - , InfixL ( reserved "or" >> return Or ) - ] - ] - -indexLookupChain :: Parser (Expression -> Expression) -indexLookupChain = List.foldr1 (flip (.)) <$> some checkLookup - where - checkLookup = flip Lookup <$> between (operator "[") (operator "]") expression - -stringExpression :: Parser Expression -stringExpression = fmap (Terminal . UInterpolable) interpolableString <|> (reserved "undef" *> return (Terminal UUndef)) <|> fmap (Terminal . UBoolean) puppetBool <|> variable <|> fmap Terminal literalValue - -varAssign :: Parser VarAssignDecl -varAssign = do - p <- getSourcePos - mt <- optional datatype - v <- variableReference - void $ symbolic '=' - e <- expression - when (Text.all Char.isDigit v) (fail "Can't assign fully numeric variables") - pe <- getSourcePos - return (VarAssignDecl mt v e (p :!: pe)) - -nodeDecl :: Parser [NodeDecl] -nodeDecl = do - p <- getSourcePos - reserved "node" - let toString (UString s) = s - toString (UNumber n) = scientific2text n - toString _ = panic "Can't happen at nodeDecl" - nodename = (reserved "default" >> return NodeDefault) <|> fmap (NodeName . toString) literalValue - ns <- (fmap NodeMatch termRegexp <|> nodename) `sepBy1` comma - inheritance <- option S.Nothing (fmap S.Just (reserved "inherits" *> nodename)) - st <- braces statementList - pe <- getSourcePos - return [NodeDecl n st inheritance (p :!: pe) | n <- ns] - -defineDecl :: Parser DefineDecl -defineDecl = do - p <- getSourcePos - reserved "define" - name <- typeName - -- TODO check native type - params <- option V.empty puppetClassParameters - st <- braces statementList - pe <- getSourcePos - return (DefineDecl name params st (p :!: pe)) - -puppetClassParameters :: Parser (Vector (Pair (Pair Text (S.Maybe UDataType)) (S.Maybe Expression))) -puppetClassParameters = V.fromList <$> parens (sepComma var) - where - toStrictMaybe (Just x) = S.Just x - toStrictMaybe Nothing = S.Nothing - var :: Parser (Pair (Pair Text (S.Maybe UDataType)) (S.Maybe Expression)) - var = do - tp <- toStrictMaybe <$> optional datatype - n <- variableReference - df <- toStrictMaybe <$> optional (symbolic '=' *> expression) - return (n :!: tp :!: df) - -puppetIfStyleCondition :: Parser (Pair Expression (Vector Statement)) -puppetIfStyleCondition = (:!:) <$> expression <*> braces statementList - -unlessCondition :: Parser ConditionalDecl -unlessCondition = do - p <- getSourcePos - reserved "unless" - (cond :!: stmts) <- puppetIfStyleCondition - pe <- getSourcePos - return (ConditionalDecl (V.singleton (Not cond :!: stmts)) (p :!: pe)) - -ifCondition :: Parser ConditionalDecl -ifCondition = do - p <- getSourcePos - reserved "if" - maincond <- puppetIfStyleCondition - others <- many (reserved "elsif" *> puppetIfStyleCondition) - elsecond <- option V.empty (reserved "else" *> braces statementList) - let ec = if V.null elsecond - then [] - else [Terminal (UBoolean True) :!: elsecond] - pe <- getSourcePos - return (ConditionalDecl (V.fromList (maincond : others ++ ec)) (p :!: pe)) - -caseCondition :: Parser ConditionalDecl -caseCondition = do - let puppetRegexpCase = Terminal . URegexp <$> termRegexp - defaultCase = Terminal (UBoolean True) <$ try (reserved "default") - matchesToExpression e (x, stmts) = f x :!: stmts - where f = case x of - (Terminal (UBoolean _)) -> identity - (Terminal (URegexp _)) -> RegexMatch e - _ -> Equal e - cases = do - matches <- (puppetRegexpCase <|> defaultCase <|> expression) `sepBy1` comma - void $ symbolic ':' - stmts <- braces statementList - return $ map (,stmts) matches - p <- getSourcePos - reserved "case" - expr1 <- expression - condlist <- concat <$> braces (some cases) - pe <- getSourcePos - return (ConditionalDecl (V.fromList (map (matchesToExpression expr1) condlist)) (p :!: pe) ) - -data OperatorChain a = OperatorChain a LinkType (OperatorChain a) - | EndOfChain a - -instance Foldable OperatorChain where - foldMap f (EndOfChain x) = f x - foldMap f (OperatorChain a _ nx) = f a <> foldMap f nx - -operatorChainStatement :: OperatorChain a -> a -operatorChainStatement (OperatorChain a _ _) = a -operatorChainStatement (EndOfChain x) = x - -zipChain :: OperatorChain a -> [ ( a, a, LinkType ) ] -zipChain (OperatorChain a d nx) = (a, operatorChainStatement nx, d) : zipChain nx -zipChain (EndOfChain _) = [] - -depOperator :: Parser LinkType -depOperator = (RBefore <$ operator "->") - <|> (RNotify <$ operator "~>") - -assignment :: Parser AttributeDecl -assignment = (AttributeDecl <$> key <*> arrowOp <*> expression) - <|> (AttributeWildcard <$> (symbolic '*' *> symbol "=>" *> expression)) - where - key = identl (satisfy Char.isAsciiLower) (satisfy acceptable) "Assignment key" - acceptable x = Char.isAsciiLower x || Char.isAsciiUpper x || Char.isDigit x || (x == '_') || (x == '-') - arrowOp = - (AssignArrow <$ symbol "=>") - <|> (AppendArrow <$ symbol "+>") - -searchExpression :: Parser SearchExpression -searchExpression = makeExprParser (lexeme searchterm) searchTable - where - searchTable :: [[Operator Parser SearchExpression]] - searchTable = [ [ InfixL ( reserved "and" >> return AndSearch ) - , InfixL ( reserved "or" >> return OrSearch ) - ] ] - searchterm = parens searchExpression <|> check - check = do - attrib <- parameterName - opr <- (EqualitySearch <$ operator "==") - <|> (NonEqualitySearch <$ operator "!=") - term <- stringExpression - return (opr attrib term) - -resCollDecl :: Position -> Text -> Parser ResCollDecl -resCollDecl p restype = do - openchev <- some (char '<') - when (length openchev > 2) (fail "Too many brackets") - void $ symbolic '|' - e <- option AlwaysTrue searchExpression - void (char '|') - void (count (length openchev) (char '>')) - sc - overrides <- option [] $ braces (sepComma assignment) - let collectortype = if length openchev == 1 - then Collector - else ExportedCollector - pe <- getSourcePos - return (ResCollDecl collectortype restype e (V.fromList overrides) (p :!: pe) ) - -classDecl :: Parser ClassDecl -classDecl = do - p <- getSourcePos - reserved "class" - ClassDecl <$> className - <*> option V.empty puppetClassParameters - <*> option S.Nothing (fmap S.Just (reserved "inherits" *> className)) - <*> braces statementList - <*> ( (p :!:) <$> getSourcePos ) - -mainFuncDecl :: Parser MainFuncDecl -mainFuncDecl = do - p <- getSourcePos - (fname, args) <- genFunctionCall True - pe <- getSourcePos - return (MainFuncDecl fname args (p :!: pe)) - -hoLambdaDecl :: Parser HigherOrderLambdaDecl -hoLambdaDecl = do - p <- getSourcePos - fc <- try lambdaCall - pe <- getSourcePos - return (HigherOrderLambdaDecl fc (p :!: pe)) - -dotLambdaDecl :: Parser HigherOrderLambdaDecl -dotLambdaDecl = do - p <- getSourcePos - ex <- expression - pe <- getSourcePos - hf <- case ex of - FunctionApplication e (Terminal (UHOLambdaCall hf)) -> do - unless (S.isNothing (hf ^. hoLambdaExpr)) (fail "Can't call a function with . and ()") - return (hf & hoLambdaExpr .~ S.Just e) - Terminal (UHOLambdaCall hf) -> do - when (S.isNothing (hf ^. hoLambdaExpr)) (fail "This function needs data to operate on") - return hf - _ -> fail "A method chained by dots." - unless (hf ^. hoLambdaFunc == LambEach) (fail "Expected 'each', the other types of method calls are not supported by language-puppet at the statement level.") - return (HigherOrderLambdaDecl hf (p :!: pe)) - - -resDefaultDecl :: Parser ResDefaultDecl -resDefaultDecl = do - p <- getSourcePos - rnd <- resourceNameRef - let assignmentList = V.fromList <$> sepComma1 assignment - asl <- braces assignmentList - pe <- getSourcePos - return (ResDefaultDecl rnd asl (p :!: pe)) - -resOverrideDecl :: Parser [ResOverrideDecl] -resOverrideDecl = do - p <- getSourcePos - restype <- resourceNameRef - names <- brackets (expression `sepBy1` comma) "Resource reference values" - assignments <- V.fromList <$> braces (sepComma assignment) - pe <- getSourcePos - return [ ResOverrideDecl restype n assignments (p :!: pe) | n <- names ] - --- | Heterogeneous chain (interleaving resource declarations with --- resource references) needs to be supported: --- --- class { 'docker::service': } -> --- Class['docker'] -chainableResources :: Parser [Statement] -chainableResources = do - let withresname = do - p <- getSourcePos - restype <- resourceNameRef - lookAhead anySingle >>= \x -> case x of - '[' -> do - resnames <- brackets (expression `sepBy1` comma) - pe <- getSourcePos - pure (ChainResRefr restype resnames (p :!: pe)) - _ -> ChainResColl <$> resCollDecl p restype - chain <- parseRelationships $ pure <$> try withresname <|> map ChainResDecl <$> resDeclGroup - let relations = do - (g1, g2, lt) <- zipChain chain - (rt1, rn1, _ :!: pe1) <- concatMap extractResRef g1 - (rt2, rn2, ps2 :!: _ ) <- concatMap extractResRef g2 - return (DepDecl (rt1 :!: rn1) (rt2 :!: rn2) lt (pe1 :!: ps2)) - return $ map DependencyDeclaration relations <> (chain ^.. folded . folded . to extractChainStatement . folded) - where - extractResRef :: ChainableRes -> [(Text, Expression, PPosition)] - extractResRef (ChainResColl _) = [] - extractResRef (ChainResDecl (ResDecl rt rn _ _ pp)) = [(rt,rn,pp)] - extractResRef (ChainResRefr rt rns pp) = [(rt,rn,pp) | rn <- rns] - - extractChainStatement :: ChainableRes -> [Statement] - extractChainStatement (ChainResColl r) = [ResourceCollectionDeclaration r] - extractChainStatement (ChainResDecl d) = [ResourceDeclaration d] - extractChainStatement ChainResRefr{} = [] - - parseRelationships :: Parser a -> Parser (OperatorChain a) - parseRelationships p = do - g <- p - o <- optional depOperator - case o of - Just o' -> OperatorChain g o' <$> parseRelationships p - Nothing -> pure (EndOfChain g) - - resDeclGroup :: Parser [ResDecl] - resDeclGroup = do - let resourceName = expression - resourceDeclaration = do - p <- getSourcePos - names <- brackets (sepComma1 resourceName) <|> fmap return resourceName - void $ symbolic ':' - vals <- fmap V.fromList (sepComma assignment) - pe <- getSourcePos - return [(n, vals, p :!: pe) | n <- names ] - groupDeclaration = (,) <$> many (char '@') <*> typeName <* symbolic '{' - (virts, rtype) <- try groupDeclaration -- for matching reasons, this gets a try until the opening brace - let sep = symbolic ';' <|> comma - x <- resourceDeclaration `sepEndBy1` sep - void $ symbolic '}' - virtuality <- case virts of - "" -> return Normal - "@" -> return Virtual - "@@" -> return Exported - _ -> fail "Invalid virtuality" - return [ ResDecl rtype rname conts virtuality pos | (rname, conts, pos) <- concat x ] - -statement :: Parser [Statement] -statement = - (pure . HigherOrderLambdaDeclaration <$> try dotLambdaDecl) - <|> (pure . VarAssignmentDeclaration <$> varAssign) - <|> (map NodeDeclaration <$> nodeDecl) - <|> (pure . DefineDeclaration <$> defineDecl) - <|> (pure . ConditionalDeclaration <$> unlessCondition) - <|> (pure . ConditionalDeclaration <$> ifCondition) - <|> (pure . ConditionalDeclaration <$> caseCondition) - <|> (pure . ResourceDefaultDeclaration <$> try resDefaultDecl) - <|> (map ResourceOverrideDeclaration <$> try resOverrideDecl) - <|> chainableResources - <|> (pure . ClassDeclaration <$> classDecl) - <|> (pure . HigherOrderLambdaDeclaration <$> hoLambdaDecl) - <|> (pure . MainFunctionDeclaration <$> mainFuncDecl) - "Statement" - -datatype :: Parser UDataType -datatype = dtString - <|> dtInteger - <|> dtFloat - <|> dtNumeric - <|> (UDTBoolean <$ reserved "Boolean") - <|> (UDTScalar <$ reserved "Scalar") - <|> (UDTData <$ reserved "Data") - <|> (UDTAny <$ reserved "Any") - <|> (UDTCollection <$ reserved "Collection") - <|> dtArray - <|> dtHash - <|> (UDTUndef <$ reserved "Undef") - <|> (reserved "Optional" *> (UDTOptional <$> brackets datatype)) - <|> (UNotUndef <$ reserved "NotUndef") - <|> (reserved "Variant" *> (UDTVariant . NE.fromList <$> brackets (datatype `sepBy1` symbolic ','))) - <|> (reserved "Regexp" *> (UDTRegexp <$> optional (brackets termRegexp))) - -- while all the other cases are straightforward, it seems that the - -- following syntax is a valid regexp for puppet: - -- '^dqsqsdqs$' - -- instead of: - -- /^dqsqsdqs$/ - -- - -- That is the reason there is a "quotedRegexp" case - <|> (reserved "Pattern" *> (UDTPattern . NE.fromList <$> brackets ( (termRegexp <|> quotedRegexp) `sepBy1` symbolic ','))) - <|> (reserved "Enum" *> (UDTEnum . NE.fromList <$> brackets (expression `sepBy1` symbolic ','))) - <|> dtExternal - "UDataType" - where - quotedRegexp = stringLiteral' >>= compileRegexp - integer = integerOrDouble >>= either (return . fromIntegral) (\d -> fail ("Integer value expected, instead of " ++ show d)) - float = either fromIntegral identity <$> integerOrDouble - dtArgs str def parseArgs = do - void $ reserved str - fromMaybe def <$> optional (brackets parseArgs) - dtbounded s constructor parser = dtArgs s (constructor Nothing Nothing) $ do - lst <- parser `sepBy1` symbolic ',' - case lst of - [minlen] -> return $ constructor (Just minlen) Nothing - [minlen,maxlen] -> return $ constructor (Just minlen) (Just maxlen) - _ -> fail ("Too many arguments to datatype " ++ Text.unpack s) - dtString = dtbounded "String" UDTString integer - dtInteger = dtbounded "Integer" UDTInteger integer - dtFloat = dtbounded "Float" UDTFloat float - dtNumeric = dtbounded "Numeric" (\ma mb -> UDTVariant (UDTFloat ma mb :| [UDTInteger (truncate <$> ma) (truncate <$> mb)])) float - dtArray = do - reserved "Array" - ml <- optional $ brackets $ do - tp <- datatype - rst <- optional (symbolic ',' *> integer `sepBy1` symbolic ',') - return (tp, rst) - case ml of - Nothing -> return (UDTArray UDTData 0 Nothing) - Just (t, Nothing) -> return (UDTArray t 0 Nothing) - Just (t, Just [mi]) -> return (UDTArray t mi Nothing) - Just (t, Just [mi, mx]) -> return (UDTArray t mi (Just mx)) - Just (_, Just _) -> fail "Too many arguments to datatype Array" - dtHash = do - reserved "Hash" - ml <- optional $ brackets $ do - tk <- datatype - symbolic ',' - tv <- datatype - rst <- optional (symbolic ',' *> integer `sepBy1` symbolic ',') - return (tk, tv, rst) - case ml of - Nothing -> return (UDTHash UDTScalar UDTData 0 Nothing) - Just (tk, tv, Nothing) -> return (UDTHash tk tv 0 Nothing) - Just (tk, tv, Just [mi]) -> return (UDTHash tk tv mi Nothing) - Just (tk, tv, Just [mi, mx]) -> return (UDTHash tk tv mi (Just mx)) - Just (_, _, Just _) -> fail "Too many arguments to datatype Hash" - dtExternal = - reserved "Stdlib::Absolutepath" $> UDTData - <|> reserved "Stdlib::Base32" $> UDTData - <|> reserved "Stdlib::Base64" $> UDTData - <|> reserved "Stdlib::Compat::Absolute_path" $> UDTData - <|> reserved "Stdlib::Compat::Array" $> UDTData - <|> reserved "Stdlib::Compat::Bool" $> UDTData - <|> reserved "Stdlib::Compat::Float" $> UDTData - <|> reserved "Stdlib::Compat::Hash" $> UDTData - <|> reserved "Stdlib::Compat::Integer" $> UDTData - <|> reserved "Stdlib::Compat::Ip_address" $> UDTData - <|> reserved "Stdlib::Compat::Ipv4" $> UDTData - <|> reserved "Stdlib::Compat::Ipv6" $> UDTData - <|> reserved "Stdlib::Compat::Numeric" $> UDTData - <|> reserved "Stdlib::Compat::String" $> UDTData - <|> reserved "Stdlib::Ensure::Service" $> UDTData - <|> reserved "Stdlib::Filemode" $> UDTData - <|> reserved "Stdlib::Filesource" $> UDTData - <|> reserved "Stdlib::Fqdn" $> UDTData - <|> reserved "Stdlib::Host" $> UDTData - <|> reserved "Stdlib::HTTPSUrl" $> UDTData - <|> reserved "Stdlib::HTTPUrl" $> UDTData - <|> reserved "Stdlib::IP::Address::Nosubnet" $> UDTData - <|> reserved "Stdlib::Ip_address" $> UDTData - <|> reserved "Stdlib::IP::Address" $> UDTData - <|> reserved "Stdlib::IP::Address::V4::CIDR" $> UDTData - <|> reserved "Stdlib::IP::Address::V4::Nosubnet" $> UDTData - <|> reserved "Stdlib::IP::Address::V4" $> UDTData - <|> reserved "Stdlib::IP::Address::V6::Alternative" $> UDTData - <|> reserved "Stdlib::IP::Address::V6::Compressed" $> UDTData - <|> reserved "Stdlib::IP::Address::V6::Full" $> UDTData - <|> reserved "Stdlib::IP::Address::V6::Nosubnet::Alternative" $> UDTData - <|> reserved "Stdlib::IP::Address::V6::Nosubnet::Compressed" $> UDTData - <|> reserved "Stdlib::IP::Address::V6::Nosubnet::Full" $> UDTData - <|> reserved "Stdlib::IP::Address::V6::Nosubnet" $> UDTData - <|> reserved "Stdlib::IP::Address::V6" $> UDTData - <|> reserved "Stdlib::Ipv4" $> UDTData - <|> reserved "Stdlib::Ipv6" $> UDTData - <|> reserved "Stdlib::MAC" $> UDTData - <|> reserved "Stdlib::Port::Privileged" $> UDTData - <|> reserved "Stdlib::Port" $> UDTData - <|> reserved "Stdlib::Port::Unprivileged" $> UDTData - <|> reserved "Stdlib::Unixpath" $> UDTData - <|> reserved "Stdlib::Windowspath" $> UDTData - <|> reserved "Nginx::ErrorLogSeverity" $> UDTData - <|> reserved "Jenkins::Tunnel" $> UDTData - <|> reserved "Systemd::Unit" $> UDTData - <|> reserved "Systemd::ServiceLimits" $> UDTData - <|> reserved "Systemd::Dropin" $> UDTData - -statementList :: Parser (Vector Statement) -statementList = (V.fromList . concat) <$> many statement - -lambdaCall :: Parser HOLambdaCall -lambdaCall = do - let tostrict (Just x) = S.Just x - tostrict Nothing = S.Nothing - HOLambdaCall <$> lambFunc - <*> fmap (tostrict . join) (optional (parens (optional expression))) - <*> lambParams - <*> (symbolic '{' *> fmap (V.fromList . concat) (many (try statement))) - <*> fmap tostrict (optional expression) <* symbolic '}' - where - lambFunc :: Parser LambdaFunc - lambFunc = (LambEach <$ reserved "each") - <|> (LambMap <$ reserved "map") - <|> (LambReduce <$ reserved "reduce") - <|> (LambFilter <$ reserved "filter") - <|> (LambSlice <$ reserved "slice") - <|> (LambLookup <$ reserved "lookup") - lambParams :: Parser LambdaParameters - lambParams = between (symbolic '|') (symbolic '|') hp - where - acceptablePart = Text.pack <$> identifier - lambdaParameter :: Parser LambdaParameter - lambdaParameter = LParam <$> optional datatype <*> (char '$' *> acceptablePart) - hp = do - vars <- lambdaParameter `sepBy1` comma - case vars of - [a] -> return (BPSingle a) - [a,b] -> return (BPPair a b) - _ -> fail "Invalid number of variables between the pipes" diff --git a/src/Puppet/Parser/Internal.hs b/src/Puppet/Parser/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Puppet/Parser/Internal.hs @@ -0,0 +1,774 @@ +{-# LANGUAGE TupleSections #-} +module Puppet.Parser.Internal +where + +import XPrelude.Extra hiding (many, option, some, try) + +import Control.Monad.Combinators.Expr +import qualified Data.Char as Char +import qualified Data.List as List +import qualified Data.List.NonEmpty as NE +import qualified Data.Maybe.Strict as S +import qualified Data.Scientific as Scientific +import qualified Data.Text as Text +import qualified Data.Vector as V +import Text.Megaparsec +import Text.Megaparsec.Char +import qualified Text.Megaparsec.Char.Lexer as Lexer +import qualified Text.Regex.PCRE.ByteString.Utils as Regex + +import Puppet.Language +import Puppet.Parser.Types + +-- | Space consumer +sc :: Parser () +sc = Lexer.space space1 (Lexer.skipLineComment "#") (Lexer.skipBlockComment "/*" "*/") + +-- | Lexeme consumes spaces after the input parser +lexeme :: Parser a -> Parser a +lexeme = Lexer.lexeme sc + +-- | Consumes a text then consumes spaces +symbol :: Text -> Parser () +symbol = void . Lexer.symbol sc + +-- | Consumes a character then consumes spaces +symbolic :: Char -> Parser () +symbolic = lexeme . void . single + +braces :: Parser a -> Parser a +braces = between (symbolic '{') (symbolic '}') + +parens :: Parser a -> Parser a +parens = between (symbolic '(') (symbolic ')') + +brackets :: Parser a -> Parser a +brackets = between (symbolic '[') (symbolic ']') + +comma :: Parser () +comma = symbolic ',' + +sepComma :: Parser a -> Parser [a] +sepComma p = p `sepEndBy` comma + +sepComma1 :: Parser a -> Parser [a] +sepComma1 p = p `sepEndBy1` comma + +-- | Parses an 'Expression'. +expression :: Parser Expression +expression = do + expr <- makeExprParser (lexeme terminal) expressionTable + ms <- optional $ do + symbolic '?' + let case_expr = do + c <- SelectorDefault <$ symbol "default" -- default case + <|> SelectorType <$> try datatype + <|> fmap SelectorValue + ( UVariableReference <$> variableReference + <|> UBoolean <$> puppetBool + <|> UUndef <$ symbol "undef" + <|> literalValue + <|> UInterpolable <$> interpolableString + <|> URegexp <$> termRegexp + ) + symbol "=>" + e <- expression + pure (c :!: e) + cases <- braces (sepComma1 case_expr) + pure (ConditionalValue expr (V.fromList cases)) + case ms of + Nothing -> pure expr + Just cv -> pure cv + +stringLiteral' :: Parser Text +stringLiteral' = between (char '\'') (symbolic '\'') interior + where + interior = Text.pack . concat <$> many (some (noneOf ['\'', '\\']) <|> (char '\\' *> fmap escape anySingle)) + escape '\'' = "'" + escape x = ['\\',x] + +identifier :: Parser (Tokens Text) +identifier = takeWhile1P Nothing isIdentifierChar + +-- | Only Ascii, hyphens (-) are not allowed. +isIdentifierChar :: Char -> Bool +isIdentifierChar x = Char.isAsciiLower x || Char.isAsciiUpper x || Char.isDigit x || (x == '_') + +-- | Like 'isIndentifierChar' but hyphens (-) are allowed. +isBarewordChar :: Char -> Bool +isBarewordChar x = isIdentifierChar x || (x == '-') + +reserved :: Text -> Parser () +reserved s = + try $ do + void (chunk s) + notFollowedBy (satisfy isIdentifierChar) + sc + +qualif :: Parser Text -> Parser Text +qualif p = do + header <- option "" (chunk "::") + ( header <> ) . Text.intercalate "::" <$> p `sepBy1` chunk "::" + +qualif1 :: Parser Text -> Parser Text +qualif1 p = try $ do + r <- qualif p + unless ("::" `Text.isInfixOf` r) (fail "This parser is not qualified") + pure r + +-- | Consumes a var $foo and then spaces +variableReference :: Parser Text +variableReference = char '$' *> lexeme variableName + +variableName :: Parser Text +variableName = qualif identifier + +className :: Parser Text +className = lexeme $ qualif moduleName + +-- yay with reserved words +typeName :: Parser Text +typeName = className + +moduleName :: Parser Text +moduleName = lexeme $ genericModuleName False + +resourceNameRef :: Parser Text +resourceNameRef = lexeme $ qualif (genericModuleName True) + +genericModuleName :: Bool -> Parser Text +genericModuleName isReference = do + let acceptable x = Char.isAsciiLower x || Char.isDigit x || (x == '_') + firstletter = if isReference + then fmap Char.toLower (satisfy Char.isAsciiUpper) + else satisfy Char.isAsciiLower + (Text.cons) <$> firstletter <*> takeWhileP Nothing acceptable + +parameterName :: Parser Text +parameterName = moduleName + +-- | Variable expression +varExpression :: Parser Expression +varExpression = Terminal . UVariableReference <$> variableReference + +-- | String interpolation +interpolableString :: Parser (Vector Expression) +interpolableString = V.fromList <$> between (char '"') (symbolic '"') + ( many (interpolableVariableReference <|> doubleQuotedStringContent <|> fmap (Terminal . UString . Text.singleton) (char '$')) ) + where + doubleQuotedStringContent = Terminal . UString . Text.pack . concat <$> + some ((char '\\' *> fmap escaper anySingle) <|> some (noneOf [ '"', '\\', '$' ])) + escaper :: Char -> String + escaper 'n' = "\n" + escaper 't' = "\t" + escaper 'r' = "\r" + escaper '"' = "\"" + escaper '\\' = "\\" + escaper '$' = "$" + escaper x = ['\\',x] + -- this is specialized because we can't be "tokenized" here + varname = Text.concat <$> some (chunk "::" <|> identifier) + varexpr = Terminal . UVariableReference <$> varname + indexchain = makeExprParser varexpr [[Postfix indexLookupChain]] -- e.g: os['release']['major'] + interpolableVariableReference = do + void (char '$') + let fenced = try (indexchain <* char '}') + <|> try (varexpr <* char '}') + <|> (expression <* char '}') + (symbolic '{' *> fenced) <|> try varexpr <|> pure (Terminal (UString (Text.singleton '$'))) + +integerOrDouble :: Parser (Either Integer Double) +integerOrDouble = Left <$> hex <|> (either Right Left . Scientific.floatingOrInteger <$> Lexer.scientific) + where + hex = chunk "0x" *> Lexer.hexadecimal + +puppetArray :: Parser UnresolvedValue +puppetArray = fmap (UArray . V.fromList) (brackets (sepComma expression)) "Array" + +puppetHash :: Parser UnresolvedValue +puppetHash = fmap (UHash . V.fromList) (braces (sepComma hashPart)) "Hash" + where + hashPart = (:!:) <$> (expression <* symbol "=>") <*> expression + +puppetBool :: Parser Bool +puppetBool = + (reserved "true" >> pure True) + <|> (reserved "false" >> pure False) + "Boolean" + +resourceReferenceRaw :: Parser (Text, [Expression]) +resourceReferenceRaw = do + let restype_parser = qualif (genericModuleName True) + resnames_parser = brackets (expression `sepBy1` comma) + (,) <$> restype_parser <*> resnames_parser "Resource reference" + +resourceReference :: Parser UnresolvedValue +resourceReference = do + (restype, resnames) <- resourceReferenceRaw + pure $ UResourceReference restype $ case resnames of + [x] -> x + _ -> Terminal $ UArray (V.fromList resnames) + +-- | Functions that have named that are not valid ... +specialFunctions :: Parser Text +specialFunctions = + chunk "Integer" + <|> chunk "Numeric" + +-- The first argument defines if non-parenthesized arguments are acceptable +genFunctionCall :: Bool -> Parser (Text, Vector Expression) +genFunctionCall nonparens = do + fname <- (specialFunctions <|> moduleName) "Function name" + -- this is a hack. Contrary to what the documentation says, + -- a "bareword" can perfectly be a qualified name : + -- include foo::bar + let argsc sep e = (fmap (Terminal . UString) (lexeme (qualif1 moduleName)) <|> e "Function argument A") `sep` comma + terminalF = terminalG FunctionWithoutParens + expressionF = makeExprParser (lexeme terminalF) expressionTable "function expression" + withparens = parens (argsc sepEndBy expression) + withoutparens = argsc sepEndBy1 expressionF + args <- withparens <|> if nonparens + then withoutparens "Function arguments B" + else fail "Function arguments C" + pure (fname, V.fromList args) + + +literalValue :: Parser UnresolvedValue +literalValue = lexeme (fmap UString stringLiteral' <|> fmap UString bareword <|> fmap UNumber numericalvalue "Literal Value") + where + bareword = Text.cons <$> satisfy Char.isAsciiLower <*> takeWhileP Nothing isBarewordChar "Bare word" + signed :: Num n => Parser (n -> n) + signed = (negate <$ char '-') <|> pure (\x -> x) + numericalvalue = ((,) <$> signed <*> integerOrDouble) >>= \case + (s, Left x) -> pure (s (fromIntegral x)) + (s, Right y) -> pure (s (Scientific.fromFloatDigits y)) + +data TerminalMode + = FunctionWithoutParens + | StandardMode + +-- this is a hack for functions :( +terminalG :: TerminalMode -> Parser Expression +terminalG mode = + parens expression + <|> fmap (Terminal . UInterpolable) interpolableString + <|> (Terminal UUndef <$ reserved "undef") + <|> fmap (Terminal . URegexp) termRegexp + <|> varExpression + <|> fmap Terminal puppetArray + <|> fmap Terminal puppetHash + <|> fmap (Terminal . UBoolean) puppetBool + <|> case mode of + FunctionWithoutParens -> remaining + StandardMode -> lambda <|> remaining + where + lambda = fmap Terminal (fmap UHOLambdaCall (try lambdaCall) <|> try funcCall) + remaining = fmap (Terminal . UDataType) datatype + <|> fmap Terminal resourceReference + <|> fmap Terminal literalValue + funcCall :: Parser UnresolvedValue + funcCall = uncurry UFunctionCall <$> genFunctionCall False + +regexp :: Parser Text +regexp = do + void (single '/') + Text.pack . concat <$> many ( do { void (char '\\') ; x <- anySingle; return ['\\', x] } <|> some (noneOf [ '/', '\\' ]) ) + <* symbolic '/' + +compileRegexp :: Text -> Parser CompRegex +compileRegexp p = case Regex.compile' Regex.compBlank Regex.execBlank (encodeUtf8 p) of + Right r -> pure $ CompRegex p r + Left ms -> fail ("Can't parse regexp /" <> Text.unpack p <> "/ : " ++ show ms) + +termRegexp :: Parser CompRegex +termRegexp = regexp >>= compileRegexp + +terminal :: Parser Expression +terminal = terminalG StandardMode + +expressionTable :: [[Operator Parser Expression]] +expressionTable = [ [ Postfix indexLookupChain ] -- http://stackoverflow.com/questions/10475337/parsec-expr-repeated-prefix-postfix-operator-not-supported + , [ Prefix ( symbolic '-' *> pure Negate ) ] + , [ Prefix ( symbolic '!' *> pure Not ) ] + , [ InfixL ( symbolic '.' *> pure FunctionApplication ) ] + , [ InfixL ( reserved "in" *> pure Contains ) ] + , [ InfixL ( symbolic '/' *> pure Division ) + , InfixL ( symbolic '*' *> pure Multiplication ) + ] + , [ InfixL ( symbolic '+' *> pure Addition ) + , InfixL ( symbolic '-' *> pure Substraction ) + ] + , [ InfixL ( symbol "<<" *> pure LeftShift ) + , InfixL ( symbol ">>" *> pure RightShift ) + ] + , [ InfixL ( symbol "==" *> pure Equal ) + , InfixL ( symbol "!=" *> pure Different ) + ] + , [ InfixL ( symbol "=~" *> pure RegexMatch ) + , InfixL ( symbol "!~" *> pure NotRegexMatch ) + ] + , [ InfixL ( symbol ">=" *> pure MoreEqualThan ) + , InfixL ( symbol "<=" *> pure LessEqualThan ) + , InfixL ( symbol ">" *> pure MoreThan ) + , InfixL ( symbol "<" *> pure LessThan ) + ] + , [ InfixL ( reserved "and" *> pure And ) + , InfixL ( reserved "or" *> pure Or ) + ] + ] + +-- | Postfix of a chain of lookup indexes such as "['release']['major']" +indexLookupChain :: Parser (Expression -> Expression) +indexLookupChain = List.foldr1 (flip (.)) <$> some checkLookup + where + checkLookup = flip Lookup <$> brackets expression + +stringExpression :: Parser Expression +stringExpression = + (Terminal . UInterpolable) <$> interpolableString + <|> (reserved "undef" $> Terminal UUndef) + <|> (Terminal . UBoolean) <$> puppetBool + <|> varExpression + <|> Terminal <$> literalValue + +varAssign :: Parser VarAssignDecl +varAssign = do + p <- getSourcePos + mt <- optional datatype + v <- variableReference + void $ symbolic '=' + e <- expression + when (Text.all Char.isDigit v) (fail "Can't assign fully numeric variables") + pe <- getSourcePos + pure (VarAssignDecl mt v e (p :!: pe)) + +nodeDecl :: Parser [NodeDecl] +nodeDecl = do + p <- getSourcePos + reserved "node" + let toString (UString s) = s + toString (UNumber n) = scientific2text n + toString _ = panic "Can't happen at nodeDecl" + nodename = (reserved "default" >> pure NodeDefault) <|> fmap (NodeName . toString) literalValue + ns <- (fmap NodeMatch termRegexp <|> nodename) `sepBy1` comma + inheritance <- option S.Nothing (fmap S.Just (reserved "inherits" *> nodename)) + st <- braces statementList + pe <- getSourcePos + pure [NodeDecl n st inheritance (p :!: pe) | n <- ns] + +defineDecl :: Parser DefineDecl +defineDecl = do + p <- getSourcePos + reserved "define" + name <- typeName + -- TODO check native type + params <- option V.empty puppetClassParameters + st <- braces statementList + pe <- getSourcePos + pure (DefineDecl name params st (p :!: pe)) + +puppetClassParameters :: Parser Parameters +puppetClassParameters = V.fromList <$> parens (sepComma var) + where + toStrictMaybe (Just x) = S.Just x + toStrictMaybe Nothing = S.Nothing + var :: Parser (Pair (Pair Text (S.Maybe UDataType)) (S.Maybe Expression)) + var = do + tp <- toStrictMaybe <$> optional datatype + n <- variableReference + df <- toStrictMaybe <$> optional (symbolic '=' *> expression) + pure (n :!: tp :!: df) + +puppetIfStyleCondition :: Parser (Pair Expression (Vector Statement)) +puppetIfStyleCondition = (:!:) <$> expression <*> braces statementList + +unlessCondition :: Parser ConditionalDecl +unlessCondition = do + p <- getSourcePos + reserved "unless" + (cond :!: stmts) <- puppetIfStyleCondition + pe <- getSourcePos + pure (ConditionalDecl (V.singleton (Not cond :!: stmts)) (p :!: pe)) + +ifCondition :: Parser ConditionalDecl +ifCondition = do + p <- getSourcePos + reserved "if" + maincond <- puppetIfStyleCondition + others <- many (reserved "elsif" *> puppetIfStyleCondition) + elsecond <- option V.empty (reserved "else" *> braces statementList) + let ec = if V.null elsecond + then [] + else [Terminal (UBoolean True) :!: elsecond] + pe <- getSourcePos + pure (ConditionalDecl (V.fromList (maincond : others ++ ec)) (p :!: pe)) + +caseCondition :: Parser ConditionalDecl +caseCondition = do + let puppetRegexpCase = Terminal . URegexp <$> termRegexp + defaultCase = Terminal (UBoolean True) <$ reserved "default" + matchesToExpression e (x, stmts) = f x :!: stmts + where f = case x of + (Terminal (UBoolean _)) -> identity + (Terminal (URegexp _)) -> RegexMatch e + _ -> Equal e + cases = do + matches <- (puppetRegexpCase <|> defaultCase <|> expression) `sepBy1` comma + void $ symbolic ':' + stmts <- braces statementList + pure $ map (,stmts) matches + p <- getSourcePos + reserved "case" + expr1 <- expression + condlist <- concat <$> braces (some cases) + pe <- getSourcePos + pure (ConditionalDecl (V.fromList (map (matchesToExpression expr1) condlist)) (p :!: pe) ) + +data OperatorChain a + = OperatorChain a LinkType (OperatorChain a) + | EndOfChain a + +instance Foldable OperatorChain where + foldMap f (EndOfChain x) = f x + foldMap f (OperatorChain a _ nx) = f a <> foldMap f nx + +operatorChainStatement :: OperatorChain a -> a +operatorChainStatement (OperatorChain a _ _) = a +operatorChainStatement (EndOfChain x) = x + +zipChain :: OperatorChain a -> [ ( a, a, LinkType ) ] +zipChain (OperatorChain a d nx) = (a, operatorChainStatement nx, d) : zipChain nx +zipChain (EndOfChain _) = [] + +depOperator :: Parser LinkType +depOperator = + (RBefore <$ symbol "->") + <|> (RNotify <$ symbol "~>") + +assignment :: Parser AttributeDecl +assignment = + (AttributeDecl <$> lexeme key <*> arrowOp <*> expression) + <|> (AttributeWildcard <$> (symbolic '*' *> symbol "=>" *> expression)) + where + key = (Text.cons) <$> (satisfy Char.isAsciiLower) <*> takeWhileP Nothing isBarewordChar "Assignment key" + arrowOp = + (AssignArrow <$ symbol "=>") + <|> (AppendArrow <$ symbol "+>") + +-- | Resource Collector +resCollDecl :: Position -> Text -> Parser ResCollDecl +resCollDecl p restype = do + openchev <- some (char '<') + when (length openchev > 2) (fail "Too many brackets") + void $ symbolic '|' + e <- option AlwaysTrue searchExpression + void (char '|') + void (count (length openchev) (char '>')) + sc + overrides <- option [] $ braces (sepComma assignment) + let collectortype = if length openchev == 1 + then Collector + else ExportedCollector + pe <- getSourcePos + pure (ResCollDecl collectortype restype e (V.fromList overrides) (p :!: pe) ) + where + searchExpression :: Parser SearchExpression + searchExpression = + let searchTable :: [[Operator Parser SearchExpression]] + searchTable = [ [ InfixL ( reserved "and" *> pure AndSearch ) + , InfixL ( reserved "or" *> pure OrSearch ) + ] ] + searchterm = parens searchExpression <|> check + check = do + attrib <- parameterName + opr <- (EqualitySearch <$ symbol "==") + <|> (NonEqualitySearch <$ symbol "!=") + term <- stringExpression + pure (opr attrib term) + in makeExprParser (lexeme searchterm) searchTable + +classDecl :: Parser ClassDecl +classDecl = do + p <- getSourcePos + reserved "class" + ClassDecl <$> className + <*> option V.empty puppetClassParameters + <*> option S.Nothing (fmap S.Just (reserved "inherits" *> className)) + <*> braces statementList + <*> ( (p :!:) <$> getSourcePos ) + +mainFuncDecl :: Parser MainFuncDecl +mainFuncDecl = do + p <- getSourcePos + (fname, args) <- genFunctionCall True + pe <- getSourcePos + pure (MainFuncDecl fname args (p :!: pe)) + +hoLambdaDecl :: Parser HigherOrderLambdaDecl +hoLambdaDecl = do + p <- getSourcePos + fc <- lambdaCall + pe <- getSourcePos + pure (HigherOrderLambdaDecl fc (p :!: pe)) + +dotLambdaDecl :: Parser HigherOrderLambdaDecl +dotLambdaDecl = do + p <- getSourcePos + ex <- expression + pe <- getSourcePos + hf <- case ex of + FunctionApplication e (Terminal (UHOLambdaCall hf)) -> do + unless (null (hf ^. hoLambdaExpr)) (fail "Can't call a function with . and ()") + pure (hf & hoLambdaExpr .~ V.singleton e) + Terminal (UHOLambdaCall hf) -> do + when (null (hf ^. hoLambdaExpr)) (fail "This function needs data to operate on") + pure hf + _ -> fail "A method chained by dots." + pure (HigherOrderLambdaDecl hf (p :!: pe)) + + +resDefaultDecl :: Parser ResDefaultDecl +resDefaultDecl = do + p <- getSourcePos + rnd <- resourceNameRef + let assignmentList = V.fromList <$> sepComma1 assignment + asl <- braces assignmentList + pe <- getSourcePos + pure (ResDefaultDecl rnd asl (p :!: pe)) + +resOverrideDecl :: Parser [ResOverrideDecl] +resOverrideDecl = do + p <- getSourcePos + restype <- resourceNameRef + names <- brackets (expression `sepBy1` comma) "Resource reference values" + assignments <- V.fromList <$> braces (sepComma assignment) + pe <- getSourcePos + pure [ ResOverrideDecl restype n assignments (p :!: pe) | n <- names ] + +-- | Heterogeneous chain (interleaving resource declarations with +-- resource references) needs to be supported: +-- +-- class { 'docker::service': } -> +-- Class['docker'] +chainableResources :: Parser [Statement] +chainableResources = do + let withresname = do + p <- getSourcePos + restype <- resourceNameRef + lookAhead anySingle >>= \case + '[' -> do + resnames <- brackets (expression `sepBy1` comma) + pe <- getSourcePos + pure (ChainResRefr restype resnames (p :!: pe)) + _ -> ChainResColl <$> resCollDecl p restype + chain <- parseRelationships $ pure <$> try withresname <|> map ChainResDecl <$> resDeclGroup + let relations = do + (g1, g2, lt) <- zipChain chain + (rt1, rn1, _ :!: pe1) <- concatMap extractResRef g1 + (rt2, rn2, ps2 :!: _ ) <- concatMap extractResRef g2 + pure (DepDecl (rt1 :!: rn1) (rt2 :!: rn2) lt (pe1 :!: ps2)) + pure $ map DependencyDeclaration relations <> (chain ^.. folded . folded . to extractChainStatement . folded) + where + extractResRef :: ChainableRes -> [(Text, Expression, PPosition)] + extractResRef (ChainResColl _) = [] + extractResRef (ChainResDecl (ResDecl rt rn _ _ pp)) = [(rt,rn,pp)] + extractResRef (ChainResRefr rt rns pp) = [(rt,rn,pp) | rn <- rns] + + extractChainStatement :: ChainableRes -> [Statement] + extractChainStatement (ChainResColl r) = [ResourceCollectionDeclaration r] + extractChainStatement (ChainResDecl d) = [ResourceDeclaration d] + extractChainStatement ChainResRefr{} = [] + + parseRelationships :: Parser a -> Parser (OperatorChain a) + parseRelationships p = do + g <- p + o <- optional depOperator + case o of + Just o' -> OperatorChain g o' <$> parseRelationships p + Nothing -> pure (EndOfChain g) + + resDeclGroup :: Parser [ResDecl] + resDeclGroup = do + let resourceName = expression + resourceDeclaration = do + p <- getSourcePos + names <- brackets (sepComma1 resourceName) <|> fmap pure resourceName + void $ symbolic ':' + vals <- fmap V.fromList (sepComma assignment) + pe <- getSourcePos + pure [(n, vals, p :!: pe) | n <- names ] + groupDeclaration = (,) <$> many (char '@') <*> typeName <* symbolic '{' + (virts, rtype) <- try groupDeclaration -- for matching reasons, this gets a try until the opening brace + let sep = symbolic ';' <|> comma + x <- resourceDeclaration `sepEndBy1` sep + void $ symbolic '}' + virtuality <- case virts of + "" -> pure Normal + "@" -> pure Virtual + "@@" -> pure Exported + _ -> fail "Invalid virtuality" + return [ ResDecl rtype rname conts virtuality pos | (rname, conts, pos) <- concat x ] + +statement :: Parser [Statement] +statement = + (pure . HigherOrderLambdaDeclaration <$> try dotLambdaDecl) + <|> (pure . VarAssignmentDeclaration <$> varAssign) + <|> (map NodeDeclaration <$> nodeDecl) + <|> (pure . DefineDeclaration <$> defineDecl) + <|> (pure . ConditionalDeclaration <$> unlessCondition) + <|> (pure . ConditionalDeclaration <$> ifCondition) + <|> (pure . ConditionalDeclaration <$> caseCondition) + <|> (pure . ResourceDefaultDeclaration <$> try resDefaultDecl) + <|> (map ResourceOverrideDeclaration <$> try resOverrideDecl) + <|> chainableResources + <|> (pure . ClassDeclaration <$> classDecl) + <|> (pure . HigherOrderLambdaDeclaration <$> try hoLambdaDecl) + <|> (pure . MainFunctionDeclaration <$> mainFuncDecl) + "Statement" + +datatype :: Parser UDataType +datatype = + dtString + <|> dtInteger + <|> dtFloat + <|> dtNumeric + <|> (UDTBoolean <$ reserved "Boolean") + <|> (UDTScalar <$ reserved "Scalar") + <|> (UDTData <$ reserved "Data") + <|> (UDTAny <$ reserved "Any") + <|> (UDTCollection <$ reserved "Collection") + <|> dtArray + <|> dtHash + <|> (UDTUndef <$ reserved "Undef") + <|> (reserved "Optional" *> (UDTOptional <$> brackets datatype)) + <|> (UNotUndef <$ reserved "NotUndef") + <|> (reserved "Variant" *> (UDTVariant . NE.fromList <$> brackets (datatype `sepBy1` symbolic ','))) + <|> (reserved "Regexp" *> (UDTRegexp <$> optional (brackets termRegexp))) + -- while all the other cases are straightforward, it seems that the + -- following syntax is a valid regexp for puppet: + -- '^dqsqsdqs$' + -- instead of: + -- /^dqsqsdqs$/ + -- + -- That is the reason there is a "quotedRegexp" case + <|> (reserved "Pattern" *> (UDTPattern . NE.fromList <$> brackets ( (termRegexp <|> quotedRegexp) `sepBy1` symbolic ','))) + <|> (reserved "Enum" *> (UDTEnum . NE.fromList <$> brackets (expression `sepBy1` symbolic ','))) + <|> dtExternal + "UDataType" + where + quotedRegexp = stringLiteral' >>= compileRegexp + integer = integerOrDouble >>= either (return . fromIntegral) (\d -> fail ("Integer value expected, instead of " ++ show d)) + float = either fromIntegral identity <$> integerOrDouble + dtArgs str def parseArgs = do + void $ reserved str + fromMaybe def <$> optional (brackets parseArgs) + dtbounded s constructor parser = dtArgs s (constructor Nothing Nothing) $ do + lst <- parser `sepBy1` symbolic ',' + case lst of + [minlen] -> return $ constructor (Just minlen) Nothing + [minlen,maxlen] -> return $ constructor (Just minlen) (Just maxlen) + _ -> fail ("Too many arguments to datatype " ++ Text.unpack s) + dtString = dtbounded "String" UDTString integer + dtInteger = dtbounded "Integer" UDTInteger integer + dtFloat = dtbounded "Float" UDTFloat float + dtNumeric = dtbounded "Numeric" (\ma mb -> UDTVariant (UDTFloat ma mb :| [UDTInteger (truncate <$> ma) (truncate <$> mb)])) float + dtArray = do + reserved "Array" + ml <- optional $ brackets $ do + tp <- datatype + rst <- optional (symbolic ',' *> integer `sepBy1` symbolic ',') + return (tp, rst) + case ml of + Nothing -> return (UDTArray UDTData 0 Nothing) + Just (t, Nothing) -> return (UDTArray t 0 Nothing) + Just (t, Just [mi]) -> return (UDTArray t mi Nothing) + Just (t, Just [mi, mx]) -> return (UDTArray t mi (Just mx)) + Just (_, Just _) -> fail "Too many arguments to datatype Array" + dtHash = do + reserved "Hash" + ml <- optional $ brackets $ do + tk <- datatype + symbolic ',' + tv <- datatype + rst <- optional (symbolic ',' *> integer `sepBy1` symbolic ',') + return (tk, tv, rst) + case ml of + Nothing -> return (UDTHash UDTScalar UDTData 0 Nothing) + Just (tk, tv, Nothing) -> return (UDTHash tk tv 0 Nothing) + Just (tk, tv, Just [mi]) -> return (UDTHash tk tv mi Nothing) + Just (tk, tv, Just [mi, mx]) -> return (UDTHash tk tv mi (Just mx)) + Just (_, _, Just _) -> fail "Too many arguments to datatype Hash" + dtExternal = + choice [ reserved "Stdlib::Absolutepath" $> UDTData + , reserved "Stdlib::Base32" $> UDTData + , reserved "Stdlib::Base64" $> UDTData + , reserved "Stdlib::Compat::Absolute_path" $> UDTData + , reserved "Stdlib::Compat::Array" $> UDTData + , reserved "Stdlib::Compat::Bool" $> UDTData + , reserved "Stdlib::Compat::Float" $> UDTData + , reserved "Stdlib::Compat::Hash" $> UDTData + , reserved "Stdlib::Compat::Integer" $> UDTData + , reserved "Stdlib::Compat::Ip_address" $> UDTData + , reserved "Stdlib::Compat::Ipv4" $> UDTData + , reserved "Stdlib::Compat::Ipv6" $> UDTData + , reserved "Stdlib::Compat::Numeric" $> UDTData + , reserved "Stdlib::Compat::String" $> UDTData + , reserved "Stdlib::Ensure::Service" $> UDTData + , reserved "Stdlib::Filemode" $> UDTData + , reserved "Stdlib::Filesource" $> UDTData + , reserved "Stdlib::Fqdn" $> UDTData + , reserved "Stdlib::Host" $> UDTData + , reserved "Stdlib::HTTPSUrl" $> UDTData + , reserved "Stdlib::HTTPUrl" $> UDTData + , reserved "Stdlib::IP::Address::Nosubnet" $> UDTData + , reserved "Stdlib::Ip_address" $> UDTData + , reserved "Stdlib::IP::Address" $> UDTData + , reserved "Stdlib::IP::Address::V4::CIDR" $> UDTData + , reserved "Stdlib::IP::Address::V4::Nosubnet" $> UDTData + , reserved "Stdlib::IP::Address::V4" $> UDTData + , reserved "Stdlib::IP::Address::V6::Alternative" $> UDTData + , reserved "Stdlib::IP::Address::V6::Compressed" $> UDTData + , reserved "Stdlib::IP::Address::V6::Full" $> UDTData + , reserved "Stdlib::IP::Address::V6::Nosubnet::Alternative" $> UDTData + , reserved "Stdlib::IP::Address::V6::Nosubnet::Compressed" $> UDTData + , reserved "Stdlib::IP::Address::V6::Nosubnet::Full" $> UDTData + , reserved "Stdlib::IP::Address::V6::Nosubnet" $> UDTData + , reserved "Stdlib::IP::Address::V6" $> UDTData + , reserved "Stdlib::Ipv4" $> UDTData + , reserved "Stdlib::Ipv6" $> UDTData + , reserved "Stdlib::MAC" $> UDTData + , reserved "Stdlib::Port::Privileged" $> UDTData + , reserved "Stdlib::Port" $> UDTData + , reserved "Stdlib::Port::Unprivileged" $> UDTData + , reserved "Stdlib::Unixpath" $> UDTData + , reserved "Stdlib::Windowspath" $> UDTData + , reserved "Nginx::ErrorLogSeverity" $> UDTData + , reserved "Jenkins::Tunnel" $> UDTData + , reserved "Systemd::Unit" $> UDTData + , reserved "Systemd::ServiceLimits" $> UDTData + , reserved "Systemd::Dropin" $> UDTData + ] + +statementList :: Parser (Vector Statement) +statementList = V.fromList . concat <$> many statement + +lambdaCall :: Parser HOLambdaCall +lambdaCall = do + let tostrict (Just x) = S.Just x + tostrict Nothing = S.Nothing + HOLambdaCall <$> lambFunc + <*> parameters + <*> lambParams + <*> (symbolic '{' *> fmap (V.fromList . concat) (many (try statement))) + <*> fmap tostrict (optional expression) <* symbolic '}' + where + parameters :: Parser (V.Vector Expression) + parameters = maybe V.empty V.fromList <$> optional (parens (expression `sepBy` comma)) + lambFunc :: Parser LambdaFunc + lambFunc = LambdaFunc <$> moduleName + lambParams :: Parser LambdaParameters + lambParams = between (symbolic '|') (symbolic '|') hp + where + lambdaParameter :: Parser LambdaParameter + lambdaParameter = LambdaParam <$> optional datatype <*> lexeme (char '$' *> identifier) + hp = V.fromList <$> lambdaParameter `sepBy1` comma diff --git a/src/Puppet/Parser/PrettyPrinter.hs b/src/Puppet/Parser/PrettyPrinter.hs --- a/src/Puppet/Parser/PrettyPrinter.hs +++ b/src/Puppet/Parser/PrettyPrinter.hs @@ -79,22 +79,13 @@ pretty (FunctionApplication e1 e2) = parens (pretty e1) <> "." <> pretty e2 instance Pretty LambdaFunc where - pretty LambEach = bold $ red "each" - pretty LambMap = bold $ red "map" - pretty LambReduce = bold $ red "reduce" - pretty LambFilter = bold $ red "filter" - pretty LambSlice = bold $ red "slice" - pretty LambLookup = bold $ red "lookup" + pretty (LambdaFunc nm) = bold $ red (ppline nm) instance Pretty LambdaParameters where - pretty b = magenta (pretty '|') <+> vars <+> magenta (pretty '|') + pretty b = encloseSep (magenta (pretty '|')) (magenta (pretty '|')) comma (V.toList (fmap mkv b)) where pmspace = foldMap ((<> " ") . pretty) - vars = - case b of - BPSingle (LParam mt v) -> pmspace mt <> pretty (UVariableReference v) - BPPair (LParam mt1 v1) (LParam mt2 v2) -> - pmspace mt1 <> pretty (UVariableReference v1) <> comma <+> pmspace mt2 <> pretty (UVariableReference v2) + mkv (LambdaParam mt v) = pmspace mt <> pretty (UVariableReference v) instance Pretty SearchExpression where pretty (EqualitySearch t e) = ppline t <+> "==" <+> pretty e @@ -104,8 +95,8 @@ pretty (OrSearch s1 s2) = parens (pretty s1) <+> "and" <+> parens (pretty s2) instance Pretty UnresolvedValue where - pretty (UBoolean True) = dullmagenta $ "true" - pretty (UBoolean False) = dullmagenta $ "false" + pretty (UBoolean True) = dullmagenta "true" + pretty (UBoolean False) = dullmagenta "false" pretty (UString s) = pretty '"' <> dullcyan (ppline (stringEscape s)) <> pretty '"' pretty (UNumber n) = cyan (ppline (scientific2text n)) pretty (UInterpolable v) = pretty '"' <> hcat (map specific (V.toList v)) <> pretty '"' @@ -128,12 +119,8 @@ instance Pretty HOLambdaCall where pretty (HOLambdaCall hf me bp stts mee) = - pretty hf <> mme <+> pretty bp <+> nest 2 (pretty '{' <> line <> ppStatements stts <> mmee) <$> pretty '}' + pretty hf <> parensList me <+> pretty bp <+> nest 2 (pretty '{' <> line <> ppStatements stts <> mmee) <$> pretty '}' where - mme = - case me of - S.Just x -> mempty <+> pretty x - S.Nothing -> mempty mmee = case mee of S.Just x -> mempty pretty x diff --git a/src/Puppet/Parser/Types.hs b/src/Puppet/Parser/Types.hs --- a/src/Puppet/Parser/Types.hs +++ b/src/Puppet/Parser/Types.hs @@ -12,12 +12,15 @@ ChainableRes(..), HasHOLambdaCall(..), LambdaParameter(..), - LambdaParameters(..), + LambdaParameters, CompRegex(..), CollectorType(..), Virtuality(..), NodeDesc(..), LinkType(..), + -- ** Synonyms + Parser, + PuppetParseError, -- ** Datatypes UDataType(..), -- ** Search Expressions @@ -37,241 +40,249 @@ VarAssignDecl(..), MainFuncDecl(..), HigherOrderLambdaDecl(..), - ResCollDecl(..) + ResCollDecl(..), + Parameters ) where -import XPrelude hiding (show) +import XPrelude hiding (show) -import Data.List.NonEmpty (NonEmpty) -import qualified Data.Maybe.Strict as S -import qualified Data.Text as Text -import qualified Data.Vector as V -import qualified GHC.Exts as Exts -import GHC.Show (Show (..)) +import Data.List.NonEmpty (NonEmpty) +import qualified Data.Maybe.Strict as S +import qualified Data.Text as Text +import qualified Data.Vector as V +import qualified GHC.Exts as Exts +import GHC.Show (Show (..)) +import Text.Megaparsec import Puppet.Language +type PuppetParseError = ParseError Char Void +type Parser = Parsec Void Text -- | /High Order lambdas/. -data LambdaFunc - = LambEach - | LambMap - | LambReduce - | LambFilter - | LambSlice - | LambLookup - deriving (Eq, Show) +newtype LambdaFunc = LambdaFunc Text deriving (Eq, Show) -- | Lambda block parameters: --- --- Currently only two types of block parameters are supported: --- single values and pairs. -data LambdaParameters - = BPSingle !LambdaParameter -- ^ @|k|@ - | BPPair !LambdaParameter !LambdaParameter -- ^ @|k,v|@ - deriving (Eq, Show) +type LambdaParameters = Vector LambdaParameter data LambdaParameter - = LParam !(Maybe UDataType) !Text - deriving (Eq, Show) + = LambdaParam !(Maybe UDataType) !Text + deriving (Eq, Show) -- The description of the /higher level lambda/ call. -data HOLambdaCall = HOLambdaCall - { _hoLambdaFunc :: !LambdaFunc - , _hoLambdaExpr :: !(S.Maybe Expression) - , _hoLambdaParams :: !LambdaParameters - , _hoLambdaStatements :: !(V.Vector Statement) - , _hoLambdaLastExpr :: !(S.Maybe Expression) - } deriving (Eq,Show) +data HOLambdaCall + = HOLambdaCall + { _hoLambdaFunc :: !LambdaFunc + , _hoLambdaExpr :: !(Vector Expression) + , _hoLambdaParams :: !LambdaParameters + , _hoLambdaStatements :: !(Vector Statement) + , _hoLambdaLastExpr :: !(S.Maybe Expression) + } deriving (Eq,Show) data ChainableRes - = ChainResColl !ResCollDecl - | ChainResDecl !ResDecl - | ChainResRefr !Text [Expression] !PPosition - deriving (Show, Eq) + = ChainResColl !ResCollDecl + | ChainResDecl !ResDecl + | ChainResRefr !Text [Expression] !PPosition + deriving (Show, Eq) data AttributeDecl - = AttributeDecl !Text !ArrowOp !Expression - | AttributeWildcard !Expression - deriving (Show, Eq) + = AttributeDecl !Text !ArrowOp !Expression + | AttributeWildcard !Expression + deriving (Show, Eq) + data ArrowOp - = AppendArrow -- ^ `+>` - | AssignArrow -- ^ `=>` - deriving (Show, Eq) + = AppendArrow -- ^ `+>` + | AssignArrow -- ^ `=>` + deriving (Show, Eq) -- | An unresolved value, typically the parser's output. data UnresolvedValue - = UBoolean !Bool -- ^ Special tokens generated when parsing the @true@ or @false@ literals. - | UString !Text -- ^ Raw string. - | UInterpolable !(V.Vector Expression) -- ^ A string that might contain variable references. The type should be refined at one point. - | UUndef -- ^ Special token that is generated when parsing the @undef@ literal. - | UResourceReference !Text !Expression -- ^ A Resource[reference] - | UArray !(V.Vector Expression) - | UHash !(V.Vector (Pair Expression Expression)) - | URegexp !CompRegex -- ^ The regular expression compilation is performed during parsing. - | UVariableReference !Text - | UFunctionCall !Text !(V.Vector Expression) - | UHOLambdaCall !HOLambdaCall - | UNumber !Scientific - | UDataType UDataType - deriving (Show, Eq) + = UBoolean !Bool -- ^ Special tokens generated when parsing the @true@ or @false@ literals. + | UString !Text -- ^ Raw string. + | UInterpolable !(Vector Expression) -- ^ A string that might contain variable references. The type should be refined at one point. + | UUndef -- ^ Special token that is generated when parsing the @undef@ literal. + | UResourceReference !Text !Expression -- ^ Alike @Resource[reference]@ + | UArray !(Vector Expression) + | UHash !(Vector (Pair Expression Expression)) + | URegexp !CompRegex -- ^ The regular expression compilation is performed during parsing. + | UVariableReference !Text + | UFunctionCall !Text !(Vector Expression) + | UHOLambdaCall !HOLambdaCall + | UNumber !Scientific + | UDataType UDataType + deriving (Show, Eq) instance Exts.IsList UnresolvedValue where - type Item UnresolvedValue = Expression - fromList = UArray . V.fromList - toList u = case u of - UArray lst -> V.toList lst - _ -> [Terminal u] + type Item UnresolvedValue = Expression + fromList = UArray . V.fromList + toList u = case u of + UArray lst -> V.toList lst + _ -> [Terminal u] instance IsString UnresolvedValue where - fromString = UString . Text.pack + fromString = UString . Text.pack data SelectorCase - = SelectorValue !UnresolvedValue - | SelectorType !UDataType - | SelectorDefault - deriving (Eq, Show) + = SelectorValue !UnresolvedValue + | SelectorType !UDataType + | SelectorDefault + deriving (Eq, Show) -- | The 'Expression's data Expression - = Equal !Expression !Expression - | Different !Expression !Expression - | Not !Expression - | And !Expression !Expression - | Or !Expression !Expression - | LessThan !Expression !Expression - | MoreThan !Expression !Expression - | LessEqualThan !Expression !Expression - | MoreEqualThan !Expression !Expression - | RegexMatch !Expression !Expression - | NotRegexMatch !Expression !Expression - | Contains !Expression !Expression - | Addition !Expression !Expression - | Substraction !Expression !Expression - | Division !Expression !Expression - | Multiplication !Expression !Expression - | Modulo !Expression !Expression - | RightShift !Expression !Expression - | LeftShift !Expression !Expression - | Lookup !Expression !Expression - | Negate !Expression - | ConditionalValue !Expression !(V.Vector (Pair SelectorCase Expression)) -- ^ All conditionals are stored in this format. - | FunctionApplication !Expression !Expression -- ^ This is for /higher order functions/. - | Terminal !UnresolvedValue -- ^ Terminal object contains no expression - deriving (Eq, Show) + = Equal !Expression !Expression + | Different !Expression !Expression + | Not !Expression + | And !Expression !Expression + | Or !Expression !Expression + | LessThan !Expression !Expression + | MoreThan !Expression !Expression + | LessEqualThan !Expression !Expression + | MoreEqualThan !Expression !Expression + | RegexMatch !Expression !Expression + | NotRegexMatch !Expression !Expression + | Contains !Expression !Expression + | Addition !Expression !Expression + | Substraction !Expression !Expression + | Division !Expression !Expression + | Multiplication !Expression !Expression + | Modulo !Expression !Expression + | RightShift !Expression !Expression + | LeftShift !Expression !Expression + | Lookup !Expression !Expression -- ^ Hash lookup @$var[\'key0\'][\'key1\']@ + | Negate !Expression + | ConditionalValue !Expression !(Vector (Pair SelectorCase Expression)) -- ^ All conditionals are stored in this format. + | FunctionApplication !Expression !Expression -- ^ This is for /higher order functions/. + | Terminal !UnresolvedValue -- ^ Terminal object contains no expression + deriving (Eq, Show) data UDataType - = UDTType - | UDTString (Maybe Int) (Maybe Int) - | UDTInteger (Maybe Int) (Maybe Int) - | UDTFloat (Maybe Double) (Maybe Double) - | UDTBoolean - | UDTArray UDataType Int (Maybe Int) - | UDTHash UDataType UDataType Int (Maybe Int) - | UDTUndef - | UDTScalar - | UDTData - | UDTOptional UDataType - | UNotUndef - | UDTVariant (NonEmpty UDataType) - | UDTPattern (NonEmpty CompRegex) - | UDTEnum (NonEmpty Expression) - | UDTAny - | UDTCollection - | UDTRegexp (Maybe CompRegex) - -- Tuple (NonEmpty DataType) Integer Integer - -- DTDefault - -- Struct TODO - deriving (Eq, Show) + = UDTType + | UDTString (Maybe Int) (Maybe Int) + | UDTInteger (Maybe Int) (Maybe Int) + | UDTFloat (Maybe Double) (Maybe Double) + | UDTBoolean + | UDTArray UDataType Int (Maybe Int) + | UDTHash UDataType UDataType Int (Maybe Int) + | UDTUndef + | UDTScalar + | UDTData + | UDTOptional UDataType + | UNotUndef + | UDTVariant (NonEmpty UDataType) + | UDTPattern (NonEmpty CompRegex) + | UDTEnum (NonEmpty Expression) + | UDTAny + | UDTCollection + | UDTRegexp (Maybe CompRegex) + -- Tuple (NonEmpty DataType) Integer Integer + -- DTDefault + -- Struct TODO + deriving (Eq, Show) instance Exts.IsList Expression where - type Item Expression = Expression - fromList = Terminal . Exts.fromList - toList u = case u of - Terminal t -> Exts.toList t - _ -> [u] + type Item Expression = Expression + fromList = Terminal . Exts.fromList + toList u = case u of + Terminal t -> Exts.toList t + _ -> [u] instance Num Expression where - (+) = Addition - (-) = Substraction - (*) = Multiplication - fromInteger = Terminal . UNumber . fromInteger - abs x = ConditionalValue (MoreEqualThan x 0) (V.fromList [SelectorValue (UBoolean True) :!: x, SelectorDefault :!: negate x]) - signum x = ConditionalValue (MoreThan x 0) (V.fromList [SelectorValue (UBoolean True) :!: 1, SelectorDefault :!: - ConditionalValue (Equal x 0) (V.fromList [SelectorValue (UBoolean True) :!: 0, SelectorDefault :!: (-1)]) - ]) + (+) = Addition + (-) = Substraction + (*) = Multiplication + fromInteger = Terminal . UNumber . fromInteger + abs x = ConditionalValue (MoreEqualThan x 0) (V.fromList [SelectorValue (UBoolean True) :!: x, SelectorDefault :!: negate x]) + signum x = ConditionalValue (MoreThan x 0) (V.fromList [SelectorValue (UBoolean True) :!: 1, SelectorDefault :!: + ConditionalValue (Equal x 0) (V.fromList [SelectorValue (UBoolean True) :!: 0, SelectorDefault :!: (-1)]) + ]) instance Fractional Expression where - (/) = Division - recip x = 1 / x - fromRational = Terminal . UNumber . fromRational + (/) = Division + recip x = 1 / x + fromRational = Terminal . UNumber . fromRational instance IsString Expression where - fromString = Terminal . fromString + fromString = Terminal . fromString --- | Search expression inside collector `<| searchexpr |>` +-- | Search expression inside collector @ \<| searchexpr |> @ data SearchExpression - = EqualitySearch !Text !Expression - | NonEqualitySearch !Text !Expression - | AndSearch !SearchExpression !SearchExpression - | OrSearch !SearchExpression !SearchExpression - | AlwaysTrue - deriving (Eq, Show) + = EqualitySearch !Text !Expression + | NonEqualitySearch !Text !Expression + | AndSearch !SearchExpression !SearchExpression + | OrSearch !SearchExpression !SearchExpression + | AlwaysTrue + deriving (Eq, Show) data CollectorType - = Collector - | ExportedCollector - deriving (Eq, Show) + = Collector -- ^ Single angle brackets @\<| |>@ + | ExportedCollector -- ^ Double angle brackets @\<\<| |>>@ + deriving (Eq, Show) data NodeDesc - = NodeName !Text - | NodeMatch !CompRegex - | NodeDefault - deriving (Show, Eq) + = NodeName !Text + | NodeMatch !CompRegex + | NodeDefault + deriving (Show, Eq) -- | Resource declaration: -- -- @ file { mode => 755} @ -data ResDecl = ResDecl !Text !Expression !(V.Vector AttributeDecl) !Virtuality !PPosition deriving (Eq, Show) +data ResDecl = ResDecl !Text !Expression !(Vector AttributeDecl) !Virtuality !PPosition deriving (Eq, Show) -- | Resource default: -- -- @ File { mode => 755 } @ -- -- . -data ResDefaultDecl = ResDefaultDecl !Text !(V.Vector AttributeDecl) !PPosition deriving (Eq, Show) +data ResDefaultDecl = ResDefaultDecl !Text !(Vector AttributeDecl) !PPosition deriving (Eq, Show) -- | Resource override: -- -- @ File['title'] { mode => 755} @ -- -- See . -data ResOverrideDecl = ResOverrideDecl !Text !Expression !(V.Vector AttributeDecl) !PPosition deriving (Eq, Show) +data ResOverrideDecl = ResOverrideDecl !Text !Expression !(Vector AttributeDecl) !PPosition deriving (Eq, Show) -- | 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 ConditionalDecl = ConditionalDecl !(Vector (Pair Expression (Vector Statement))) !PPosition deriving (Eq, Show) -data ClassDecl = ClassDecl !Text !(V.Vector (Pair (Pair Text (S.Maybe UDataType)) (S.Maybe Expression))) !(S.Maybe Text) !(V.Vector Statement) !PPosition deriving (Eq, Show) -data DefineDecl = DefineDecl !Text !(V.Vector (Pair (Pair Text (S.Maybe UDataType)) (S.Maybe Expression))) !(V.Vector Statement) !PPosition deriving (Eq, Show) +-- | Declare a class with +-- +-- * a name +-- * a list of parameters +-- * an optional inherits +-- * a list of statements +-- * a position +data ClassDecl = ClassDecl !Text !Parameters !(S.Maybe Text) !(Vector Statement) !PPosition deriving (Eq, Show) +-- | Declare a define with +-- * a name +-- * a list of parameters +-- * a list of statements +-- * a position +data DefineDecl = DefineDecl !Text !Parameters !(Vector Statement) !PPosition deriving (Eq, Show) + +type Parameters = Vector (Pair (Pair Text (S.Maybe UDataType)) (S.Maybe Expression)) + -- | 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) +data NodeDecl = NodeDecl !NodeDesc !(Vector Statement) !(S.Maybe NodeDesc) !PPosition deriving (Eq, Show) -- | @ $newvar = 'world' @ data VarAssignDecl - = VarAssignDecl - { _vadtype :: Maybe UDataType - , _vadname :: !Text - , _vadvalue :: !Expression - , _vadpos :: !PPosition - } deriving (Eq, Show) + = VarAssignDecl + { _vadtype :: Maybe UDataType + , _vadname :: !Text + , _vadvalue :: !Expression + , _vadpos :: !PPosition + } deriving (Eq, Show) -data MainFuncDecl = MainFuncDecl !Text !(V.Vector Expression) !PPosition deriving (Eq, Show) +data MainFuncDecl = MainFuncDecl !Text !(Vector Expression) !PPosition deriving (Eq, Show) -- | /Higher order function/ call. data HigherOrderLambdaDecl = HigherOrderLambdaDecl !HOLambdaCall !PPosition deriving (Eq, Show) @@ -281,25 +292,25 @@ -- @ User \<| title == 'jenkins' |> { groups +> "docker"} @ -- -- See -data ResCollDecl = ResCollDecl !CollectorType !Text !SearchExpression !(V.Vector AttributeDecl) !PPosition deriving (Eq, Show) +data ResCollDecl = ResCollDecl !CollectorType !Text !SearchExpression !(Vector AttributeDecl) !PPosition deriving (Eq, Show) data DepDecl = DepDecl !(Pair Text Expression) !(Pair Text Expression) !LinkType !PPosition deriving (Eq, Show) -- | All possible statements. data Statement - = ResourceDeclaration !ResDecl - | ResourceDefaultDeclaration !ResDefaultDecl - | ResourceOverrideDeclaration !ResOverrideDecl - | ResourceCollectionDeclaration !ResCollDecl - | ClassDeclaration !ClassDecl - | DefineDeclaration !DefineDecl - | NodeDeclaration !NodeDecl - | ConditionalDeclaration !ConditionalDecl - | VarAssignmentDeclaration !VarAssignDecl - | MainFunctionDeclaration !MainFuncDecl - | HigherOrderLambdaDeclaration !HigherOrderLambdaDecl - | DependencyDeclaration !DepDecl - | TopContainer !(V.Vector Statement) !Statement -- ^ Special statement used to include the expressions that are top level. Certainly buggy, but probably just like the original implementation. - deriving (Eq, Show) + = ResourceDeclaration !ResDecl + | ResourceDefaultDeclaration !ResDefaultDecl + | ResourceOverrideDeclaration !ResOverrideDecl + | ResourceCollectionDeclaration !ResCollDecl + | ClassDeclaration !ClassDecl + | DefineDeclaration !DefineDecl + | NodeDeclaration !NodeDecl + | ConditionalDeclaration !ConditionalDecl + | VarAssignmentDeclaration !VarAssignDecl + | MainFunctionDeclaration !MainFuncDecl + | HigherOrderLambdaDeclaration !HigherOrderLambdaDecl + | DependencyDeclaration !DepDecl + | TopContainer !(Vector Statement) !Statement -- ^ Special statement used to include the expressions that are top level. Certainly buggy, but probably just like the original implementation. + deriving (Eq, Show) makeClassy ''HOLambdaCall diff --git a/src/Puppet/Runner/Daemon.hs b/src/Puppet/Runner/Daemon.hs --- a/src/Puppet/Runner/Daemon.hs +++ b/src/Puppet/Runner/Daemon.hs @@ -76,12 +76,12 @@ getTemplate <- initTemplateDaemon intr pref templStats catStats <- newStats parseStats <- newStats - return (Daemon - (getCatalog' pref (parseFunc (pref ^. prefPuppetPaths) fcache parseStats) getTemplate catStats hquery) - parseStats - catStats - templStats - ) + pure (Daemon + (getCatalog' pref (parseFunc (pref ^. prefPuppetPaths) fcache parseStats) getTemplate catStats hquery) + parseStats + catStats + templStats + ) getCatalog' :: Preferences IO -> ( TopLevelType -> Text -> IO (S.Either PrettyError Statement) ) @@ -108,6 +108,7 @@ (pref ^. prefStrictness == Strict) (pref ^. prefPuppetPaths) (pref ^. prefRebaseFile) + ((pref ^. prefFactsOverride) `HM.union` (pref ^. prefFactsDefault)) ) node facts @@ -125,12 +126,18 @@ -- Build the 'HieraQueryLayers' needed by the interpreter to lookup hiera values. hieraQuery :: Preferences IO -> IO (HieraQueryLayers IO) hieraQuery pref = do - api0 <- case pref ^. prefHieraPath of - Just p -> startHiera p + global_api <- case pref ^. prefHieraPath of + Just p -> startHiera "global" p Nothing -> pure dummyHiera - modapis <- getModApis - pure (HieraQueryLayers api0 modapis) + env_api <- getEnvApi + mod_api <- getModApis + pure (HieraQueryLayers global_api env_api mod_api) where + getEnvApi :: IO (HieraQueryFunc IO) + getEnvApi = do + let f = (pref ^. prefPuppetPaths . baseDir) <> "/hiera.yaml" + found <- Directory.doesFileExist f + if found then startHiera "environment" f else pure dummyHiera getModApis :: IO (Container (HieraQueryFunc IO)) getModApis = do let ignored_modules = pref^.prefIgnoredmodules @@ -139,10 +146,10 @@ (HM.fromList . catMaybes) <$> for dirs (\dir -> runMaybeT $ do let modname = toS dir - path = modpath <> "/" <> dir <> "/hiera.yaml" + fp = modpath <> "/" <> dir <> "/hiera.yaml" guard (modname `notElem` ignored_modules) - guard =<< liftIO (Directory.doesFileExist path) - liftIO $ (modname, ) <$> startHiera path) + guard =<< liftIO (Directory.doesFileExist fp) + liftIO $ (modname, ) <$> startHiera "module" fp) defaultImpureMethods :: MonadIO m => IoMethods m 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 @@ -102,7 +102,7 @@ computeTemplate :: RubyInterpreter -> TemplateSource -> InterpreterState -> InterpreterReader IO -> MStats -> Cache.FileCacheR TemplateParseError [RubyStatement] -> IO TemplateAnswer computeTemplate rubyintp srcinfo intpstate intpreader mstats filecache = do let (curcontext, fvariables) = - case extractFromState intpstate of + case extractScope intpstate of Nothing -> (mempty, mempty) Just (c,v) -> (c,v) template_src = templateSrc srcinfo @@ -119,7 +119,7 @@ Inline s -> measure mstats ("parsing - " <> toS template_src) $ pure $ encapsulateError (runParser erbparser () "inline" (toS s)) o <- case parsed of Left err -> do - let !msg = "Template '" <> template_src <> "' could not be parsed " <> show (tgetError err) + let !msg = "Template could not be parsed " <> show (tgetError err) -- if the haskell parser fails the ruby one will fallback. logInfoStr msg measure mstats ("ruby - " <> toS template_src) $ mkSafe $ computeTemplateWRuby srcinfo curcontext variables intpstate intpreader diff --git a/src/Puppet/Runner/Puppetlabs.hs b/src/Puppet/Runner/Puppetlabs.hs --- a/src/Puppet/Runner/Puppetlabs.hs +++ b/src/Puppet/Runner/Puppetlabs.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedLists #-} -- | Contains an Haskell implementation (or mock implementation) of some ruby functions found in puppetlabs modules. module Puppet.Runner.Puppetlabs (extFunctions) where @@ -7,7 +8,7 @@ import Data.ByteString (ByteString) import Data.Char (isDigit) import Data.Foldable (foldlM) -import qualified Data.HashMap.Strict as HM +import qualified Data.HashMap.Strict as Map import Data.Scientific as Sci import qualified Data.Text as Text import qualified Data.Text.Encoding as Text @@ -24,11 +25,13 @@ extFun :: [(FilePath, Text, [PValue] -> InterpreterMonad PValue)] extFun = [ ("/apache", "bool2httpd", apacheBool2httpd) + , ("/docker", "docker_swarm_join_flags", mockDockerSwarmJoinFlags) , ("/docker", "docker_run_flags", mockDockerRunFlags) , ("/jenkins", "jenkins_port", mockJenkinsPort) , ("/jenkins", "jenkins_prefix", mockJenkinsPrefix) , ("/postgresql", "postgresql_acls_to_resources_hash", pgAclsToHash) , ("/postgresql", "postgresql_password", pgPassword) + , ("/puppetdb", "puppetdb_create_subsetting_resource_hash", puppetdb_create_subsetting_resource_hash) , ("/extlib", "random_password", randomPassword) , ("/extlib", "cache_data", mockCacheData) ] @@ -37,19 +40,19 @@ -- -- If the ruby file is not found on the local filesystem the record is ignored. This is to avoid potential namespace conflict. extFunctions :: FilePath -> IO (Container ( [PValue] -> InterpreterMonad PValue)) -extFunctions modpath = foldlM f HM.empty extFun +extFunctions modpath = foldlM f Map.empty extFun where f acc (modname, fname, fn) = do test <- testFile modname fname if test - then return $ HM.insert fname fn acc + then return $ Map.insert fname fn acc else return acc testFile modname fname = Directory.doesFileExist (modpath <> modname <> "/lib/puppet/parser/functions/" <> Text.unpack fname <>".rb") apacheBool2httpd :: MonadThrowPos m => [PValue] -> m PValue -apacheBool2httpd [PBoolean True] = return $ PString "On" -apacheBool2httpd [PString "true"] = return $ PString "On" -apacheBool2httpd [_] = return $ PString "Off" +apacheBool2httpd [PBoolean True] = pure $ PString "On" +apacheBool2httpd [PString "true"] = pure $ PString "On" +apacheBool2httpd [_] = pure $ PString "Off" apacheBool2httpd arg@_ = throwPosError $ "expect one single argument" <+> pretty arg pgPassword :: MonadThrowPos m => [PValue] -> m PValue @@ -89,14 +92,14 @@ pgAclsToHash _ = throwPosError "expects 3 arguments; one array one string and one number" aclsToHash :: MonadThrowPos m => Vector PValue -> Text -> Scientific -> m (Container PValue) -aclsToHash vec ident offset = ifoldlM f HM.empty vec +aclsToHash vec ident offset = ifoldlM f Map.empty vec where f :: MonadThrowPos m => Int -> Container PValue -> PValue -> m (Container PValue) f idx acc (PString acl) = do let order = offset + scientific (toInteger idx) 0 keymsg = sformat ("postgresql class generated rule " % FMT.stext % " " % FMT.int) ident idx x <- aclToHash (Text.words acl) order - return $ HM.insert keymsg x acc + return $ Map.insert keymsg x acc f _ _ pval = throwPosError $ "expect a string as acl but get" <+> pretty pval aclToHash :: (MonadThrowPos m) => [Text] -> Scientific -> m PValue @@ -105,7 +108,7 @@ fin remn hs = return $ PHash $ if null remn then hs - else HM.insert "auth_option" (PString (Text.unwords remn)) hs + else Map.insert "auth_option" (PString (Text.unwords remn)) hs analyze = case remaining of method : remn | typ == "local" -> fin remn $ baseHash & at "auth_method" ?~ PString method @@ -116,12 +119,11 @@ fin remn $ baseHash & at "address" ?~ PString addr & at "auth_method" ?~ PString method _ -> throwPosError $ "Unable to parse acl line" <+> squotes (ppline (Text.unwords acl)) - baseHash = HM.fromList - [ ("type", PString "local") - , ("database", PString db ) - , ("user", PString usr) - , ("order", PString (sformat (FMT.left 3 '0' %. scifmt Sci.Fixed (Just 0)) order)) - ] + baseHash = [ ("type", PString "local") + , ("database", PString db ) + , ("user", PString usr) + , ("order", PString (sformat (FMT.left 3 '0' %. scifmt Sci.Fixed (Just 0)) order)) + ] aclToHash acl _ = throwPosError $ "Unable to parse acl line" <+> squotes (ppline (Text.unwords acl)) -- faked implementation, replace by the correct one if you need so. @@ -129,8 +131,23 @@ mockDockerRunFlags arg@[PHash _]= (pure . PString . show . head) arg mockDockerRunFlags arg@_ = throwPosError $ "Expect an hash as argument but was" <+> pretty arg +-- faked implementation, replace by the correct one if you need so. +mockDockerSwarmJoinFlags :: MonadThrowPos m => [PValue] -> m PValue +mockDockerSwarmJoinFlags arg@[PHash _]= (pure . PString . show . head) arg +mockDockerSwarmJoinFlags arg@_ = throwPosError $ "Expect an hash as argument but was" <+> pretty arg + -- utils scientificToInt :: MonadThrowPos m => Scientific -> m Int -scientificToInt s = maybe (throwPosError $ "Unable to convert" <+> ppline (show s) <+> "into an int.") - return +scientificToInt s = maybe (throwPosError $ "Unable to convert" <+> pretty s <+> "into an int.") + pure (Sci.toBoundedInteger s) + +-- https://github.com/puppetlabs/puppetlabs-puppetdb/blob/master/lib/puppet/parser/functions/puppetdb_create_subsetting_resource_hash.rb +puppetdb_create_subsetting_resource_hash :: MonadThrowPos m => [PValue] -> m PValue +puppetdb_create_subsetting_resource_hash [PHash s, PHash args] = do + let res_hash = [ (k, PHash h) + | (k,v) <- itoList s + , let h = [ ( "subsetting", PString k) , ("value", v)] `Map.union` args + ] + pure $ PHash (Map.fromList res_hash) +puppetdb_create_subsetting_resource_hash arg@_ = throwPosError $ "Expect 2 hashes as arguments but was" <+> pretty arg 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 @@ -3,11 +3,14 @@ -- functions that can be found in "Puppet.Interpreter" and -- "Puppet.Interpreter.Resolve". -- +-- This module is quite useful for quick testing in a repl or within the test suites. +-- -- >>> dummyEval (resolveExpression (Addition "1" "2")) -- Right (PString "3") module Puppet.Runner.Pure ( dummyEval , dummyFacts + , dummyInitialState , pureEval , pureEval' , pureReader @@ -27,24 +30,37 @@ import PuppetDB (dummyPuppetDB) -dummyTemplate :: Monad m => TemplateSource -> InterpreterState -> InterpreterReader m -> m (S.Either PrettyError Text) -dummyTemplate (Filename _) _ _ = return (S.Left "Can't interpret files") -dummyTemplate (Inline cnt) s _ = - return $ case extractFromState s of - Nothing -> S.Left "Context retrieval error (pureReader)" - Just (ctx, scope) -> - case parseErbString (toS cnt) of - Left e -> S.Left (PrettyError (pplines (show e))) - Right stmts -> - case rubyEvaluate scope ctx stmts of - Right x -> S.Right x - Left e -> S.Left (PrettyError e) +-- | Evaluates with a map of statements in a pure context. +-- Unlike 'dummyEval', each hiera lookup is evaluated to return Nothing. +pureEval :: HM.HashMap (TopLevelType, Text) Statement -- ^ A top-level map + -> InterpreterMonad a -- ^ The action to evaluate + -> (Either PrettyError a, InterpreterState, InterpreterWriter) +pureEval stmap action = + pureEval' stmap dummyInitialState Nothing action +-- | More flexible version of 'pureEval' +pureEval' :: HM.HashMap (TopLevelType, Text) Statement -- ^ A top-level map + -> InterpreterState -- ^ the initial state + -> Maybe PValue -- ^ a value to be return by all hiera lookup + -> InterpreterMonad a -- ^ The action to evaluate + -> (Either PrettyError a, InterpreterState, InterpreterWriter) +pureEval' stmap s0 hiera action = + runIdentity (interpretMonad (pureReader stmap hiera) s0 action) + +-- | A default evaluation function for arbitrary interpreter actions. +-- Unlike 'pureEval', each hiera lookup is evaluated to return the string 'dummy'. +dummyEval :: InterpreterMonad a -> Either PrettyError a +dummyEval action = pureEval' mempty dummyInitialState (Just "dummy") action ^. _1 + +dummyInitialState :: InterpreterState +dummyInitialState = initialState dummyFacts [("confdir", "/etc/puppet")] + -- | A pure 'InterpreterReader', that can only evaluate a subset of the -- templates, and that can include only the supplied top level statements. pureReader :: HM.HashMap (TopLevelType, Text) Statement -- ^ A top-level statement map + -> Maybe PValue -- ^ What value a call to hiera should return -> InterpreterReader Identity -pureReader sttmap = +pureReader sttmap hiera = InterpreterReader baseNativeTypes getstatementdummy @@ -59,40 +75,34 @@ True (puppetPaths "/etc/puppet") Nothing + mempty where pure_hiera :: HieraQueryFunc Identity - pure_hiera _ _ _ = pure (S.Right (Just "pure")) - hieradummy = HieraQueryLayers pure_hiera mempty + pure_hiera _ _ _ = pure (S.Right hiera) + hieradummy = HieraQueryLayers pure_hiera pure_hiera mempty getstatementdummy tlt n = return $ case HM.lookup (tlt,n) sttmap of Just x -> S.Right x Nothing -> S.Left "Can't get statement" iomethods_purestubs :: IoMethods Identity iomethods_purestubs = IoMethods (return []) (const (return (Left "Can't read file"))) (\_ -> return ()) --- | Evaluates an interpreter expression in a pure context. -pureEval :: Facts -- ^ A list of facts that will be used during evaluation - -> HM.HashMap (TopLevelType, Text) Statement -- ^ A top-level map - -> InterpreterMonad a -- ^ The action to evaluate - -> (Either PrettyError a, InterpreterState, InterpreterWriter) -pureEval facts stmap action = - pureEval' stmap state0 action - where - state0 = initialState facts $ HM.fromList [("confdir", "/etc/puppet")] - --- | More general version of 'pureEval' where you pass the initial state directly -pureEval' :: HM.HashMap (TopLevelType, Text) Statement -- ^ A top-level map - -> InterpreterState - -> InterpreterMonad a -- ^ The action to evaluate - -> (Either PrettyError a, InterpreterState, InterpreterWriter) -pureEval' stmap s0 action = - runIdentity (interpretMonad (pureReader stmap) s0 action) - +dummyTemplate :: Monad m => TemplateSource -> InterpreterState -> InterpreterReader m -> m (S.Either PrettyError Text) +dummyTemplate (Filename _) _ _ = return (S.Left "Can't interpret files") +dummyTemplate (Inline cnt) s _ = + return $ case extractScope s of + Nothing -> S.Left "Context retrieval error (pureReader)" + Just (ctx, scope) -> + case parseErbString (toS cnt) of + Left e -> S.Left (PrettyError (pplines (show e))) + Right stmts -> + case rubyEvaluate scope ctx stmts of + Right x -> S.Right x + Left e -> S.Left (PrettyError e) -- | A bunch of facts that can be used for pure evaluation. dummyFacts :: Facts dummyFacts = HM.fromList - [ ("architecture", "amd64") - , ("augeasversion", "0.10.0") + [ ("augeasversion", "0.10.0") , ("bios_release_date", "07/06/2010") , ("bios_vendor", "Dell Inc.") , ("bios_version", "2.2.0") @@ -175,7 +185,3 @@ , ("uuid", "97b75940-be55-11e3-b1b6-0800200c9a66") , ("virtual", "physical") ] - --- | A default evaluation function for arbitrary interpreter actions. -dummyEval :: InterpreterMonad a -> Either PrettyError a -dummyEval action = pureEval dummyFacts mempty action ^. _1 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 @@ -51,6 +51,7 @@ , singleArgument "empty" _empty -- ensure_packages (in main interpreter module) -- ensure_resource (in main interpreter module) + , singleArgument "fact" fact , singleArgument "flatten" flatten -- floor -- fqdn_rand_string @@ -118,6 +119,8 @@ -- type -- union , singleArgument "unique" unique + -- from puppetlabs-translate + , ("translate", translate) -- unix2dos , ("upcase", stringArrayFunction Text.toUpper) -- uriescape @@ -300,11 +303,18 @@ deleteUndefValues :: PValue -> InterpreterMonad PValue deleteUndefValues (PArray r) = return $ PArray $ V.filter (/= PUndef) r deleteUndefValues (PHash h) = return $ PHash $ HM.filter (/= PUndef) h -deleteUndefValues x = throwPosError ("delete_undef_values(): Expects an Array or a Hash, not" <+> pretty x) +deleteUndefValues x = throwPosError ("delete_undef_values(): Expects an Array or a Hash, not" <+> pretty x) _empty :: PValue -> InterpreterMonad PValue _empty = return . PBoolean . flip elem [PUndef, PString "", PString "undef", PArray V.empty, PHash HM.empty] +fact :: PValue -> InterpreterMonad PValue +fact (PString k) = do + askFact k >>= \case + Just r -> pure r + Nothing -> throwPosError ("fact(): Failed to retrieve fact" <+> ppline k) +fact x = throwPosError ("fact(): Expects a String, not" <+> pretty x) + flatten :: PValue -> InterpreterMonad PValue flatten r@(PArray _) = return $ PArray (flatten' r) where @@ -526,3 +536,8 @@ pvalues :: PValue -> InterpreterMonad PValue pvalues (PHash h) = return $ PArray (toVectorOf traverse h) pvalues x = throwPosError ("values(): expected a hash, not" <+> pretty x) + +-- dummy translate method from puppetlabs-translate (used in puppetlabs-docker for instance) +translate :: [PValue] -> InterpreterMonad PValue +translate [v@(PString _)] = pure v +translate x = throwPosError ("values(): expected a String, not" <+> pretty x) diff --git a/src/PuppetDB.hs b/src/PuppetDB.hs --- a/src/PuppetDB.hs +++ b/src/PuppetDB.hs @@ -63,7 +63,7 @@ puppetDBFacts :: NodeName -> PuppetDBAPI IO -> IO (HashMap Text PValue) puppetDBFacts node pdbapi = - runExceptT (getFacts pdbapi (QEqual FCertname node)) >>= \case + runExceptT (getPDBFacts pdbapi (QEqual FCertname node)) >>= \case Right facts@(_:_) -> return (Map.fromList (map (\f -> (f ^. factInfoName, f ^. factInfoVal)) facts)) _ -> do rawFacts <- fmap concat (sequence [factNET, factRAM, factOS, fversion, factMountPoints, factOS, factUser, factUName, fenv, factProcessor]) diff --git a/src/PuppetDB/Core.hs b/src/PuppetDB/Core.hs --- a/src/PuppetDB/Core.hs +++ b/src/PuppetDB/Core.hs @@ -181,7 +181,7 @@ , replaceCatalog :: WireCatalog -> ExceptT PrettyError m () -- ^ , replaceFacts :: [(NodeName, Facts)] -> ExceptT PrettyError m () -- ^ , deactivateNode :: NodeName -> ExceptT PrettyError m () -- ^ - , getFacts :: Query FactField -> ExceptT PrettyError m [FactInfo] -- ^ + , getPDBFacts :: Query FactField -> ExceptT PrettyError m [FactInfo] -- ^ , getResources :: Query ResourceField -> ExceptT PrettyError m [Resource] -- ^ , getNodes :: Query NodeField -> ExceptT PrettyError m [NodeInfo] , commitDB :: ExceptT PrettyError m () -- ^ This is only here to tell the test PuppetDB to save its content to disk. diff --git a/src/XPrelude/Extra.hs b/src/XPrelude/Extra.hs --- a/src/XPrelude/Extra.hs +++ b/src/XPrelude/Extra.hs @@ -5,12 +5,11 @@ , String , Container , unwrapError - , isEmpty , dropInitialColons , strictifyEither , scientific2text , text2Scientific - , ifromList, ikeys, isingleton, ifromListWith, iunionWith, iinsertWith + , ifromList, ikeys, ifromListWith, iunionWith, iinsertWith -- * Logger , loggerName , logDebug @@ -77,14 +76,11 @@ {-# INLINABLE ifromList #-} ifromList = foldl' (\curm (k,v) -> curm & at k ?~ v) mempty +-- | Return all the keys of a map in a set. ikeys :: (Eq k, Hashable k) => HashMap k v -> HS.HashSet k {-# INLINABLE ikeys #-} ikeys = HS.fromList . Map.keys -isingleton :: (Monoid b, At b) => Index b -> IxValue b -> b -{-# INLINABLE isingleton #-} -isingleton k v = mempty & at k ?~ v - ifromListWith :: (Monoid m, At m, Foldable f) => (IxValue m -> IxValue m -> IxValue m) -> f (Index m, IxValue m) -> m {-# INLINABLE ifromListWith #-} ifromListWith f = foldl' (\curmap (k,v) -> iinsertWith f k v curmap) mempty @@ -100,9 +96,6 @@ iunionWith :: (Hashable k, Eq k) => (v -> v -> v) -> HashMap k v -> HashMap k v -> HashMap k v {-# INLINABLE iunionWith #-} iunionWith = Map.unionWith - -isEmpty :: (Eq x, Monoid x) => x -> Bool -isEmpty = (== mempty) -- | Remove the '::' token from a text if any. dropInitialColons :: Text -> Text diff --git a/src/XPrelude/PP.hs b/src/XPrelude/PP.hs --- a/src/XPrelude/PP.hs +++ b/src/XPrelude/PP.hs @@ -4,7 +4,6 @@ module XPrelude.PP ( module Exports , PrettyError (..) - , prettyToShow , ppline , pplines , pptext @@ -64,6 +63,3 @@ -- | pretty print one line of string pptext :: String -> Doc pptext = text - -prettyToShow :: Doc -> String -prettyToShow d = displayS (renderCompact d) "" diff --git a/tests/DT/Parser.hs b/tests/DT/Parser.hs deleted file mode 100644 --- a/tests/DT/Parser.hs +++ /dev/null @@ -1,24 +0,0 @@ -module DT.Parser (spec) where - -import Helpers - -import Test.Hspec.Megaparsec -import Text.Megaparsec (parse) -import qualified Text.Regex.PCRE.ByteString.Utils as Regex - -spec :: Spec -spec = do - let parsed s r = it ("accepts " <> toS s) $ parse datatype "?" s `shouldParse` r - failed s = it ("rejects " <> toS s) $ shouldFailOn (parse datatype "?") s - describe "String" $ do - "String" `parsed` UDTString Nothing Nothing - failed "String[]" - failed "String[4,5,6]" - "String[5]" `parsed` UDTString (Just 5) Nothing - "String[5,8]" `parsed` UDTString (Just 5) (Just 8) - "Regexp" `parsed` UDTRegexp Nothing - let Right foore = Regex.compile' Regex.compBlank Regex.execBlank "foo" - "Regexp[/foo/]" `parsed` UDTRegexp (Just (CompRegex "foo" foore)) - it "accepts variables" $ pendingWith "to be fixed" *> parse datatype "?" "String[$var]" `shouldParse` UDTString (Just 5) Nothing - describe "Stdlib::" $ do - "Stdlib::HTTPUrl" `parsed` UDTData diff --git a/tests/ErbSpec.hs b/tests/ErbSpec.hs --- a/tests/ErbSpec.hs +++ b/tests/ErbSpec.hs @@ -10,10 +10,10 @@ parsingtests :: [(String, [RubyStatement])] parsingtests = [ ("port = 5432", [ Puts (Value (Literal "port = 5432" ))]) - , ("mode = host=<% @var %>", [ Puts (Value (Literal "mode = host=")) + , ("mode = host=<%= @var %>", [ Puts (Value (Literal "mode = host=")) , Puts (Object (Value (Literal "@var"))) , Puts (Value (Literal ""))]) - , ("mode = host=<% var %>", [ Puts (Value (Literal "mode = host=")) + , ("mode = host=<%= var %>", [ Puts (Value (Literal "mode = host=")) , Puts (Object (Value (Literal "var"))) , Puts (Value (Literal ""))]) , ("<%= @os['architecture'] %>", [ Puts (Value (Literal "")) @@ -27,7 +27,7 @@ , Puts (Value (Literal ""))]) , ("<%= scope.lookupvar('::fqdn') %>", [ Puts (Value (Literal "")) , Puts (ScopeObject (Value (Literal "::fqdn"))) - , Puts(Value (Literal ""))]) + , Puts(Value (Literal ""))]) ] resolvetests :: [([RubyStatement], Text)] @@ -60,7 +60,7 @@ resolvespec = let state0 = initialState dummyFacts mempty - Just (scope_name, scope) = extractFromState state0 + Just (scope_name, scope) = extractScope state0 in for_ resolvetests $ \(s, e) -> let item = it ("should resolve " <> show s) in diff --git a/tests/EvalSpec.hs b/tests/EvalSpec.hs deleted file mode 100644 --- a/tests/EvalSpec.hs +++ /dev/null @@ -1,44 +0,0 @@ -module EvalSpec (spec) where - - -import Test.Hspec -import Text.Megaparsec (eof, parse) - -import Puppet.Interpreter -import Puppet.Parser -import Puppet.Runner -import XPrelude - -evaluations = [ "4 + 2 == 6" - , "[1,2][1] == 2" - , "[1,[1,2]][1][0] == 1" - , "[1,2,3] + [4,5,6] == [1,2,3,4,5,6]" - , "{a => 1} + {b => 2} == {a=>1, b=>2 }" - , "[1,2,3] << 10 == [1,2,3,10]" - , "[1,2,3] << [4,5] == [1,2,3,[4,5]]" - , "4 / 2.0 == 2" - , "$architecture == 'amd64'" - , "$facts['architecture'] == 'amd64'" - , "$settings::confdir == '/etc/puppet'" - , "regsubst('127', '([0-9]+)', '<\\1>', 'G') == '<127>'" - , "regsubst(['1','2','3'], '([0-9]+)', '<\\1>', 'G') == ['<1>','<2>','<3>']" - , "versioncmp('2.1','2.2') == -1" - , "inline_template('a','b') == 'ab'" - ] - -testEvaluation t = - let item = it ("should evaluate " <> t) in - case check (toS t) of - Left ctx -> context ctx $ item False - Right b -> item b - -check :: Text -> Either String Bool -check t = - case parse (expression <* eof) "dummy" t of - Left _ -> Left $ "Parsing error: are you sure the evaluation is correct ?" - Right e -> case dummyEval (resolveExpression e) of - Right (PBoolean True) -> Right True - _ -> Right False - -spec = do - describe "Evaluation of expressions" $ mapM_ testEvaluation evaluations diff --git a/tests/ExprSpec.hs b/tests/ExprSpec.hs deleted file mode 100644 --- a/tests/ExprSpec.hs +++ /dev/null @@ -1,35 +0,0 @@ -module ExprSpec (spec) where - -import qualified Data.Vector as Vector -import Test.Hspec -import Test.Hspec.Megaparsec -import Text.Megaparsec - -import Puppet.Parser -import XPrelude - -expressions :: [(Text, Expression)] -expressions = - [ ("5 + 3 * 2", 5 + 3 * 2) - , ("5+2 == 7", Equal (5 + 2) 7) - , ("include(foo::bar)", Terminal (UFunctionCall "include" (Vector.singleton "foo::bar") )) - , ("$y ? {\ - \ undef => 'undef',\ - \ default => 'default',\ - \ }", ConditionalValue (Terminal (UVariableReference "y")) - (Vector.fromList [SelectorValue UUndef :!: Terminal (UString "undef") - ,SelectorDefault :!: Terminal (UString "default")])) - , ("$x", Terminal (UVariableReference "x")) - , ("x($y)", Terminal (UFunctionCall "x" (Vector.singleton (Terminal (UVariableReference "y"))))) - , ("\"${x}\"", Terminal (UInterpolable (Vector.fromList [Terminal (UVariableReference "x")]))) - , ("\"${x[3]}\"", Terminal (UInterpolable (Vector.fromList [Lookup (Terminal (UVariableReference "x")) 3]))) - , ("\"${x[$y]}\"", Terminal (UInterpolable (Vector.fromList [Lookup (Terminal (UVariableReference "x")) (Terminal (UVariableReference "y")) ]))) - , ("\"${x($y)}\"", Terminal (UInterpolable (Vector.fromList [ Terminal (UFunctionCall "x" (Vector.singleton (Terminal (UVariableReference "y")))) ]))) - , ("\"${x($y)}$'\"", Terminal (UInterpolable (Vector.fromList [ Terminal (UFunctionCall "x" (Vector.singleton (Terminal (UVariableReference "y")))),Terminal (UString "$"),Terminal (UString "'")]))) - ] - - -testExpression (t,e) = it ("should parse " ++ show t) $ parse (expression <* eof) "" t `shouldParse` e - -spec = do - describe "Expression parser" $ mapM_ testExpression expressions diff --git a/tests/Function/AssertPrivateSpec.hs b/tests/Function/AssertPrivateSpec.hs deleted file mode 100644 --- a/tests/Function/AssertPrivateSpec.hs +++ /dev/null @@ -1,30 +0,0 @@ -{-# LANGUAGE OverloadedLists #-} -module Function.AssertPrivateSpec where - -import Helpers - -import Puppet.Interpreter (initialState) - - -main :: IO () -main = hspec spec - -evalWithScope :: ([PValue] -> InterpreterMonad PValue) - -> Text -- ^ caller scope - -> Text -- ^ module scope - -> [Expression] -- ^ function args - -> Either String PValue -evalWithScope apFunc callerScope moduleScope = (_Left %~ show) . view _1 . ctxEval . (mapM resolveExpression >=> apFunc) - where - ctxEval = pureEval' mempty state0 - state0 = initialState dummyFacts [("confdir", "/etc/puppet")] & curScope .~ [ContClass moduleScope, ContClass callerScope] - - -spec :: Spec -spec = withStdlibFunction "assert_private" $ \apFunc -> do - let errorWith a b = case a of - Right x -> fail ("Should have failed, got this instead: " ++ show x) - Left rr -> rr `shouldContain` b - it "should work when called from inside module" (evalWithScope apFunc "bar" "bar" [] `shouldBe` Right PUndef) - it "should fail with the default message" (evalWithScope apFunc "bar" "baz" [] `errorWith` "is private") - it "should fail with an explicit failure message" (evalWithScope apFunc "bar" "baz" ["lalala"] `errorWith` "lalala") diff --git a/tests/Function/DeleteAtSpec.hs b/tests/Function/DeleteAtSpec.hs deleted file mode 100644 --- a/tests/Function/DeleteAtSpec.hs +++ /dev/null @@ -1,30 +0,0 @@ -{-# LANGUAGE OverloadedLists #-} - -module Function.DeleteAtSpec (spec, main) where - -import Helpers - -main :: IO () -main = hspec spec - -spec :: Spec -spec = withStdlibFunction "delete_at" $ \deleteAtFunc -> do - let evalArgs' = dummyEval . deleteAtFunc - narray = PArray . fmap PNumber - check a b res = case evalArgs' [narray a, PNumber b] of - Left rr -> expectationFailure (show rr) - Right res' -> res' `shouldBe` narray res - checkError args ins = case evalArgs' args of - Left rr -> show rr `shouldContain` ins - Right r -> expectationFailure ("Should have errored, received this instead: " <> show r) - it "should error with invalid arguments" $ do - checkError [] "expects 2 arguments" - checkError [PNumber 1] "expects 2 arguments" - checkError ["foo", "bar"] "expects its first argument to be an array" - checkError [ narray [0,1,2], PNumber 3 ] "Out of bounds access" - it "should work otherwise" $ do - check [0,1,2] 1 [0,2] - it "should work for negative positions" $ do - pending - check [0,1,2] (-1) [0,1] - check [0,1,2] (-4) [0,1,2] diff --git a/tests/Function/EachSpec.hs b/tests/Function/EachSpec.hs deleted file mode 100644 --- a/tests/Function/EachSpec.hs +++ /dev/null @@ -1,50 +0,0 @@ -{-# LANGUAGE OverloadedLists #-} -module Function.EachSpec (spec, main) where - -import Helpers - -main :: IO () -main = hspec spec - -spec :: Spec -spec = do - let mgetCatalog x = case getCatalog x of - Left rr -> fail rr - Right y -> return y - describe "should be callable as" $ do - it "each on an array selecting each value" $ do - c <- mgetCatalog "$a = [1,2,3]\n $a.each |$v| {\n file { \"/file_$v\": ensure => present } \n } " - getResource (RIdentifier "file" "/file_1") c >>= getAttribute "ensure" >>= \a -> a `shouldBe` "present" - getResource (RIdentifier "file" "/file_2") c >>= getAttribute "ensure" >>= \a -> a `shouldBe` "present" - getResource (RIdentifier "file" "/file_3") c >>= getAttribute "ensure" >>= \a -> a `shouldBe` "present" - it "each on an array selecting each value - function call style" $ do - c <- mgetCatalog "$a = [1,2,3]\n each ($a) |$index, $v| {\n file { \"/file_$v\": ensure => present }\n }" - getResource (RIdentifier "file" "/file_1") c >>= getAttribute "ensure" >>= \a -> a `shouldBe` "present" - getResource (RIdentifier "file" "/file_2") c >>= getAttribute "ensure" >>= \a -> a `shouldBe` "present" - getResource (RIdentifier "file" "/file_3") c >>= getAttribute "ensure" >>= \a -> a `shouldBe` "present" - it "each on an array with index" $ do - c <- mgetCatalog "$a = [present, absent, present]\n $a.each |$k,$v| {\n file { \"/file_$k\": ensure => $v }\n }" - getResource (RIdentifier "file" "/file_0") c >>= getAttribute "ensure" >>= \a -> a `shouldBe` "present" - getResource (RIdentifier "file" "/file_1") c >>= getAttribute "ensure" >>= \a -> a `shouldBe` "absent" - getResource (RIdentifier "file" "/file_2") c >>= getAttribute "ensure" >>= \a -> a `shouldBe` "present" - it "each on a hash selecting entries" $ do - c <- mgetCatalog "$a = {'a'=>'present','b'=>'absent','c'=>'present'}\n $a.each |$e| {\n $num = $e[0]\n file { \"/file_${num}\": ensure => $e[1] }\n }" - getResource (RIdentifier "file" "/file_a") c >>= getAttribute "ensure" >>= \a -> a `shouldBe` "present" - getResource (RIdentifier "file" "/file_b") c >>= getAttribute "ensure" >>= \a -> a `shouldBe` "absent" - getResource (RIdentifier "file" "/file_c") c >>= getAttribute "ensure" >>= \a -> a `shouldBe` "present" - it "each on a hash selecting key and value" $ do - c <- mgetCatalog "$a = {'a'=>present,'b'=>absent,'c'=>present}\n $a.each |$k, $v| {\n file { \"/file_$k\": ensure => $v }\n }" - getResource (RIdentifier "file" "/file_a") c >>= getAttribute "ensure" >>= \a -> a `shouldBe` "present" - getResource (RIdentifier "file" "/file_b") c >>= getAttribute "ensure" >>= \a -> a `shouldBe` "absent" - getResource (RIdentifier "file" "/file_c") c >>= getAttribute "ensure" >>= \a -> a `shouldBe` "present" - it "each on a hash selecting key and value (using captures-last parameter)" $ do - pending - c <- mgetCatalog "$a = {'a'=>present,'b'=>absent,'c'=>present}\n $a.each |*$kv| {\n file { \"/file_${kv[0]}\": ensure => $kv[1] }\n }" - getResource (RIdentifier "file" "/file_a") c >>= getAttribute "ensure" >>= \a -> a `shouldBe` "present" - getResource (RIdentifier "file" "/file_b") c >>= getAttribute "ensure" >>= \a -> a `shouldBe` "absent" - getResource (RIdentifier "file" "/file_c") c >>= getAttribute "ensure" >>= \a -> a `shouldBe` "present" - describe "should produce receiver" $ - it "each checking produced value using single expression" $ do - pending - c <- mgetCatalog "$a = [1, 3, 2]\n $b = $a.each |$x| { \"unwanted\" }\n $u = $b[1]\n file { \"/file_${u}\":\n ensure => present\n }" - getResource (RIdentifier "file" "/file_3") c >>= getAttribute "ensure" >>= \a -> a `shouldBe` "present" diff --git a/tests/Function/JoinKeysToValuesSpec.hs b/tests/Function/JoinKeysToValuesSpec.hs deleted file mode 100644 --- a/tests/Function/JoinKeysToValuesSpec.hs +++ /dev/null @@ -1,26 +0,0 @@ -{-# LANGUAGE OverloadedLists #-} -module Function.JoinKeysToValuesSpec (spec) where - -import Test.Hspec - -import qualified Data.Foldable as F -import Data.Monoid - -import Puppet.Interpreter - -import Helpers - -spec :: Spec -spec = withStdlibFunction "join_keys_to_values" $ \jkvFunc -> it "Should work as expected" $ do - let eval h s = case dummyEval (jkvFunc [PHash h, PString s]) of - Left rr -> Left (spretty (getError rr)) - Right (PArray vals) -> Right (F.toList vals) - Right v -> Left ("Expected an array, not: " <> spretty v) - eval [] "" `shouldBe` Right [] - eval [] ":" `shouldBe` Right [] - eval [("key","value")] "" `shouldBe` Right ["keyvalue"] - eval [("key","value")] ":" `shouldBe` Right ["key:value"] - eval [("key",PUndef)] ":" `shouldBe` Right ["key:"] - case eval [("key1","value1"),("key2","value2")] ":" of - Left rr -> fail rr - Right lst -> lst `shouldMatchList` ["key1:value1", "key2:value2"] diff --git a/tests/Function/LookupSpec.hs b/tests/Function/LookupSpec.hs deleted file mode 100644 --- a/tests/Function/LookupSpec.hs +++ /dev/null @@ -1,29 +0,0 @@ -module Function.LookupSpec (spec, main) where - -import Helpers - -main :: IO () -main = hspec spec - -fname = "lookup" -expectedErrMsg = "Wrong set of arguments" -expectedValue = "pure" - -checkSuccess :: [Expression] -> Text -> Expectation -checkSuccess = checkExprsSuccess fname - -checkError :: [Expression] -> String -> Expectation -checkError = checkExprsError fname - -boolDatatype = Terminal (UDataType UDTBoolean) -stringDatatype = Terminal (UDataType (UDTString Nothing Nothing)) - -spec :: Spec -spec = do - it "should fail with no argument" (checkError [] expectedErrMsg) - it "should succeed with one argument" (checkSuccess ["hostname"] expectedValue) - it "should succeed with 4 arguments" (checkSuccess ["hostname", stringDatatype, "unique", "default"] expectedValue) - it "should fail with an unknown merge strategy" (checkError ["hostname", stringDatatype, "joe", "default"] "Unknown merge strategy") - it "should succeed with two arguments, the second on being a datatype" (checkSuccess ["hostname", stringDatatype] expectedValue) - it "should fail when the type mismatched" (checkError ["hostname", boolDatatype] "Datatype mismatched") - it "should fail with two arguments both strings" (checkError ["hostname", "default"] expectedErrMsg) diff --git a/tests/Function/MergeSpec.hs b/tests/Function/MergeSpec.hs deleted file mode 100644 --- a/tests/Function/MergeSpec.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-# LANGUAGE OverloadedLists #-} -module Function.MergeSpec (spec, main) where - - -import Helpers - -import qualified Data.HashMap.Strict as HM - - -main :: IO () -main = hspec spec - -evalArgs :: InterpreterMonad PValue -> Either PrettyError (HM.HashMap Text PValue) -evalArgs = dummyEval - >=> \pv -> case pv of - PHash s -> return s - _ -> Left ("Expected a string, not " <> PrettyError (pretty pv)) - -spec :: Spec -spec = withStdlibFunction "merge" $ \mergeFunc -> do - let evalArgs' = evalArgs . mergeFunc - let check args res = case evalArgs' (map PHash args) of - Left rr -> expectationFailure (show rr) - Right res' -> res' `shouldBe` res - checkError args ins = case evalArgs' args of - Left rr -> show rr `shouldContain` ins - Right r -> expectationFailure ("Should have errored, received this instead: " <> show r) - it "should error with invalid arguments" $ do - checkError [] "Expects at least two hashes" - checkError [PNumber 1] "Expects at least two hashes" - checkError [PBoolean True] "Expects at least two hashes" - checkError ["foo"] "Expects at least two hashes" - it "should handle empty hashes" $ do - check [[],[]] [] - check [[],[],[]] [] - it "should merge hashes" $ do - check [ [("key", "value")], [] ] [("key","value")] - check [ [], [("key", "value")] ] [("key","value")] - check [ [("key1", "value1")], [("key2", "value2")], [("key3", "value3")] ] [("key1", "value1"), ("key2", "value2"), ("key3", "value3")] - check [ [("key", "value1")], [("key", "value2")] ] [("key","value2")] diff --git a/tests/Function/PrefixSpec.hs b/tests/Function/PrefixSpec.hs deleted file mode 100644 --- a/tests/Function/PrefixSpec.hs +++ /dev/null @@ -1,39 +0,0 @@ -{-# LANGUAGE OverloadedLists #-} -module Function.PrefixSpec (spec, main) where - -import qualified Data.Text as T - -import Helpers - -main :: IO () -main = hspec spec - -fname :: Text -fname = "prefix" - -spec :: Spec -spec = withStdlibFunction fname $ \tester -> do - let checkError input expectederror = - case dummyEval (tester input) of - Left rr -> show (getError rr) `shouldStartWith` (T.unpack fname ++ ": " ++ expectederror) - Right _ -> expectationFailure "should have failed" - checkSuccess input expected = - case dummyEval (tester input) of - Left rr -> expectationFailure (show rr) - Right r -> r `shouldBe` expected - it "should fail with no argument" (checkError [] "expects two arguments") - it "should fail if the first argument isn't an array or hash" (checkError ["lol"] "expects the first argument to be an array or a hash") - it "should fail if the second argument isn't a string" $ do - checkError [PArray [], PNumber 1] "expects the second argument to be a string" - checkError [PArray [], PArray []] "expects the second argument to be a string" - it "should work with arrays" $ do - checkSuccess [ PArray []] (PArray []) - checkSuccess [ PArray [], ""] (PArray []) - checkSuccess [ PArray ["one"], "pre" ] (PArray ["preone"]) - checkSuccess [ PArray ["one","two","three"], "pre" ] (PArray ["preone","pretwo","prethree"]) - it "should work with hashes" $ do - checkSuccess [(PHash mempty)] (PHash mempty) - checkSuccess [(PHash mempty), ""] (PHash mempty) - checkSuccess [(PHash [("one", PNumber 5)] ), "pre" ] (PHash [("preone", PNumber 5)]) - checkSuccess [(PHash [("one", PNumber 5), ("two", "lol"), ("three", PNumber 7)]), "pre" ] (PHash [("preone", PNumber 5), ("pretwo", "lol"), ("prethree", PNumber 7)]) - diff --git a/tests/Function/ShellquoteSpec.hs b/tests/Function/ShellquoteSpec.hs deleted file mode 100644 --- a/tests/Function/ShellquoteSpec.hs +++ /dev/null @@ -1,41 +0,0 @@ -{-# LANGUAGE OverloadedLists #-} -module Function.ShellquoteSpec (spec, main) where - -import Helpers - -main :: IO () -main = hspec spec - -check :: [Expression] -> Text -> Expectation -check = checkExprsSuccess "shellquote" - -spec :: Spec -spec = do - it "should handle no arguments" (check [] "") - it "should handle array arguments" $ - check ["foo", ["bar@example.com", "localhost:/dev/null"], "xyzzy+-4711,23"] - "foo bar@example.com localhost:/dev/null xyzzy+-4711,23" - it "should quote unsafe characters" $ - check ["/etc/passwd ", "(ls)", "*", "[?]", "'&'"] - "\"/etc/passwd \" \"(ls)\" \"*\" \"[?]\" \"'&'\"" - it "should deal with double quotes" $ - check ["\"foo\"bar\""] - "'\"foo\"bar\"'" - it "should cope with dollar signs" $ - check ["$PATH", "foo$bar", "\"x$\""] - "'$PATH' 'foo$bar' '\"x$\"'" - it "should deal with apostrophes (single quotes)" $ - check ["'foo'bar'", "`$'EDITOR'`"] - "\"'foo'bar'\" \"\\`\\$'EDITOR'\\`\"" - it "should cope with grave accents (backquotes)" $ - check ["`echo *`", "`ls \"$MAILPATH\"`"] - "'`echo *`' '`ls \"$MAILPATH\"`'" - it "should deal with both single and double quotes" $ - check ["'foo\"bar\"xyzzy'", "\"foo'bar'xyzzy\""] - "\"'foo\\\"bar\\\"xyzzy'\" \"\\\"foo'bar'xyzzy\\\"\"" - it "should handle multiple quotes *and* dollars and backquotes" $ - check ["'foo\"$x`bar`\"xyzzy'"] - "\"'foo\\\"\\$x\\`bar\\`\\\"xyzzy'\"" - it "should handle linefeeds" $ - check ["foo \n bar"] - "\"foo \n bar\"" diff --git a/tests/Function/SizeSpec.hs b/tests/Function/SizeSpec.hs deleted file mode 100644 --- a/tests/Function/SizeSpec.hs +++ /dev/null @@ -1,42 +0,0 @@ -{-# LANGUAGE OverloadedLists #-} -module Function.SizeSpec (spec, main) where - -import Helpers - -main :: IO () -main = hspec spec - -evalArgs :: InterpreterMonad PValue -> Either PrettyError Scientific -evalArgs = dummyEval - >=> \pv -> case pv of - PNumber s -> return s - _ -> Left ("Expected a string, not " <> PrettyError (pretty pv)) - -spec :: Spec -spec = withStdlibFunction "size" $ \sizeFunc -> do - let evalArgs' = evalArgs . sizeFunc - let check args res = case evalArgs' args of - Left rr -> expectationFailure (show rr) - Right res' -> res' `shouldBe` res - checkError args ins = case evalArgs' args of - Left rr -> show rr `shouldContain` ins - Right r -> expectationFailure ("Should have errored, received this instead: " <> show r) - it "should error with no arguments" (checkError [] "a single argument") - it "should error with numerical arguments" (checkError [PNumber 1] "size(): Expects ") - it "should error with boolean arguments" (checkError [PBoolean True] "size(): Expects ") - -- Not conformant: - -- it "should error with numerical arguments" (checkError ["1"] "size(): Expects ") - it "should handle arrays" $ do - check [PArray []] 0 - check [PArray ["a"]] 1 - check [PArray ["one","two","three"]] 3 - check [PArray ["one","two","three","four"]] 4 - it "should handle hashes" $ do - check [PHash []] 0 - check [PHash [("1","2")]] 1 - check [PHash [("1","2"),("3","4")]] 2 - it "should handle strings" $ do - check [""] 0 - check ["a"] 1 - check ["ab"] 2 - check ["abcd"] 4 diff --git a/tests/Function/SprintfSpec.hs b/tests/Function/SprintfSpec.hs deleted file mode 100644 --- a/tests/Function/SprintfSpec.hs +++ /dev/null @@ -1,41 +0,0 @@ -module Function.SprintfSpec (spec, main) where - -import Helpers - -main :: IO () -main = hspec spec - -fname = "sprintf" - -checkSuccess :: [Expression] -> Text -> Expectation -checkSuccess = checkExprsSuccess fname - -checkError :: [Expression] -> String -> Expectation -checkError = checkExprsError fname - -spec :: Spec -spec = do - it "should fail with no argument" (checkError [] "Expects a string as its first argument") - it "should succeed with one argument" (checkSuccess ["hello"] "hello") -- puppet sprintf accepts one arg - it "should work with multiple arguments" (checkSuccess ["hello %s %s", "world", "!"] "hello world !") - it "should work with one string argument" (checkSuccess ["hello %s", "world"] "hello world" ) - it "should work with one int argument" (checkSuccess ["hello %d", 10] "hello 10" ) - it "should fail if arg is not provided" (checkError ["hello %s"] "not enough arguments") - it "should fail when a wrong format instruction is used" (checkError ["hello %d", "world"] "Don't know how to convert this to a number" ) - it "should fail when a wrong format instruction is used" (checkError ["hello %f", "world"] "Don't know how to convert this to a number" ) - it "should work with one int argument" (checkSuccess ["hello %f", 1.0] "hello 1.0" ) - it "should work with one int argument" (checkSuccess ["hello %.1f", 1.23] "hello 1.2" ) - it "should pad with zeroes" (checkSuccess ["hello %03d", 10] "hello 010") - it "should pad with spaces" (checkSuccess ["hello % 3d", 10] "hello 10") - it "should format integers" (checkSuccess ["%+05d", 23] "+0023") - it "should format floats" (checkSuccess ["%+.2f", 2.7182818284590451] "+2.72") - it "should format large floats" (pendingWith "Minor formatting difference" >> checkSuccess ["%+.2e", 27182818284590451] "+2.72e+16") - it "should work with " (checkSuccess ["%5d" , 5] " 5") - it "should work with 0" (checkSuccess ["%05d" , 5] "00005") - it "should work with - " (checkSuccess ["%-5d" , 5] "5 ") - it "should work with -0" (checkSuccess ["%-05d" , 5] "5 ") - it "should work with + " (checkSuccess ["%+5d" , 5] " +5") - it "should work with + 0" (checkSuccess ["%+05d" , 5] "+0005") - it "should work with +- " (checkSuccess ["%+-5d" , 5] "+5 ") - it "should work with +-0" (checkSuccess ["%+-05d", 5] "+5 ") - it "should perform more complex formatting" (pendingWith "# is not yet supported" >> checkSuccess [ "<%.8s:%#5o %#8X (%-8s)>", "overlongstring", 23, 48879, "foo" ] "") diff --git a/tests/Function/SuffixSpec.hs b/tests/Function/SuffixSpec.hs deleted file mode 100644 --- a/tests/Function/SuffixSpec.hs +++ /dev/null @@ -1,39 +0,0 @@ -{-# LANGUAGE OverloadedLists #-} -module Function.SuffixSpec (spec, main) where - -import qualified Data.Text as T - -import Helpers - -main :: IO () -main = hspec spec - -fname :: Text -fname = "suffix" - -spec :: Spec -spec = withStdlibFunction fname $ \tester -> do - let checkError input expectederror = - case dummyEval (tester input) of - Left rr -> show (getError rr) `shouldStartWith` (T.unpack fname ++ ": " ++ expectederror) - Right _ -> expectationFailure "should have failed" - checkSuccess input expected = - case dummyEval (tester input) of - Left rr -> expectationFailure (show rr) - Right r -> r `shouldBe` expected - it "should fail with no argument" (checkError [] "expects two arguments") - it "should fail if the first argument isn't an array or hash" (checkError ["lol"] "expects the first argument to be an array or a hash") - it "should fail if the second argument isn't a string" $ do - checkError [PArray [], PNumber 1] "expects the second argument to be a string" - checkError [PArray [], PArray []] "expects the second argument to be a string" - it "should work with arrays" $ do - checkSuccess [ PArray []] (PArray []) - checkSuccess [ PArray [], ""] (PArray []) - checkSuccess [ PArray ["one"], "post" ] (PArray ["onepost"]) - checkSuccess [ PArray ["one","two","three"], "post" ] (PArray ["onepost","twopost","threepost"]) - it "should work with hashes" $ do - checkSuccess [(PHash mempty)] (PHash mempty) - checkSuccess [(PHash mempty), ""] (PHash mempty) - checkSuccess [(PHash [("one", PNumber 5)] ), "post" ] (PHash [("onepost", PNumber 5)]) - checkSuccess [(PHash [("one", PNumber 5), ("two", "lol"), ("three", PNumber 7)]), "post" ] (PHash [("onepost", PNumber 5), ("twopost", "lol"), ("threepost", PNumber 7)]) - diff --git a/tests/Helpers.hs b/tests/Helpers.hs --- a/tests/Helpers.hs +++ b/tests/Helpers.hs @@ -1,22 +1,21 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedLists #-} + module Helpers ( module Exports - , compileCatalog , checkExprsSuccess , checkExprsError - , getCatalog + , pureCatalog , getResource , getAttribute - , spretty + , renderToString , withStdlibFunction ) where -import XPrelude as Exports +import XPrelude as Exports import Control.Monad as Exports (fail) import qualified Data.HashMap.Strict as HM import qualified Data.Maybe.Strict as S -import Data.Text as Text import qualified Data.Vector as Vector import Test.Hspec as Exports @@ -24,31 +23,27 @@ import Puppet.Parser as Exports import Puppet.Runner as Exports hiding (getCatalog) - -compileCatalog :: MonadError String m => Text -> m (FinalCatalog, EdgeMap, FinalCatalog, [Resource], InterpreterState) -compileCatalog input = do - statements <- either (throwError . show) return (runPuppetParser mempty input) - let nodename = "node.fqdn" - sttmap = - [((TopNode, nodename), NodeDeclaration (NodeDecl (NodeName nodename) statements S.Nothing (initialPPos "dummy"))) - ] - (res, finalState, _) = pureEval dummyFacts sttmap (computeCatalog nodename) - (catalog, em, exported, defResources) <- either (throwError . show) return res - return (catalog, em, exported, defResources, finalState) - -getCatalog :: MonadError String m => Text -> m FinalCatalog -getCatalog = fmap (view _1) . compileCatalog - -spretty :: Pretty a => a -> String -spretty = flip displayS "" . renderCompact . pretty +-- | Given a raw text input to be parsed, compute the manifest in a pure setting. +-- The 'InterpreterWriter' might be useful for debugging purpose. +pureCatalog :: Text -> Either String (FinalCatalog, InterpreterWriter) +pureCatalog = runExcept . fmap (\s -> (s^._1,s^._6)) . compileCatalog + where + compileCatalog :: Text -> Except String (FinalCatalog, EdgeMap, FinalCatalog, [Resource], InterpreterState, InterpreterWriter) + compileCatalog input = do + statements <- either (throwError . show) pure (runPuppetParser mempty input) + let nodename = "pure" + top_node = [((TopNode, nodename), NodeDeclaration (NodeDecl (NodeName nodename) statements S.Nothing (initialPPos mempty)))] + (res, finalState, logs) = pureEval top_node (computeCatalog nodename) + (catalog, em, exported, defResources) <- either (throwError . show) pure res + pure (catalog, em, exported, defResources, finalState, logs) getResource :: (Monad m) => RIdentifier -> FinalCatalog -> m Resource -getResource resid catalog = maybe (fail ("Unknown resource " ++ spretty resid)) return (HM.lookup resid catalog) +getResource resid catalog = maybe (fail ("Unknown resource " <> renderToString resid)) pure (HM.lookup resid catalog) getAttribute :: Monad m => Text -> Resource -> m PValue getAttribute att res = case res ^? rattributes . ix att of - Nothing -> fail ("Unknown attribute: " ++ Text.unpack att) + Nothing -> fail ("Unknown attribute: " <> toS att) Just x -> return x withStdlibFunction :: Text -> ( ([PValue] -> InterpreterMonad PValue) -> Spec ) -> Spec @@ -71,7 +66,9 @@ evalExprs :: Text -> [Expression] -> Either PrettyError Text evalExprs fname = - dummyEval . resolveValue . UFunctionCall fname . Vector.fromList - >=> \pv -> case pv of - PString s -> return s - _ -> Left ("Expected a string, not " <> PrettyError (pretty pv)) + dummyEval . resolveValue . UFunctionCall fname . Vector.fromList >=> \case + PString s -> return s + v -> Left ("Expected a string, not " <> PrettyError (pretty v)) + +renderToString :: Pretty a => a -> String +renderToString d = displayS (renderCompact (pretty d)) "" diff --git a/tests/HieraSpec.hs b/tests/HieraSpec.hs --- a/tests/HieraSpec.hs +++ b/tests/HieraSpec.hs @@ -31,13 +31,16 @@ spec = do runIO $ Log.updateGlobalLogger loggerName (Log.setLevel Log.WARNING) - q3 <- runIO $ startHiera config_v3 - q5 <- runIO $ startHiera config_v5 + q3 <- runIO $ startHiera "test" config_v3 + q5 <- runIO $ startHiera "test" config_v5 describe "Hiera" $ do describe "v5 lookup hierarchy" $ do it "should override some values" $ do q5 vars "http_port" QFirst >>= checkOutput (Just (PNumber 9090)) q5 vars "global" QFirst >>= checkOutput (Just "glob") + describe "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 diff --git a/tests/Interpreter/ClassSpec.hs b/tests/Interpreter/ClassSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Interpreter/ClassSpec.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE OverloadedLists #-} + +module Interpreter.ClassSpec (spec) where + +import Test.Hspec + +import Control.Lens +import qualified Data.Text as Text + +import Helpers + +spec = do + describe "Class" $ do + it "should work when using several include statements" $ + pureCatalog (Text.unlines ["class foo {}", "include foo", "include foo"]) `shouldSatisfy` (has _Right) + it "should work when using class before include" $ + pureCatalog (Text.unlines ["class foo {}", "class { 'foo': }", "include foo"]) `shouldSatisfy` (has _Right) + it "should fail when using include before class" $ + pureCatalog (Text.unlines ["class foo {}", "include foo", "class { 'foo': }" ]) `shouldSatisfy` (has _Left) + it "should fail if the class is not defined" $ + pureCatalog (Text.unlines ["include foo"]) `shouldSatisfy` (has _Left) + describe "Parameters" $ do + it "should fail when declaring a class with an unknown params" $ + pureCatalog (Text.unlines ["class foo ($param0){}", "class {'foo': param1 => 1 }"]) `shouldSatisfy` (has _Left) + it "should succeed when declaring a class with a correct param" $ + pureCatalog (Text.unlines ["class foo ($param0){}", "class {'foo': param0 => 1 }"]) `shouldSatisfy` (has _Right) + it "should fail when the type of the attribute is wrong" $ do + pureCatalog (Text.unlines ["class foo (String $param0){}", "class {'foo': param0 => 1 }"]) `shouldSatisfy` (has _Left) + it "should fail when declaring with a missing param" $ do + pureCatalog (Text.unlines ["class foo ($param0){}", "class {'foo': }"]) `shouldSatisfy` (has _Left) + it "should succeed with missing param and an optional type" $ do + pureCatalog (Text.unlines ["class foo (Optional[String] $param0){}", "class {'foo': }"]) `shouldSatisfy` (has _Right) diff --git a/tests/Interpreter/CollectorSpec.hs b/tests/Interpreter/CollectorSpec.hs --- a/tests/Interpreter/CollectorSpec.hs +++ b/tests/Interpreter/CollectorSpec.hs @@ -12,19 +12,23 @@ shouldNotify :: [Text] -> [PValue] -> Expectation shouldNotify content expectedMessages = do - catalog <- case runExcept (getCatalog (Text.unlines content)) of + catalog <- case pureCatalog (Text.unlines content) of Left rr -> fail rr - Right x -> return x + Right (x,_) -> pure x let messages = itoList catalog ^.. folded . filtered (\rp -> rp ^. _1 . itype == "notify") . _2 . rattributes . ix "message" messages `shouldMatchList` expectedMessages shouldFail :: [Text] -> Expectation -shouldFail content = let catalog :: Either String FinalCatalog - catalog = runExcept (getCatalog (Text.unlines content)) +shouldFail content = let catalog = pureCatalog (Text.unlines content) in catalog `shouldSatisfy` has _Left -spec :: Spec -spec = do +spec = + describe "Collectors" $ do + spec0 + spec1 + +spec0 :: Spec +spec0 = do it "matches everything when no query given" $ [ "@notify { 'testing': message => 'the message' }" , "@notify { 'other': message => 'the other message' }" @@ -148,3 +152,31 @@ , "Notify <| |> { message => 'overridden1' }" , "Notify <| |> { message => 'overridden2' }" ] `shouldNotify` ["overridden2"] + + +spec1 :: Spec +spec1 = do + let computeWith = pureCatalog . arrowOperationInput + describe "Resource Collector" $ + it "should append the new 'uid' attribute in the user resource" $ + getResAttr (computeWith "=>") ^. at "uid" `shouldBe` Just (PNumber 1000) + describe "AppendArrow in AttributeDecl" $ + it "should add 'docker' to the 'groups' attribute of the user resource" $ do + getResAttr (computeWith "+>") ^. at "groups" `shouldBe` Just (PArray $ ["ci", "docker"]) + describe "AssignArrow in AttributeDecl" $ + it "should override the 'groups' attributes from the user resource" $ + getResAttr (computeWith "=>") ^. at "groups" `shouldBe` Just (PArray $ ["docker"]) + where + getResAttr :: Either String (FinalCatalog, InterpreterWriter) -> Container PValue + getResAttr s = s ^. _Right . _1 . at (RIdentifier "user" "jenkins")._Just.rattributes + + arrowOperationInput :: Text -> Text + arrowOperationInput arr = + Text.unlines [ "user { 'jenkins':" + , " groups => 'ci'" + , "}" + , "User <| title == 'jenkins' |> {" + , "groups " <> arr <> " 'docker'," + , "uid => 1000}" + , "}" + ] diff --git a/tests/Interpreter/EvalSpec.hs b/tests/Interpreter/EvalSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Interpreter/EvalSpec.hs @@ -0,0 +1,52 @@ +module Interpreter.EvalSpec (spec) where + + +import Test.Hspec +import Text.Megaparsec (errorBundlePretty, eof, parse) + +import Puppet.Interpreter +import Puppet.Parser.Internal +import Puppet.Runner +import XPrelude + +evaluations = [ "4 + 2 == 6" + , "[1,2][1] == 2" + , "[1,[1,2]][1][0] == 1" + , "[1,2,3] + [4,5,6] == [1,2,3,4,5,6]" + , "{a => 1} + {b => 2} == {a=>1, b=>2 }" + , "[1,2,3] << 10 == [1,2,3,10]" + , "[1,2,3] << [4,5] == [1,2,3,[4,5]]" + , "4 / 2.0 == 2" + , "$kernel == 'Linux'" + , "$facts['os']['architecture'] == 'amd64'" + -- string interpolation + , "\"$kernel\" == 'Linux'" + , "\"${kernel} box\" == 'Linux box'" + , "\"${os['architecture']}\" == 'amd64'" + , "\"${os['release']['major']}\" == '7'" + , "\"${facts['kernel']}\" == 'Linux'" + , "\"${facts['os']['architecture']}\" == 'amd64'" + -- + , "$settings::confdir == '/etc/puppet'" + , "regsubst('127', '([0-9]+)', '<\\1>', 'G') == '<127>'" + , "regsubst(['1','2','3'], '([0-9]+)', '<\\1>', 'G') == ['<1>','<2>','<3>']" + , "versioncmp('2.1','2.2') == -1" + , "inline_template('a','b') == 'ab'" + ] + +testEvaluation t = + let item = it ("should evaluate " <> t) in + case check (toS t) of + Left ctx -> context ctx $ item False + Right b -> item b + +check :: Text -> Either String Bool +check t = + case parse (expression <* eof) "dummy" t of + Left err -> Left $ "Parsing error. Are you sure the input is correct ?\n" <> errorBundlePretty err + Right e -> case dummyEval (resolveExpression e) of + Right (PBoolean True) -> Right True + _ -> Right False + +spec = do + describe "Evaluation of expressions" $ mapM_ testEvaluation evaluations diff --git a/tests/Interpreter/Function/AssertPrivateSpec.hs b/tests/Interpreter/Function/AssertPrivateSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Interpreter/Function/AssertPrivateSpec.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE OverloadedLists #-} +module Interpreter.Function.AssertPrivateSpec where + +import Helpers + +main :: IO () +main = hspec spec + +evalWithScope :: ([PValue] -> InterpreterMonad PValue) + -> Text -- ^ caller scope + -> Text -- ^ module scope + -> [Expression] -- ^ function args + -> Either String PValue +evalWithScope apFunc callerScope moduleScope = + (_Left %~ show) . view _1 . ctxEval . (mapM resolveExpression >=> apFunc) + where + ctxEval = pureEval' mempty state0 Nothing + state0 = dummyInitialState & curScope .~ [ContClass moduleScope, ContClass callerScope] + +spec :: Spec +spec = withStdlibFunction "assert_private" $ \apFunc -> do + let errorWith a b = case a of + Right x -> fail ("Should have failed, got this instead: " ++ show x) + Left rr -> rr `shouldContain` b + it "should work when called from inside module" (evalWithScope apFunc "bar" "bar" [] `shouldBe` Right PUndef) + it "should fail with the default message" (evalWithScope apFunc "bar" "baz" [] `errorWith` "is private") + it "should fail with an explicit failure message" (evalWithScope apFunc "bar" "baz" ["lalala"] `errorWith` "lalala") diff --git a/tests/Interpreter/Function/DeleteAtSpec.hs b/tests/Interpreter/Function/DeleteAtSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Interpreter/Function/DeleteAtSpec.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE OverloadedLists #-} + +module Interpreter.Function.DeleteAtSpec (spec, main) where + +import Helpers + +main :: IO () +main = hspec spec + +spec :: Spec +spec = withStdlibFunction "delete_at" $ \deleteAtFunc -> do + let evalArgs' = dummyEval . deleteAtFunc + narray = PArray . fmap PNumber + check a b res = case evalArgs' [narray a, PNumber b] of + Left rr -> expectationFailure (show rr) + Right res' -> res' `shouldBe` narray res + checkError args ins = case evalArgs' args of + Left rr -> show rr `shouldContain` ins + Right r -> expectationFailure ("Should have errored, received this instead: " <> show r) + it "should error with invalid arguments" $ do + checkError [] "expects 2 arguments" + checkError [PNumber 1] "expects 2 arguments" + checkError ["foo", "bar"] "expects its first argument to be an array" + checkError [ narray [0,1,2], PNumber 3 ] "Out of bounds access" + it "should work otherwise" $ do + check [0,1,2] 1 [0,2] + it "should work for negative positions" $ do + pending + check [0,1,2] (-1) [0,1] + check [0,1,2] (-4) [0,1,2] diff --git a/tests/Interpreter/Function/EachSpec.hs b/tests/Interpreter/Function/EachSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Interpreter/Function/EachSpec.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE OverloadedLists #-} +module Interpreter.Function.EachSpec (spec, main) where + +import Helpers + +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + let getCatalog x = case pureCatalog x of + Left rr -> fail rr + Right (y,_) -> pure y + describe "should be callable as" $ do + let checkEnsure f v c = + getResource (RIdentifier "file" f) c >>= getAttribute "ensure" >>= \a -> a `shouldBe` v + checks :: [(Text, PValue)] -> FinalCatalog -> IO () + checks lst c = mapM_ (\(f,v) -> checkEnsure f v c) lst + it "each on an array selecting each value" $ + getCatalog "$a = [1,2,3]\n $a.each |$v| {\n file { \"/file_$v\": ensure => present } \n } " + >>= checks [ ("/file_1", "present") + , ("/file_2", "present") + , ("/file_3", "present") + ] + it "each on an array selecting each value - function call style" $ + getCatalog "$a = [1,2,3]\n each ($a) |$index, $v| {\n file { \"/file_$v\": ensure => present }\n }" + >>= checks [ ("/file_1", "present") + , ("/file_2", "present") + , ("/file_3", "present") + ] + it "each on an array with index" $ + getCatalog "$a = [present, absent, present]\n $a.each |$k,$v| {\n file { \"/file_$k\": ensure => $v }\n }" + >>= checks [ ("/file_0", "present") + , ("/file_1", "absent") + , ("/file_2", "present") + ] + it "each on a hash selecting entries" $ + getCatalog "$a = {'a'=>'present','b'=>'absent','c'=>'present'}\n $a.each |$e| {\n $num = $e[0]\n file { \"/file_${num}\": ensure => $e[1] }\n }" + >>= checks [ ("/file_a", "present") + , ("/file_b", "absent") + , ("/file_c", "present") + ] + it "each on a hash selecting key and value" $ + getCatalog "$a = {'a'=>present,'b'=>absent,'c'=>present}\n $a.each |$k, $v| {\n file { \"/file_$k\": ensure => $v }\n }" + >>= checks [ ("/file_a", "present") + , ("/file_b", "absent") + , ("/file_c", "present") + ] + it "each on a hash selecting key and value (using captures-last parameter)" $ do + pending + getCatalog "$a = {'a'=>present,'b'=>absent,'c'=>present}\n $a.each |*$kv| {\n file { \"/file_${kv[0]}\": ensure => $kv[1] }\n }" + >>= checks [ ("/file_a", "present") + , ("/file_b", "absent") + , ("/file_c", "present") + ] + describe "should produce receiver" $ + it "each checking produced value using single expression" $ do + pending + c <- getCatalog "$a = [1, 3, 2]\n $b = $a.each |$x| { \"unwanted\" }\n $u = $b[1]\n file { \"/file_${u}\":\n ensure => present\n }" + getResource (RIdentifier "file" "/file_3") c >>= getAttribute "ensure" >>= \a -> a `shouldBe` "present" diff --git a/tests/Interpreter/Function/JoinKeysToValuesSpec.hs b/tests/Interpreter/Function/JoinKeysToValuesSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Interpreter/Function/JoinKeysToValuesSpec.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE OverloadedLists #-} +module Interpreter.Function.JoinKeysToValuesSpec (spec) where + +import Test.Hspec + +import qualified Data.Foldable as F +import Data.Monoid + +import Puppet.Interpreter + +import Helpers + +spec :: Spec +spec = withStdlibFunction "join_keys_to_values" $ \jkvFunc -> it "Should work as expected" $ do + let eval h s = case dummyEval (jkvFunc [PHash h, PString s]) of + Left rr -> Left (renderToString (getError rr)) + Right (PArray vals) -> Right (F.toList vals) + Right v -> Left ("Expected an array, not: " <> renderToString v) + eval [] "" `shouldBe` Right [] + eval [] ":" `shouldBe` Right [] + eval [("key","value")] "" `shouldBe` Right ["keyvalue"] + eval [("key","value")] ":" `shouldBe` Right ["key:value"] + eval [("key",PUndef)] ":" `shouldBe` Right ["key:"] + case eval [("key1","value1"),("key2","value2")] ":" of + Left rr -> fail rr + Right lst -> lst `shouldMatchList` ["key1:value1", "key2:value2"] diff --git a/tests/Interpreter/Function/LookupSpec.hs b/tests/Interpreter/Function/LookupSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Interpreter/Function/LookupSpec.hs @@ -0,0 +1,32 @@ +module Interpreter.Function.LookupSpec (spec, main) where + +import Helpers + +main :: IO () +main = hspec spec + +fname = "lookup" +expectedErrMsg = "Wrong set of arguments" + +-- See dummyFacts defined in Pure.hs +testkey = "foo" +expectedValue = "dummy" + +checkSuccess :: [Expression] -> Text -> Expectation +checkSuccess = checkExprsSuccess fname + +checkError :: [Expression] -> String -> Expectation +checkError = checkExprsError fname + +boolDatatype = Terminal (UDataType UDTBoolean) +stringDatatype = Terminal (UDataType (UDTString Nothing Nothing)) + +spec :: Spec +spec = do + it "should fail with no argument" (checkError [] expectedErrMsg) + it "should succeed with one argument" (checkSuccess [testkey] expectedValue) + it "should succeed with 4 arguments" (checkSuccess [testkey, stringDatatype, "unique", "default"] expectedValue) + it "should fail with an unknown merge strategy" (checkError [testkey, stringDatatype, "joe", "default"] "Unknown merge strategy") + it "should succeed with two arguments, the second one being a datatype" (checkSuccess [testkey, stringDatatype] expectedValue) + it "should fail when the type mismatched" (checkError [testkey, boolDatatype] "Datatype mismatched") + it "should fail with two arguments both strings" (checkError [testkey, "default"] expectedErrMsg) diff --git a/tests/Interpreter/Function/MergeSpec.hs b/tests/Interpreter/Function/MergeSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Interpreter/Function/MergeSpec.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE OverloadedLists #-} +module Interpreter.Function.MergeSpec (spec, main) where + + +import Helpers + +import qualified Data.HashMap.Strict as HM + + +main :: IO () +main = hspec spec + +evalArgs :: InterpreterMonad PValue -> Either PrettyError (HM.HashMap Text PValue) +evalArgs = dummyEval + >=> \pv -> case pv of + PHash s -> return s + _ -> Left ("Expected a string, not " <> PrettyError (pretty pv)) + +spec :: Spec +spec = withStdlibFunction "merge" $ \mergeFunc -> do + let evalArgs' = evalArgs . mergeFunc + let check args res = case evalArgs' (map PHash args) of + Left rr -> expectationFailure (show rr) + Right res' -> res' `shouldBe` res + checkError args ins = case evalArgs' args of + Left rr -> show rr `shouldContain` ins + Right r -> expectationFailure ("Should have errored, received this instead: " <> show r) + it "should error with invalid arguments" $ do + checkError [] "Expects at least two hashes" + checkError [PNumber 1] "Expects at least two hashes" + checkError [PBoolean True] "Expects at least two hashes" + checkError ["foo"] "Expects at least two hashes" + it "should handle empty hashes" $ do + check [[],[]] [] + check [[],[],[]] [] + it "should merge hashes" $ do + check [ [("key", "value")], [] ] [("key","value")] + check [ [], [("key", "value")] ] [("key","value")] + check [ [("key1", "value1")], [("key2", "value2")], [("key3", "value3")] ] [("key1", "value1"), ("key2", "value2"), ("key3", "value3")] + check [ [("key", "value1")], [("key", "value2")] ] [("key","value2")] diff --git a/tests/Interpreter/Function/PrefixSpec.hs b/tests/Interpreter/Function/PrefixSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Interpreter/Function/PrefixSpec.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE OverloadedLists #-} +module Interpreter.Function.PrefixSpec (spec, main) where + +import qualified Data.Text as T + +import Helpers + +main :: IO () +main = hspec spec + +fname :: Text +fname = "prefix" + +spec :: Spec +spec = withStdlibFunction fname $ \tester -> do + let checkError input expectederror = + case dummyEval (tester input) of + Left rr -> show (getError rr) `shouldStartWith` (T.unpack fname ++ ": " ++ expectederror) + Right _ -> expectationFailure "should have failed" + checkSuccess input expected = + case dummyEval (tester input) of + Left rr -> expectationFailure (show rr) + Right r -> r `shouldBe` expected + it "should fail with no argument" (checkError [] "expects two arguments") + it "should fail if the first argument isn't an array or hash" (checkError ["lol"] "expects the first argument to be an array or a hash") + it "should fail if the second argument isn't a string" $ do + checkError [PArray [], PNumber 1] "expects the second argument to be a string" + checkError [PArray [], PArray []] "expects the second argument to be a string" + it "should work with arrays" $ do + checkSuccess [ PArray []] (PArray []) + checkSuccess [ PArray [], ""] (PArray []) + checkSuccess [ PArray ["one"], "pre" ] (PArray ["preone"]) + checkSuccess [ PArray ["one","two","three"], "pre" ] (PArray ["preone","pretwo","prethree"]) + it "should work with hashes" $ do + checkSuccess [(PHash mempty)] (PHash mempty) + checkSuccess [(PHash mempty), ""] (PHash mempty) + checkSuccess [(PHash [("one", PNumber 5)] ), "pre" ] (PHash [("preone", PNumber 5)]) + checkSuccess [(PHash [("one", PNumber 5), ("two", "lol"), ("three", PNumber 7)]), "pre" ] (PHash [("preone", PNumber 5), ("pretwo", "lol"), ("prethree", PNumber 7)]) + diff --git a/tests/Interpreter/Function/ShellquoteSpec.hs b/tests/Interpreter/Function/ShellquoteSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Interpreter/Function/ShellquoteSpec.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE OverloadedLists #-} +module Interpreter.Function.ShellquoteSpec (spec, main) where + +import Helpers + +main :: IO () +main = hspec spec + +check :: [Expression] -> Text -> Expectation +check = checkExprsSuccess "shellquote" + +spec :: Spec +spec = do + it "should handle no arguments" (check [] "") + it "should handle array arguments" $ + check ["foo", ["bar@example.com", "localhost:/dev/null"], "xyzzy+-4711,23"] + "foo bar@example.com localhost:/dev/null xyzzy+-4711,23" + it "should quote unsafe characters" $ + check ["/etc/passwd ", "(ls)", "*", "[?]", "'&'"] + "\"/etc/passwd \" \"(ls)\" \"*\" \"[?]\" \"'&'\"" + it "should deal with double quotes" $ + check ["\"foo\"bar\""] + "'\"foo\"bar\"'" + it "should cope with dollar signs" $ + check ["$PATH", "foo$bar", "\"x$\""] + "'$PATH' 'foo$bar' '\"x$\"'" + it "should deal with apostrophes (single quotes)" $ + check ["'foo'bar'", "`$'EDITOR'`"] + "\"'foo'bar'\" \"\\`\\$'EDITOR'\\`\"" + it "should cope with grave accents (backquotes)" $ + check ["`echo *`", "`ls \"$MAILPATH\"`"] + "'`echo *`' '`ls \"$MAILPATH\"`'" + it "should deal with both single and double quotes" $ + check ["'foo\"bar\"xyzzy'", "\"foo'bar'xyzzy\""] + "\"'foo\\\"bar\\\"xyzzy'\" \"\\\"foo'bar'xyzzy\\\"\"" + it "should handle multiple quotes *and* dollars and backquotes" $ + check ["'foo\"$x`bar`\"xyzzy'"] + "\"'foo\\\"\\$x\\`bar\\`\\\"xyzzy'\"" + it "should handle linefeeds" $ + check ["foo \n bar"] + "\"foo \n bar\"" diff --git a/tests/Interpreter/Function/SizeSpec.hs b/tests/Interpreter/Function/SizeSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Interpreter/Function/SizeSpec.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE OverloadedLists #-} +module Interpreter.Function.SizeSpec (spec, main) where + +import Helpers + +main :: IO () +main = hspec spec + +evalArgs :: InterpreterMonad PValue -> Either PrettyError Scientific +evalArgs = dummyEval + >=> \pv -> case pv of + PNumber s -> return s + _ -> Left ("Expected a string, not " <> PrettyError (pretty pv)) + +spec :: Spec +spec = withStdlibFunction "size" $ \sizeFunc -> do + let evalArgs' = evalArgs . sizeFunc + let check args res = case evalArgs' args of + Left rr -> expectationFailure (show rr) + Right res' -> res' `shouldBe` res + checkError args ins = case evalArgs' args of + Left rr -> show rr `shouldContain` ins + Right r -> expectationFailure ("Should have errored, received this instead: " <> show r) + it "should error with no arguments" (checkError [] "a single argument") + it "should error with numerical arguments" (checkError [PNumber 1] "size(): Expects ") + it "should error with boolean arguments" (checkError [PBoolean True] "size(): Expects ") + -- Not conformant: + -- it "should error with numerical arguments" (checkError ["1"] "size(): Expects ") + it "should handle arrays" $ do + check [PArray []] 0 + check [PArray ["a"]] 1 + check [PArray ["one","two","three"]] 3 + check [PArray ["one","two","three","four"]] 4 + it "should handle hashes" $ do + check [PHash []] 0 + check [PHash [("1","2")]] 1 + check [PHash [("1","2"),("3","4")]] 2 + it "should handle strings" $ do + check [""] 0 + check ["a"] 1 + check ["ab"] 2 + check ["abcd"] 4 diff --git a/tests/Interpreter/Function/SprintfSpec.hs b/tests/Interpreter/Function/SprintfSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Interpreter/Function/SprintfSpec.hs @@ -0,0 +1,41 @@ +module Interpreter.Function.SprintfSpec (spec, main) where + +import Helpers + +main :: IO () +main = hspec spec + +fname = "sprintf" + +checkSuccess :: [Expression] -> Text -> Expectation +checkSuccess = checkExprsSuccess fname + +checkError :: [Expression] -> String -> Expectation +checkError = checkExprsError fname + +spec :: Spec +spec = do + it "should fail with no argument" (checkError [] "Expects a string as its first argument") + it "should succeed with one argument" (checkSuccess ["hello"] "hello") -- puppet sprintf accepts one arg + it "should work with multiple arguments" (checkSuccess ["hello %s %s", "world", "!"] "hello world !") + it "should work with one string argument" (checkSuccess ["hello %s", "world"] "hello world" ) + it "should work with one int argument" (checkSuccess ["hello %d", 10] "hello 10" ) + it "should fail if arg is not provided" (checkError ["hello %s"] "not enough arguments") + it "should fail when a wrong format instruction is used" (checkError ["hello %d", "world"] "Don't know how to convert this to a number" ) + it "should fail when a wrong format instruction is used" (checkError ["hello %f", "world"] "Don't know how to convert this to a number" ) + it "should work with one int argument" (checkSuccess ["hello %f", 1.0] "hello 1.0" ) + it "should work with one int argument" (checkSuccess ["hello %.1f", 1.23] "hello 1.2" ) + it "should pad with zeroes" (checkSuccess ["hello %03d", 10] "hello 010") + it "should pad with spaces" (checkSuccess ["hello % 3d", 10] "hello 10") + it "should format integers" (checkSuccess ["%+05d", 23] "+0023") + it "should format floats" (checkSuccess ["%+.2f", 2.7182818284590451] "+2.72") + it "should format large floats" (pendingWith "Minor formatting difference" >> checkSuccess ["%+.2e", 27182818284590451] "+2.72e+16") + it "should work with " (checkSuccess ["%5d" , 5] " 5") + it "should work with 0" (checkSuccess ["%05d" , 5] "00005") + it "should work with - " (checkSuccess ["%-5d" , 5] "5 ") + it "should work with -0" (checkSuccess ["%-05d" , 5] "5 ") + it "should work with + " (checkSuccess ["%+5d" , 5] " +5") + it "should work with + 0" (checkSuccess ["%+05d" , 5] "+0005") + it "should work with +- " (checkSuccess ["%+-5d" , 5] "+5 ") + it "should work with +-0" (checkSuccess ["%+-05d", 5] "+5 ") + it "should perform more complex formatting" (pendingWith "# is not yet supported" >> checkSuccess [ "<%.8s:%#5o %#8X (%-8s)>", "overlongstring", 23, 48879, "foo" ] "") diff --git a/tests/Interpreter/Function/SuffixSpec.hs b/tests/Interpreter/Function/SuffixSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Interpreter/Function/SuffixSpec.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE OverloadedLists #-} +module Interpreter.Function.SuffixSpec (spec, main) where + +import qualified Data.Text as T + +import Helpers + +main :: IO () +main = hspec spec + +fname :: Text +fname = "suffix" + +spec :: Spec +spec = withStdlibFunction fname $ \tester -> do + let checkError input expectederror = + case dummyEval (tester input) of + Left rr -> show (getError rr) `shouldStartWith` (T.unpack fname ++ ": " ++ expectederror) + Right _ -> expectationFailure "should have failed" + checkSuccess input expected = + case dummyEval (tester input) of + Left rr -> expectationFailure (show rr) + Right r -> r `shouldBe` expected + it "should fail with no argument" (checkError [] "expects two arguments") + it "should fail if the first argument isn't an array or hash" (checkError ["lol"] "expects the first argument to be an array or a hash") + it "should fail if the second argument isn't a string" $ do + checkError [PArray [], PNumber 1] "expects the second argument to be a string" + checkError [PArray [], PArray []] "expects the second argument to be a string" + it "should work with arrays" $ do + checkSuccess [ PArray []] (PArray []) + checkSuccess [ PArray [], ""] (PArray []) + checkSuccess [ PArray ["one"], "post" ] (PArray ["onepost"]) + checkSuccess [ PArray ["one","two","three"], "post" ] (PArray ["onepost","twopost","threepost"]) + it "should work with hashes" $ do + checkSuccess [(PHash mempty)] (PHash mempty) + checkSuccess [(PHash mempty), ""] (PHash mempty) + checkSuccess [(PHash [("one", PNumber 5)] ), "post" ] (PHash [("onepost", PNumber 5)]) + checkSuccess [(PHash [("one", PNumber 5), ("two", "lol"), ("three", PNumber 7)]), "post" ] (PHash [("onepost", PNumber 5), ("twopost", "lol"), ("threepost", PNumber 7)]) + diff --git a/tests/Interpreter/Function/WithSpec.hs b/tests/Interpreter/Function/WithSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Interpreter/Function/WithSpec.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE OverloadedLists #-} +module Interpreter.Function.WithSpec where + +import Helpers + +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + let getCatalog x = case pureCatalog x of + Left rr -> fail rr + Right (y,_) -> pure y + describe "should run as" $ do + it "should be callable with an argument" $ + getCatalog "with ( 12 ) |$x| { file {'/f': content => $x; } }" + >>= getResource (RIdentifier "file" "/f") + >>= getAttribute "content" + >>= (`shouldBe` "12") + it "should be callable with two arguments" $ + getCatalog "with ( '/tmp/lal', 12 ) |$f, $x| { file {$f: content => $x; } }" + >>= getResource (RIdentifier "file" "/tmp/lal") + >>= getAttribute "content" + >>= (`shouldBe` "12") + it "should separate scopes scope" $ do + getCatalog "$x='lol' \n with ( 12 ) |$x| { file {'/f': content => $x; } } \n file {'/g': content => $x; }" + >>= getResource (RIdentifier "file" "/f") + >>= getAttribute "content" + >>= (`shouldBe` "12") + getCatalog "$x='lol' \n with ( 12 ) |$x| { file {'/f': content => $x; } } \n file {'/g': content => $x; }" + >>= getResource (RIdentifier "file" "/g") + >>= getAttribute "content" + >>= (`shouldBe` "lol") + it "should work in value mode" $ + getCatalog "$x= with ('a', 'b' ) |$x, $y| { \"${x} and ${y}\" } \n file {'/g': content => $x; }" + >>= getResource (RIdentifier "file" "/g") + >>= getAttribute "content" + >>= (`shouldBe` "a and b") diff --git a/tests/Interpreter/IfSpec.hs b/tests/Interpreter/IfSpec.hs --- a/tests/Interpreter/IfSpec.hs +++ b/tests/Interpreter/IfSpec.hs @@ -9,30 +9,22 @@ import Helpers -{- -shouldReturn :: [Text] -> [PValue] -> Expectation -shouldReturn content expectedMessages = do - cat <- case runExcept (getCatalog (T.unlines content)) of - Left rr -> fail rr - Right x -> return x - _foo cat --} - shouldFail :: [Text] -> Expectation -shouldFail content = let cat :: Either String FinalCatalog - cat = runExcept (getCatalog (Text.unlines content)) +shouldFail content = let cat = pureCatalog (Text.unlines content) in cat `shouldSatisfy` has _Left shouldNotFail :: [Text] -> Expectation -shouldNotFail content = let cat :: Either String FinalCatalog - cat = runExcept (getCatalog (Text.unlines content)) +shouldNotFail content = let cat = pureCatalog (Text.unlines content) in cat `shouldSatisfy` has _Right spec :: Spec spec = do + describe "If" $ do it "doesn't enter false conditions" $ shouldNotFail [ "if (false) { fail ':(' }" ] it "enters true conditions" $ shouldFail [ "if (true) { fail ':(' }" ] + it "enters empty string conditions" $ shouldFail + [ "if '' { fail ':(' }" ] it "not (unknown variable) is true" $ shouldFail [ "if (!$::unknown123) { fail ':(' }" ] diff --git a/tests/InterpreterSpec.hs b/tests/InterpreterSpec.hs deleted file mode 100644 --- a/tests/InterpreterSpec.hs +++ /dev/null @@ -1,80 +0,0 @@ -module InterpreterSpec (collectorSpec, classIncludeSpec, main) where - -import Helpers - -import qualified Data.HashMap.Strict as HM -import qualified Data.Text as Text -import qualified Data.Vector as V -import Text.Megaparsec (eof, parse) - -appendArrowNode :: Text -appendArrowNode = "appendArrow" - -arrowOperationInput :: Text -> Text -arrowOperationInput arr = Text.unlines [ "node " <> appendArrowNode <> " {" - , "user { 'jenkins':" - , " groups => 'ci'" - , "}" - , "User <| title == 'jenkins' |> {" - , "groups " <> arr <> " 'docker'," - , "uid => 1000}" - , "}" - ] - -getResAttr :: - (Either - PrettyError - (FinalCatalog, EdgeMap, FinalCatalog, [Resource]), - InterpreterState, - InterpreterWriter) - -> Container PValue -getResAttr s = - let finalcatalog = s ^._1._Right._1 - in finalcatalog ^. at (RIdentifier "user" "jenkins")._Just.rattributes - - -collectorSpec :: Spec -collectorSpec = do - let computeWith arr = pureCompute appendArrowNode (arrowOperationInput arr) - describe "Resource Collector" $ - it "should append the new 'uid' attribute in the user resource" $ - getResAttr (computeWith "=>") ^. at "uid" `shouldBe` Just (PNumber 1000) - describe "AppendArrow in AttributeDecl" $ - it "should add 'docker' to the 'groups' attribute of the user resource" $ - getResAttr (computeWith "+>") ^. at "groups" `shouldBe` Just (PArray $ V.fromList ["ci", "docker"]) - describe "AssignArrow in AttributeDecl" $ - it "should override the 'groups' attributes from the user resource" $ - getResAttr (computeWith "=>") ^. at "groups" `shouldBe` Just (PArray $ V.fromList ["docker"]) - -classIncludeSpec :: Spec -classIncludeSpec = do - let compute i = pureCompute "dummy" i ^. _1 - describe "Multiple loading" $ do - it "should work when using several include statements" $ compute (Text.unlines [ "node 'dummy' {",  "include foo", "include foo", "}" ]) `shouldSatisfy` (has _Right) - it "should work when using class before include" $ compute (Text.unlines [ "node 'dummy' {",  "class { 'foo': }", "include foo", "}" ]) `shouldSatisfy` (has _Right) - it "should fail when using include before class" $ compute (Text.unlines [ "node 'dummy' {",  "include foo", "class { 'foo': }", "}" ]) `shouldSatisfy` (has _Left) - -main :: IO () -main = hspec $ do - describe "Collectors" collectorSpec - describe "Class inclusion" classIncludeSpec - --- | Given a node and raw text input to be parsed, compute the manifest in a dummy setting. -pureCompute :: NodeName - -> Text - -> (Either PrettyError (FinalCatalog, EdgeMap, FinalCatalog, [Resource]), - InterpreterState, - InterpreterWriter) -pureCompute node input = - let hush' :: Show a => Either a b -> b - hush' = either (panic . show) identity - - getStatement :: NodeName -> Text -> HashMap (TopLevelType, NodeName) Statement - getStatement n i = HM.fromList [ ((TopNode, n), nodeStatement i) - , ((TopClass, "foo"), ClassDeclaration $ ClassDecl mempty mempty mempty mempty (initialPPos mempty)) - ] - - nodeStatement :: Text -> Statement - nodeStatement i = V.head $ hush' $ parse (puppetParser <* eof) "test" i - - in pureEval dummyFacts (getStatement node input) (computeCatalog node) diff --git a/tests/LexerSpec.hs b/tests/LexerSpec.hs deleted file mode 100644 --- a/tests/LexerSpec.hs +++ /dev/null @@ -1,22 +0,0 @@ -module LexerSpec(spec) where - -import System.FilePath.Glob -import Test.Hspec -import Text.Megaparsec (eof, parse) -import Test.Hspec.Megaparsec -import XPrelude - -import Puppet.Parser - -alltests = do - files <- runIO $ globDir1 (compile "*.pp") "tests/lexer" - mapM_ test files - - where - test fp = do - r <- runIO $ fmap check (readFile fp) - it ("should parse " <> fp) r - check i = - parse (puppetParser <* eof) empty `shouldSucceedOn` i - -spec = describe "Lexer" $ alltests diff --git a/tests/Parser/DT.hs b/tests/Parser/DT.hs new file mode 100644 --- /dev/null +++ b/tests/Parser/DT.hs @@ -0,0 +1,26 @@ +module Parser.DT (spec) where + +import Helpers + +import Test.Hspec.Megaparsec +import Text.Megaparsec (parse) +import qualified Text.Regex.PCRE.ByteString.Utils as Regex + +import Puppet.Parser.Internal + +spec :: Spec +spec = do + let parsed s r = it ("accepts " <> toS s) $ parse datatype "?" s `shouldParse` r + failed s = it ("rejects " <> toS s) $ shouldFailOn (parse datatype "?") s + describe "String" $ do + "String" `parsed` UDTString Nothing Nothing + failed "String[]" + failed "String[4,5,6]" + "String[5]" `parsed` UDTString (Just 5) Nothing + "String[5,8]" `parsed` UDTString (Just 5) (Just 8) + "Regexp" `parsed` UDTRegexp Nothing + let Right foore = Regex.compile' Regex.compBlank Regex.execBlank "foo" + "Regexp[/foo/]" `parsed` UDTRegexp (Just (CompRegex "foo" foore)) + it "accepts variables" $ pendingWith "to be fixed" *> parse datatype "?" "String[$var]" `shouldParse` UDTString (Just 5) Nothing + describe "Stdlib::" $ do + "Stdlib::HTTPUrl" `parsed` UDTData diff --git a/tests/Parser/ExprSpec.hs b/tests/Parser/ExprSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Parser/ExprSpec.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE OverloadedLists #-} +module Parser.ExprSpec (spec) where + +import Test.Hspec +import Test.Hspec.Megaparsec +import Text.Megaparsec + +import Puppet.Parser +import Puppet.Parser.Internal +import XPrelude + +expressions :: [(Text, Expression)] +expressions = + [ ("5 + 3 * 2", 5 + 3 * 2) + , ("5+2 == 7", Equal (5 + 2) 7) + , ("include(foo::bar)", Terminal (UFunctionCall "include" ["foo::bar"] )) + , ("$y ? {\ + \ undef => 'undef',\ + \ default => 'default',\ + \ }", ConditionalValue (Terminal (UVariableReference "y")) + [ SelectorValue UUndef :!: Terminal (UString "undef") + , SelectorDefault :!: Terminal (UString "default")]) + , ("$x", Terminal (UVariableReference "x")) + , ("x($y)", Terminal (UFunctionCall "x" [ Terminal (UVariableReference "y") ])) + , ("\"$\"", Terminal (UInterpolable [Terminal (UString "$")])) + , ("\"${x}\"", Terminal (UInterpolable [Terminal (UVariableReference "x")])) + , ("$x[ 3 ]", Lookup (Terminal (UVariableReference "x")) (Terminal (UNumber 3))) + , ("\"${ os[ 'architecture' ]}\"", Terminal (UInterpolable [Lookup (Terminal (UVariableReference "os")) (Terminal (UString "architecture"))])) + , ("\"${facts['os']['architecture']}\"", Terminal (UInterpolable [Lookup (Lookup (Terminal (UVariableReference "facts")) (Terminal (UString "os"))) (Terminal (UString "architecture"))])) + , ("\"${x[$y]}\"", Terminal (UInterpolable [Lookup (Terminal (UVariableReference "x")) (Terminal (UVariableReference "y")) ])) + , ("\"${x($y)}\"", Terminal (UInterpolable [ Terminal (UFunctionCall "x" [ Terminal (UVariableReference "y") ] ) ] )) + , ("\"${x($y)}$'\"", Terminal (UInterpolable [ Terminal (UFunctionCall "x" [ Terminal (UVariableReference "y") ]) + , Terminal (UString "$"),Terminal (UString "'")])) + ] + +invalid :: [Text] +invalid = [ "$os['name]" + -- pending + -- , "$os ['name']" + -- interpolation + , "\"${os['name]}\"" + , "\"${os[name}\"" + , "\"${os[name]\"" + ] + +testExpression (t,e) = it ("should parse " <> toS t) $ parse (expression <* eof) "" t `shouldParse` e + +testInvalid s = it ("rejects " <> toS s) $ shouldFailOn (parse (expression <* eof) "") s + +spec = do + describe "Expression parser" $ mapM_ testExpression expressions + describe "Invalid expression" $ mapM_ testInvalid invalid diff --git a/tests/Parser/LexerSpec.hs b/tests/Parser/LexerSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Parser/LexerSpec.hs @@ -0,0 +1,31 @@ +module Parser.LexerSpec(spec) where + +import XPrelude + +import System.FilePath.Glob +import Test.Hspec +import Text.Megaparsec (eof, parse) +import Test.Hspec.Megaparsec + +import Puppet.Parser +import Puppet.Parser.Internal + +validFiles = do + files <- runIO $ globDir1 (compile "*.pp") "tests/Parser/lexer" + mapM_ test files + + where + test fp = do + r <- runIO $ fmap check (readFile fp) + it ("should parse " <> fp) r + check i = + parse (puppetParser <* eof) empty `shouldSucceedOn` i + +spec = describe "Lexer" $ do + describe "Valid lexer" $ validFiles + describe "Invalid lexer" $ do + it "should fail to parse resource reference with a space after the resource type" $ invalid resourceReference "File ['/test']" + xit "should fail if there is a space after the variable name" $ invalid interpolableString "\"${os ['name']}\"" + +-- Utils +invalid p s = parse (p <* eof) mempty `shouldFailOn` s diff --git a/tests/Parser/lexer/aliastest.pp b/tests/Parser/lexer/aliastest.pp new file mode 100644 --- /dev/null +++ b/tests/Parser/lexer/aliastest.pp @@ -0,0 +1,16 @@ +file { "a file": + path => "/tmp/aliastest", + ensure => file +} + +file { "another": + path => "/tmp/aliastest2", + ensure => file, + require => File["a file"] +} + +file { "a third": + path => "/tmp/aliastest3", + ensure => file, + require => File["/tmp/aliastest"] +} diff --git a/tests/Parser/lexer/appendArrowAttribute.pp b/tests/Parser/lexer/appendArrowAttribute.pp new file mode 100644 --- /dev/null +++ b/tests/Parser/lexer/appendArrowAttribute.pp @@ -0,0 +1,6 @@ +node test { + user { 'jenkins': + groups => "docker" + } + User <| title == 'jenkins' |> { groups +> "dockerroot" } +} diff --git a/tests/Parser/lexer/argumentdefaults.pp b/tests/Parser/lexer/argumentdefaults.pp new file mode 100644 --- /dev/null +++ b/tests/Parser/lexer/argumentdefaults.pp @@ -0,0 +1,14 @@ +# $Id$ + +define testargs($file, $mode = 755) { + file { $file: ensure => file, mode => $mode } +} + +testargs { "testingname": + file => "/tmp/argumenttest1" +} + +testargs { "testingother": + file => "/tmp/argumenttest2", + mode => 644 +} diff --git a/tests/Parser/lexer/arithmeticexpression.pp b/tests/Parser/lexer/arithmeticexpression.pp new file mode 100644 --- /dev/null +++ b/tests/Parser/lexer/arithmeticexpression.pp @@ -0,0 +1,8 @@ + +$one = 1.30 +$two = 2.034e-2 + +$result = ((( $two + 2) / $one) + 4 * 5.45) - (6 << 7) + (0x800 + -9) + + +notice("result is $result == 1295.87692307692") diff --git a/tests/Parser/lexer/arraytrailingcomma.pp b/tests/Parser/lexer/arraytrailingcomma.pp new file mode 100644 --- /dev/null +++ b/tests/Parser/lexer/arraytrailingcomma.pp @@ -0,0 +1,3 @@ +file { + ["/tmp/arraytrailingcomma1","/tmp/arraytrailingcomma2", ]: content => "tmp" +} diff --git a/tests/Parser/lexer/assert_types.pp b/tests/Parser/lexer/assert_types.pp new file mode 100644 --- /dev/null +++ b/tests/Parser/lexer/assert_types.pp @@ -0,0 +1,11 @@ +if $storage_driver { + if $::osfamily == 'windows' { + assert_type($storage_driver) |$a, $b| { + fail(translate(('Valid values for storage_driver on windows are windowsfilter'))) + } + } else { + assert_type($storage_driver) |$a, $b| { + fail(translate(('Valid values for storage_driver are aufs, devicemapper, btrfs, overlay, overlay2, vfs, zfs.'))) + } + } + } diff --git a/tests/Parser/lexer/case143.pp b/tests/Parser/lexer/case143.pp new file mode 100644 --- /dev/null +++ b/tests/Parser/lexer/case143.pp @@ -0,0 +1,5 @@ +$sources_list_content = $_purge['sources.list'] ? { + true => "# Repos managed by puppet.\n", + default => undef, +} + diff --git a/tests/Parser/lexer/casestatement.pp b/tests/Parser/lexer/casestatement.pp new file mode 100644 --- /dev/null +++ b/tests/Parser/lexer/casestatement.pp @@ -0,0 +1,65 @@ +# $Id$ + +$var = "value" + +case $var { + "nope": { + file { "/tmp/fakefile": mode => 644, ensure => file } + } + "value": { + file { "/tmp/existsfile": mode => 755, ensure => file } + } +} + +$ovar = "yayness" + +case $ovar { + "fooness": { + file { "/tmp/nostillexistsfile": mode => 644, ensure => file } + } + "booness", "yayness": { + case $var { + "nep": { + file { "/tmp/noexistsfile": mode => 644, ensure => file } + } + "value": { + file { "/tmp/existsfile2": mode => 755, ensure => file } + } + } + } +} + +case $ovar { + "fooness": { + file { "/tmp/nostillexistsfile": mode => 644, ensure => file } + } + default: { + file { "/tmp/existsfile3": mode => 755, ensure => file } + } +} + +$bool = true + +case $bool { + true: { + file { "/tmp/existsfile4": mode => 755, ensure => file } + } +} + +$yay = yay +$a = yay +$b = boo + +case $yay { + $a: { file { "/tmp/existsfile5": mode => 755, ensure => file } } + $b: { file { "/tmp/existsfile5": mode => 644, ensure => file } } + default: { file { "/tmp/existsfile5": mode => 711, ensure => file } } + +} + +$regexvar = "exists regex" +case $regexvar { + "no match": { file { "/tmp/existsfile6": mode => 644, ensure => file } } + /(.*) regex$/: { file { "/tmp/${1}file6": mode => 755, ensure => file } } + default: { file { "/tmp/existsfile6": mode => 711, ensure => file } } +} diff --git a/tests/Parser/lexer/classheirarchy.pp b/tests/Parser/lexer/classheirarchy.pp new file mode 100644 --- /dev/null +++ b/tests/Parser/lexer/classheirarchy.pp @@ -0,0 +1,15 @@ +# $Id$ + +class base { + file { "/tmp/classheir1": ensure => file, mode => 755 } +} + +class sub1 inherits base { + file { "/tmp/classheir2": ensure => file, mode => 755 } +} + +class sub2 inherits base { + file { "/tmp/classheir3": ensure => file, mode => 755 } +} + +include sub1, sub2 diff --git a/tests/Parser/lexer/classpathtest.pp b/tests/Parser/lexer/classpathtest.pp new file mode 100644 --- /dev/null +++ b/tests/Parser/lexer/classpathtest.pp @@ -0,0 +1,11 @@ +# $Id$ + +define mytype { + file { "/tmp/classtest": ensure => file, mode => 755 } +} + +class testing { + mytype { "componentname": } +} + +include testing diff --git a/tests/Parser/lexer/collection.pp b/tests/Parser/lexer/collection.pp new file mode 100644 --- /dev/null +++ b/tests/Parser/lexer/collection.pp @@ -0,0 +1,10 @@ +class one { + @file { "/tmp/colltest1": content => "one" } + @file { "/tmp/colltest2": content => "two" } +} + +class two { + File <| content == "one" |> +} + +include one, two diff --git a/tests/Parser/lexer/collection_override.pp b/tests/Parser/lexer/collection_override.pp new file mode 100644 --- /dev/null +++ b/tests/Parser/lexer/collection_override.pp @@ -0,0 +1,8 @@ +@file { + "/tmp/collection": + content => "whatever" +} + +File<| |> { + mode => 0600 +} diff --git a/tests/Parser/lexer/collection_within_virtual_definitions.pp b/tests/Parser/lexer/collection_within_virtual_definitions.pp new file mode 100644 --- /dev/null +++ b/tests/Parser/lexer/collection_within_virtual_definitions.pp @@ -0,0 +1,20 @@ +define test($name) { + file {"/tmp/collection_within_virtual_definitions1_$name.txt": + content => "File name $name\n" + } + Test2 <||> +} + +define test2() { + file {"/tmp/collection_within_virtual_definitions2_$name.txt": + content => "This is a test\n" + } +} + +node default { + @test {"foo": + name => "foo" + } + @test2 {"foo2": } + Test <||> +} diff --git a/tests/Parser/lexer/componentmetaparams.pp b/tests/Parser/lexer/componentmetaparams.pp new file mode 100644 --- /dev/null +++ b/tests/Parser/lexer/componentmetaparams.pp @@ -0,0 +1,11 @@ +file { "/tmp/component1": + ensure => file +} + +define thing { + file { $name: ensure => file } +} + +thing { "/tmp/component2": + require => File["/tmp/component1"] +} diff --git a/tests/Parser/lexer/componentrequire.pp b/tests/Parser/lexer/componentrequire.pp new file mode 100644 --- /dev/null +++ b/tests/Parser/lexer/componentrequire.pp @@ -0,0 +1,8 @@ +define testfile($mode) { + file { $name: mode => $mode, ensure => present } +} + +testfile { "/tmp/testing_component_requires2": mode => 755 } + +file { "/tmp/testing_component_requires1": mode => 755, ensure => present, + require => Testfile["/tmp/testing_component_requires2"] } diff --git a/tests/Parser/lexer/conversions.pp b/tests/Parser/lexer/conversions.pp new file mode 100644 --- /dev/null +++ b/tests/Parser/lexer/conversions.pp @@ -0,0 +1,6 @@ +$a_number = Integer("0xFF", 16) # results in 255 +$a_number = Numeric("010") # results in 8 +$a_number = Numeric("010", 10) # results in 10 +$a_number = Integer(true) # results in 1 +$a_number = Numeric("0x10", 10) # this is an error. Prefix and radix does not match. + diff --git a/tests/Parser/lexer/deepclassheirarchy.pp b/tests/Parser/lexer/deepclassheirarchy.pp new file mode 100644 --- /dev/null +++ b/tests/Parser/lexer/deepclassheirarchy.pp @@ -0,0 +1,23 @@ +# $Id$ + +class base { + file { "/tmp/deepclassheir1": ensure => file, mode => 755 } +} + +class sub1 inherits base { + file { "/tmp/deepclassheir2": ensure => file, mode => 755 } +} + +class sub2 inherits sub1 { + file { "/tmp/deepclassheir3": ensure => file, mode => 755 } +} + +class sub3 inherits sub2 { + file { "/tmp/deepclassheir4": ensure => file, mode => 755 } +} + +class sub4 inherits sub3 { + file { "/tmp/deepclassheir5": ensure => file, mode => 755 } +} + +include sub4 diff --git a/tests/Parser/lexer/defineoverrides.pp b/tests/Parser/lexer/defineoverrides.pp new file mode 100644 --- /dev/null +++ b/tests/Parser/lexer/defineoverrides.pp @@ -0,0 +1,17 @@ +# $Id$ + +$file = "/tmp/defineoverrides1" + +define myfile($mode) { + file { $name: ensure => file, mode => $mode } +} + +class base { + myfile { $file: mode => 644 } +} + +class sub inherits base { + Myfile[$file] { mode => 755, } # test the end-comma +} + +include sub diff --git a/tests/Parser/lexer/emptyclass.pp b/tests/Parser/lexer/emptyclass.pp new file mode 100644 --- /dev/null +++ b/tests/Parser/lexer/emptyclass.pp @@ -0,0 +1,9 @@ +# $Id$ + +define component { +} + +class testing { +} + +include testing diff --git a/tests/Parser/lexer/emptyexec.pp b/tests/Parser/lexer/emptyexec.pp new file mode 100644 --- /dev/null +++ b/tests/Parser/lexer/emptyexec.pp @@ -0,0 +1,3 @@ +exec { "touch /tmp/emptyexectest": + path => "/usr/bin:/bin" +} diff --git a/tests/Parser/lexer/falsevalues.pp b/tests/Parser/lexer/falsevalues.pp new file mode 100644 --- /dev/null +++ b/tests/Parser/lexer/falsevalues.pp @@ -0,0 +1,3 @@ +$value = false + +file { "/tmp/falsevalues$value": ensure => file } diff --git a/tests/Parser/lexer/filecreate.pp b/tests/Parser/lexer/filecreate.pp new file mode 100644 --- /dev/null +++ b/tests/Parser/lexer/filecreate.pp @@ -0,0 +1,11 @@ +# $Id$ + +file { + "/tmp/createatest": ensure => file, mode => 755; + "/tmp/createbtest": ensure => file, mode => 755 +} + +file { + "/tmp/createctest": ensure => file; + "/tmp/createdtest": ensure => file; +} diff --git a/tests/Parser/lexer/fqdefinition.pp b/tests/Parser/lexer/fqdefinition.pp new file mode 100644 --- /dev/null +++ b/tests/Parser/lexer/fqdefinition.pp @@ -0,0 +1,5 @@ +define one::two($ensure) { + file { "/tmp/fqdefinition": ensure => $ensure } +} + +one::two { "/tmp/fqdefinition": ensure => file } diff --git a/tests/Parser/lexer/fqparents.pp b/tests/Parser/lexer/fqparents.pp new file mode 100644 --- /dev/null +++ b/tests/Parser/lexer/fqparents.pp @@ -0,0 +1,11 @@ +class base { + class one { + file { "/tmp/fqparent1": ensure => file } + } +} + +class two::three inherits base::one { + file { "/tmp/fqparent2": ensure => file } +} + +include two::three diff --git a/tests/Parser/lexer/funccomma.pp b/tests/Parser/lexer/funccomma.pp new file mode 100644 --- /dev/null +++ b/tests/Parser/lexer/funccomma.pp @@ -0,0 +1,5 @@ +@file { + ["/tmp/funccomma1","/tmp/funccomma2"]: content => "1" +} + +realize( File["/tmp/funccomma1"], File["/tmp/funccomma2"] , ) diff --git a/tests/Parser/lexer/hashindefault.pp b/tests/Parser/lexer/hashindefault.pp new file mode 100644 --- /dev/null +++ b/tests/Parser/lexer/hashindefault.pp @@ -0,0 +1,32 @@ +class bind::master ($testcheck = '', $domains = { "${::domain}" => {} } , $slaves = [], $query_nets = ['10.2.1.0/24'], $forwarders = '') +{ + validate_hash($domains) + validate_array($slaves) + validate_array($query_nets) + + include bind + include bind::statichosts + + create_resources('bind::zonefile', $bind::master::domains) + bind::zonefile { 'zone.rev': ; } + + file { + '/etc/bind/named.conf.local': + content => template("bind/master.named.conf.local.erb"), + owner => 'root', + group => 'root', + mode => '644', + require => Package['bind9'], + notify => Service['bind9']; + '/etc/bind/named.conf.options': + content => template("bind/named.conf.options.erb"), + owner => 'root', + group => 'root', + mode => '644', + require => Package['bind9'], + notify => Service['bind9']; + } + + Zone_record<<| |>> +} + diff --git a/tests/Parser/lexer/ifexpression.pp b/tests/Parser/lexer/ifexpression.pp new file mode 100644 --- /dev/null +++ b/tests/Parser/lexer/ifexpression.pp @@ -0,0 +1,12 @@ +$one = 1 +$two = 2 + +if (($one < $two) and (($two < 3) or ($two == 2))) { + notice("True!") +} + +if ("test regex" =~ /(.*) regex/) { + file { + "/tmp/${1}iftest": ensure => file, mode => 0755 + } +} diff --git a/tests/Parser/lexer/ifupdown.pp b/tests/Parser/lexer/ifupdown.pp new file mode 100644 --- /dev/null +++ b/tests/Parser/lexer/ifupdown.pp @@ -0,0 +1,3 @@ +node 'test' { + ifupdown_route { 'other': vlans => ['8','11']; } +} diff --git a/tests/Parser/lexer/implicititeration.pp b/tests/Parser/lexer/implicititeration.pp new file mode 100644 --- /dev/null +++ b/tests/Parser/lexer/implicititeration.pp @@ -0,0 +1,15 @@ +# $Id$ + +$files = ["/tmp/iterationatest", "/tmp/iterationbtest"] + +file { $files: ensure => file, mode => 755 } + +file { ["/tmp/iterationctest", "/tmp/iterationdtest"]: + ensure => file, + mode => 755 +} + +file { + ["/tmp/iterationetest", "/tmp/iterationftest"]: ensure => file, mode => 755; + ["/tmp/iterationgtest", "/tmp/iterationhtest"]: ensure => file, mode => 755; +} diff --git a/tests/Parser/lexer/interpolableindexing.pp b/tests/Parser/lexer/interpolableindexing.pp new file mode 100644 --- /dev/null +++ b/tests/Parser/lexer/interpolableindexing.pp @@ -0,0 +1,4 @@ + +$v = "a${x}" +$w = "a${y[10]}" + diff --git a/tests/Parser/lexer/lambda.pp b/tests/Parser/lexer/lambda.pp new file mode 100644 --- /dev/null +++ b/tests/Parser/lexer/lambda.pp @@ -0,0 +1,22 @@ +$binaries = ["facter", "hiera", "mco", "puppet", "puppetserver"] + +$binaries.each | $binary | { + file {"/usr/bin/$binary": + ensure => link, + target => "/opt/puppetlabs/bin/$binary", + } +} + +each($binaries) |$binary| { + file {"/usr/bin/$binary": + ensure => link, + target => "/opt/puppetlabs/bin/$binary", + } +} + +$entries = {} +$entries.each | String $e_name, Hash $e_params | { + limits::limits { $e_name: + * => $e_params, + } +} diff --git a/tests/Parser/lexer/multilinecomments.pp b/tests/Parser/lexer/multilinecomments.pp new file mode 100644 --- /dev/null +++ b/tests/Parser/lexer/multilinecomments.pp @@ -0,0 +1,10 @@ + +/* +file { + "/tmp/multilinecomments": content => "pouet" +} +*/ + +/* and another one for #2333, the whitespace after the +end comment is here on purpose */ + diff --git a/tests/Parser/lexer/multilookup.pp b/tests/Parser/lexer/multilookup.pp new file mode 100644 --- /dev/null +++ b/tests/Parser/lexer/multilookup.pp @@ -0,0 +1,1 @@ +$a = $b[1][2][3] diff --git a/tests/Parser/lexer/multipleclass.pp b/tests/Parser/lexer/multipleclass.pp new file mode 100644 --- /dev/null +++ b/tests/Parser/lexer/multipleclass.pp @@ -0,0 +1,9 @@ +class one { + file { "/tmp/multipleclassone": content => "one" } +} + +class one { + file { "/tmp/multipleclasstwo": content => "two" } +} + +include one diff --git a/tests/Parser/lexer/multipleinstances.pp b/tests/Parser/lexer/multipleinstances.pp new file mode 100644 --- /dev/null +++ b/tests/Parser/lexer/multipleinstances.pp @@ -0,0 +1,7 @@ +# $Id$ + +file { + "/tmp/multipleinstancesa": ensure => file, mode => 755; + "/tmp/multipleinstancesb": ensure => file, mode => 755; + "/tmp/multipleinstancesc": ensure => file, mode => 755; +} diff --git a/tests/Parser/lexer/multisubs.pp b/tests/Parser/lexer/multisubs.pp new file mode 100644 --- /dev/null +++ b/tests/Parser/lexer/multisubs.pp @@ -0,0 +1,13 @@ +class base { + file { "/tmp/multisubtest": content => "base", mode => 644 } +} + +class sub1 inherits base { + File["/tmp/multisubtest"] { mode => 755 } +} + +class sub2 inherits base { + File["/tmp/multisubtest"] { content => sub2 } +} + +include sub1, sub2 diff --git a/tests/Parser/lexer/namevartest.pp b/tests/Parser/lexer/namevartest.pp new file mode 100644 --- /dev/null +++ b/tests/Parser/lexer/namevartest.pp @@ -0,0 +1,9 @@ +define filetest($mode, $ensure = file) { + file { $name: + mode => $mode, + ensure => $ensure + } +} + +filetest { "/tmp/testfiletest": mode => 644} +filetest { "/tmp/testdirtest": mode => 755, ensure => directory} diff --git a/tests/Parser/lexer/nodes.pp b/tests/Parser/lexer/nodes.pp new file mode 100644 --- /dev/null +++ b/tests/Parser/lexer/nodes.pp @@ -0,0 +1,16 @@ + +node 'www1.example.com', 'www2.example.com', 'www3.example.com' { + include common + include apache, squid +} + + +node /^www\d+$/ { + include common +} + +node 'www1.example.com' inherits 'common' { + include ntp + include apache + include squid +} diff --git a/tests/Parser/lexer/rawresref.pp b/tests/Parser/lexer/rawresref.pp new file mode 100644 --- /dev/null +++ b/tests/Parser/lexer/rawresref.pp @@ -0,0 +1,6 @@ +class test { + file { + "/etc/udp2log/${name}": + require => Package[udplog]; + } +} diff --git a/tests/Parser/lexer/scopetest.pp b/tests/Parser/lexer/scopetest.pp new file mode 100644 --- /dev/null +++ b/tests/Parser/lexer/scopetest.pp @@ -0,0 +1,13 @@ + +$mode = 640 + +define thing { + file { "/tmp/$name": ensure => file, mode => $mode } +} + +class testing { + $mode = 755 + thing {scopetest: } +} + +include testing diff --git a/tests/Parser/lexer/selectorvalues.pp b/tests/Parser/lexer/selectorvalues.pp new file mode 100644 --- /dev/null +++ b/tests/Parser/lexer/selectorvalues.pp @@ -0,0 +1,50 @@ +$value1 = "" +$value2 = true +$value3 = false +$value4 = yay + +$test = "yay" + +$mode1 = $value1 ? { + "" => 755, + default => 644 +} + +$mode2 = $value2 ? { + true => 755, + default => 644 +} + +$mode3 = $value3 ? { + false => 755, + default => 644 +} + +$mode4 = $value4 ? { + $test => 755, + default => 644 +} + +$mode5 = yay ? { + $test => 755, + default => 644 +} + +$mode6 = $mode5 ? { + 755 => 755, + -2 => 3 +} + +$mode7 = "test regex" ? { + /regex$/ => 755, + default => 644 +} + + +file { "/tmp/selectorvalues1": ensure => file, mode => $mode1 } +file { "/tmp/selectorvalues2": ensure => file, mode => $mode2 } +file { "/tmp/selectorvalues3": ensure => file, mode => $mode3 } +file { "/tmp/selectorvalues4": ensure => file, mode => $mode4 } +file { "/tmp/selectorvalues5": ensure => file, mode => $mode5 } +file { "/tmp/selectorvalues6": ensure => file, mode => $mode6 } +file { "/tmp/selectorvalues7": ensure => file, mode => $mode7 } diff --git a/tests/Parser/lexer/simpledefaults.pp b/tests/Parser/lexer/simpledefaults.pp new file mode 100644 --- /dev/null +++ b/tests/Parser/lexer/simpledefaults.pp @@ -0,0 +1,5 @@ +# $Id$ + +File { mode => 755 } + +file { "/tmp/defaulttest": ensure => file } diff --git a/tests/Parser/lexer/simpleselector.pp b/tests/Parser/lexer/simpleselector.pp new file mode 100644 --- /dev/null +++ b/tests/Parser/lexer/simpleselector.pp @@ -0,0 +1,39 @@ +# $Id$ +/* +$var = "value" + +file { "/tmp/snippetselectatest": + ensure => file, + mode => $var ? { + nottrue => 641, + value => 755 + } +} +*/ +file { "/tmp/snippetselectbtest": + ensure => file, + mode => $var ? { + nottrue => 644, + default => 755 + } +} +/* +$othervar = "complex value" + +file { "/tmp/snippetselectctest": + ensure => file, + mode => $othervar ? { + "complex value" => 755, + default => 644 + } +} +$anothervar = Yayness + +file { "/tmp/snippetselectdtest": + ensure => file, + mode => $anothervar ? { + Yayness => 755, + default => 644 + } +} +*/ diff --git a/tests/Parser/lexer/singleary.pp b/tests/Parser/lexer/singleary.pp new file mode 100644 --- /dev/null +++ b/tests/Parser/lexer/singleary.pp @@ -0,0 +1,19 @@ +# $Id$ + +file { "/tmp/singleary1": + ensure => file +} + +file { "/tmp/singleary2": + ensure => file +} + +file { "/tmp/singleary3": + ensure => file, + require => [File["/tmp/singleary1"], File["/tmp/singleary2"]] +} + +file { "/tmp/singleary4": + ensure => file, + require => [File["/tmp/singleary1"]] +} diff --git a/tests/Parser/lexer/singlequote.pp b/tests/Parser/lexer/singlequote.pp new file mode 100644 --- /dev/null +++ b/tests/Parser/lexer/singlequote.pp @@ -0,0 +1,11 @@ +# $Id$ + +file { "/tmp/singlequote1": + ensure => file, + content => 'a $quote' +} + +file { "/tmp/singlequote2": + ensure => file, + content => 'some "\\yayness\"' +} diff --git a/tests/Parser/lexer/singleselector.pp b/tests/Parser/lexer/singleselector.pp new file mode 100644 --- /dev/null +++ b/tests/Parser/lexer/singleselector.pp @@ -0,0 +1,22 @@ +$value1 = "" +$value2 = true +$value3 = false +$value4 = yay + +$test = "yay" + +$mode1 = $value1 ? { + "" => 755 +} + +$mode2 = $value2 ? { + true => 755 +} + +$mode3 = $value3 ? { + default => 755 +} + +file { "/tmp/singleselector1": ensure => file, mode => $mode1 } +file { "/tmp/singleselector2": ensure => file, mode => $mode2 } +file { "/tmp/singleselector3": ensure => file, mode => $mode3 } diff --git a/tests/Parser/lexer/subclass_name_duplication.pp b/tests/Parser/lexer/subclass_name_duplication.pp new file mode 100644 --- /dev/null +++ b/tests/Parser/lexer/subclass_name_duplication.pp @@ -0,0 +1,11 @@ +#!/usr/bin/env puppet + +class one::fake { + file { "/tmp/subclass_name_duplication1": ensure => present } +} + +class two::fake { + file { "/tmp/subclass_name_duplication2": ensure => present } +} + +include one::fake, two::fake diff --git a/tests/Parser/lexer/tagged.pp b/tests/Parser/lexer/tagged.pp new file mode 100644 --- /dev/null +++ b/tests/Parser/lexer/tagged.pp @@ -0,0 +1,35 @@ +# $Id$ + +tag(testing) +tag(funtest) + +class tagdefine { + $path = tagged(tagdefine) ? { + rtrue => "true", rfalse => "false" + } + + file { "/tmp/taggeddefine$path": ensure => file } +} + +include tagdefine + +$yayness = tagged(yayness) ? { + true => "true", false => "false" +} + +$funtest = tagged(testing) ? { + true => "true", false => "false" +} + +$both = tagged(testing, yayness) ? { + true => "true", false => "false" +} + +$bothtrue = tagged(testing, testing) ? { + true => "true", false => "false" +} + +file { "/tmp/taggedyayness$yayness": ensure => file } +file { "/tmp/taggedtesting$funtest": ensure => file } +file { "/tmp/taggedboth$both": ensure => file } +file { "/tmp/taggedbothtrue$bothtrue": ensure => file } diff --git a/tests/Parser/lexer/tricky_wikimedia_1.pp b/tests/Parser/lexer/tricky_wikimedia_1.pp new file mode 100644 --- /dev/null +++ b/tests/Parser/lexer/tricky_wikimedia_1.pp @@ -0,0 +1,33 @@ +define create_pkcs12( $certname="$name", $cert_alias="", $password="", $user="root", $group="ssl-cert", $location="/etc/ssl/private" ) { + + if ( $cert_alias == "" ) { + $certalias = $certname + } else { + $certalias = $cert_alias + } + + if ( $password == "" ) { + $defaultpassword = $passwords::certs::certs_default_pass + } else { + $defaultpassword = $password + } + + exec { + # pkcs12 file, used by things like opendj, nss, and tomcat + "${name}_create_pkcs12": + creates => "${location}/${certname}.p12", + command => "/usr/bin/openssl pkcs12 -export -name \"${certalias}\" -passout pass:${defaultpassword} -in /etc/ssl/certs/${certname}.pem -inkey /etc/ssl/private/${certname}.key -out ${location}/${certname}.p12", + require => [Package["openssl"], File["/etc/ssl/private/${certname}.key", "/etc/ssl/certs/${certname}.pem"]]; + } + + file { + # Fix permissions on the p12 file, and make it available as + # a puppet resource + "${location}/${certname}.p12": + mode => 0440, + owner => $user, + group => $group, + require => Exec["${name}_create_pkcs12"], + ensure => file; + } +} diff --git a/tests/Parser/lexer/virtualresources.pp b/tests/Parser/lexer/virtualresources.pp new file mode 100644 --- /dev/null +++ b/tests/Parser/lexer/virtualresources.pp @@ -0,0 +1,14 @@ +class one { + @file { "/tmp/virtualtest1": content => "one" } + @file { "/tmp/virtualtest2": content => "two" } + @file { "/tmp/virtualtest3": content => "three" } + @file { "/tmp/virtualtest4": content => "four" } +} + +class two { + File <| content == "one" |> + realize(File["/tmp/virtualtest2"]) + realize(File["/tmp/virtualtest3"], File["/tmp/virtualtest4"]) +} + +include one, two diff --git a/tests/Parser/lexer/wget_double_regexp.pp b/tests/Parser/lexer/wget_double_regexp.pp new file mode 100644 --- /dev/null +++ b/tests/Parser/lexer/wget_double_regexp.pp @@ -0,0 +1,196 @@ +################################################################################ +# Definition: wget::fetch +# +# This defined type will download files from the internet. You may define a +# web proxy using $http_proxy if necessary. +# +# == Parameters: +# $source_hash: MD5-sum of the content to be downloaded, +# if content exists, but does not match it is removed +# before downloading +# +################################################################################ +define wget::fetch ( + $destination, + $source = $title, + $source_hash = undef, + $timeout = '0', + $verbose = false, + $redownload = false, + $nocheckcertificate = false, + $no_cookies = false, + $execuser = undef, + $user = undef, + $password = undef, + $headers = undef, + $cache_dir = undef, + $cache_file = undef, + $flags = undef, + $backup = true, + $mode = undef, + $unless = undef, +) { + + include wget + + # Does $destination end in a slash? If so, treat as a directory + case $destination { + # This is a nasty looking regex but it's simply checking to see if the $destination + # ends in either forward slash "\" (Linux) or backwards slash "/" (Windows) + /^.*\/$/, /^.*\$/: { + $source_split = split($source, '/') # split the URL into arrays, using "/" as a delimiter + $source_filename = $source_split[-1] # take the very last value in the array. this is the filename + $_destination = "${destination}/${source_filename}" + } + default: { + $_destination = $destination + } + } + + $http_proxy_env = $::http_proxy ? { + undef => [], + default => [ "HTTP_PROXY=${::http_proxy}", "http_proxy=${::http_proxy}" ], + } + $https_proxy_env = $::https_proxy ? { + undef => [], + default => [ "HTTPS_PROXY=${::https_proxy}", "https_proxy=${::https_proxy}" ], + } + $password_env = $user ? { + undef => [], + default => [ "WGETRC=${_destination}.wgetrc" ], + } + + # not using stdlib.concat to avoid extra dependency + $environment = split(inline_template('<%= (@http_proxy_env+@https_proxy_env+@password_env).join(\',\') %>'),',') + + $verbose_option = $verbose ? { + true => '--verbose', + false => '--no-verbose' + } + + # Windows exec unless testing requires different syntax + if ($::operatingsystem == 'windows') { + $exec_path = $::path + $unless_test = "cmd.exe /c \"dir ${_destination}\"" + } else { + $exec_path = '/usr/bin:/usr/sbin:/bin:/usr/local/bin:/opt/local/bin:/usr/sfw/bin' + if $unless != undef { + $unless_test = $unless + } + elsif $redownload == true or $cache_dir != undef { + $unless_test = 'test' + } else { + $unless_test = "test -s '${_destination}'" + } + } + + $nocheckcert_option = $nocheckcertificate ? { + true => ' --no-check-certificate', + false => '' + } + + $no_cookies_option = $no_cookies ? { + true => ' --no-cookies', + false => '', + } + + $user_option = $user ? { + undef => '', + default => " --user=${user}", + } + + if $user != undef { + $wgetrc_content = $::operatingsystem ? { + # This is to work around an issue with macports wget and out of date CA cert bundle. This requires + # installing the curl-ca-bundle package like so: + # + # sudo port install curl-ca-bundle + 'Darwin' => "password=${password}\nCA_CERTIFICATE=/opt/local/share/curl/curl-ca-bundle.crt\n", + default => "password=${password}", + } + + file { "${_destination}.wgetrc": + owner => $execuser, + mode => '0600', + content => $wgetrc_content, + before => Exec["wget-${name}"], + schedule => $schedule, + } + } + + $output_option = $cache_dir ? { + undef => " --output-document=\"${_destination}\"", + default => " -N -P \"${cache_dir}\"", + } + + # again, not using stdlib.concat, concatanate array of headers into a single string + if $headers != undef { + $headers_all = inline_template('<% @headers.each do | header | -%> --header "<%= header -%>"<% end -%>') + } + + $header_option = $headers ? { + undef => '', + default => $headers_all, + } + + $flags_joined = $flags ? { + undef => '', + default => inline_template(' <%= @flags.join(" ") %>') + } + + $exec_user = $cache_dir ? { + undef => $execuser, + default => undef, + } + + case $source_hash{ + '', undef: { + $command = "wget ${verbose_option}${nocheckcert_option}${no_cookies_option}${header_option}${user_option}${output_option}${flags_joined} \"${source}\"" + } + default: { + $command = "wget ${verbose_option}${nocheckcert_option}${no_cookies_option}${header_option}${user_option}${output_option}${flags_joined} \"${source}\" && echo '${source_hash} ${_destination}' | md5sum -c --quiet" + } + } + + + + + exec { "wget-${name}": + command => $command, + timeout => $timeout, + unless => $unless_test, + environment => $environment, + user => $exec_user, + path => $exec_path, + require => Class['wget'], + schedule => $schedule, + } + + if $cache_dir != undef { + $cache = $cache_file ? { + undef => inline_template('<%= require \'uri\'; File.basename(URI::parse(@source).path) %>'), + default => $cache_file, + } + file { $_destination: + ensure => file, + source => "${cache_dir}/${cache}", + owner => $execuser, + mode => $mode, + require => Exec["wget-${name}"], + backup => $backup, + schedule => $schedule, + } + } + + # remove destination if source_hash is invalid + if $source_hash != undef { + exec { "wget-source_hash-check-${name}": + command => "test ! -e '${_destination}' || rm ${_destination}", + path => '/usr/bin:/usr/sbin:/bin:/usr/local/bin:/opt/local/bin', + # only remove destination if md5sum does not match $source_hash + unless => "echo '${source_hash} ${_destination}' | md5sum -c --quiet", + notify => Exec["wget-${name}"], + schedule => $schedule, + } + } +} diff --git a/tests/Spec.hs b/tests/Spec.hs --- a/tests/Spec.hs +++ b/tests/Spec.hs @@ -2,56 +2,58 @@ import Helpers -import qualified DT.Parser import qualified ErbSpec -import qualified EvalSpec -import qualified ExprSpec -import qualified Function.AssertPrivateSpec -import qualified Function.DeleteAtSpec -import qualified Function.EachSpec -import qualified Function.JoinKeysToValuesSpec -import qualified Function.LookupSpec -import qualified Function.MergeSpec -import qualified Function.ShellquoteSpec -import qualified Function.SizeSpec -import qualified Function.SprintfSpec -import qualified Function.SuffixSpec -import qualified Function.PrefixSpec +import qualified HieraSpec +import qualified Interpreter.ClassSpec import qualified Interpreter.CollectorSpec +import qualified Interpreter.EvalSpec +import qualified Interpreter.Function.AssertPrivateSpec +import qualified Interpreter.Function.DeleteAtSpec +import qualified Interpreter.Function.EachSpec +import qualified Interpreter.Function.JoinKeysToValuesSpec +import qualified Interpreter.Function.LookupSpec +import qualified Interpreter.Function.MergeSpec +import qualified Interpreter.Function.PrefixSpec +import qualified Interpreter.Function.ShellquoteSpec +import qualified Interpreter.Function.SizeSpec +import qualified Interpreter.Function.SprintfSpec +import qualified Interpreter.Function.SuffixSpec +import qualified Interpreter.Function.WithSpec import qualified Interpreter.IfSpec -import qualified InterpreterSpec -import qualified LexerSpec +import qualified Parser.DT +import qualified Parser.ExprSpec +import qualified Parser.LexerSpec import qualified PuppetdbSpec -import qualified HieraSpec main :: IO () main = hspec spec spec :: Spec spec = do - describe "Data types" $ do - describe "Parser" DT.Parser.spec - EvalSpec.spec - ExprSpec.spec - ErbSpec.spec - LexerSpec.spec + describe "Parser" $ do + describe "Data types" $ do + Parser.DT.spec + Parser.ExprSpec.spec + Parser.LexerSpec.spec describe "Interpreter" $ do - describe "Collector" InterpreterSpec.collectorSpec - describe "Class include" InterpreterSpec.classIncludeSpec - describe "Collector (puppet tests)" Interpreter.CollectorSpec.spec - describe "If" Interpreter.IfSpec.spec - describe "Puppet functions" $ do - describe "The shellquote function" Function.ShellquoteSpec.spec - describe "The sprintf function" Function.SprintfSpec.spec - describe "The each function" Function.EachSpec.spec - describe "The lookup function" Function.LookupSpec.spec - describe "The suffix function" Function.SuffixSpec.spec - describe "The prefix function" Function.PrefixSpec.spec - describe "stdlib functions" $ do - describe "The assert_private function" Function.AssertPrivateSpec.spec - describe "The join_keys_to_values function" Function.JoinKeysToValuesSpec.spec - describe "The merge function" Function.MergeSpec.spec - describe "The size function" Function.SizeSpec.spec - describe "The delete_at function" Function.DeleteAtSpec.spec + Interpreter.CollectorSpec.spec + Interpreter.ClassSpec.spec + Interpreter.EvalSpec.spec + Interpreter.IfSpec.spec + describe "stdlib functions" $ do + describe "The assert_private function" Interpreter.Function.AssertPrivateSpec.spec + describe "The join_keys_to_values function" Interpreter.Function.JoinKeysToValuesSpec.spec + describe "The merge function" Interpreter.Function.MergeSpec.spec + describe "The size function" Interpreter.Function.SizeSpec.spec + describe "The delete_at function" Interpreter.Function.DeleteAtSpec.spec + describe "puppet functions" $ do + describe "The shellquote function" Interpreter.Function.ShellquoteSpec.spec + describe "The sprintf function" Interpreter.Function.SprintfSpec.spec + describe "The each function" Interpreter.Function.EachSpec.spec + describe "The with function" Interpreter.Function.WithSpec.spec + describe "The lookup function" Interpreter.Function.LookupSpec.spec + describe "The suffix function" Interpreter.Function.SuffixSpec.spec + describe "The prefix function" Interpreter.Function.PrefixSpec.spec + ErbSpec.spec PuppetdbSpec.spec HieraSpec.spec diff --git a/tests/hiera/common.yaml b/tests/hiera/common.yaml --- a/tests/hiera/common.yaml +++ b/tests/hiera/common.yaml @@ -8,3 +8,4 @@ uid: 2000 tom: uid: 2001 +optional_value: ~ diff --git a/tests/hiera/hiera-v5.yaml b/tests/hiera/hiera-v5.yaml --- a/tests/hiera/hiera-v5.yaml +++ b/tests/hiera/hiera-v5.yaml @@ -1,10 +1,13 @@ --- version: 5 +default: + datadir: data hierarchy: - - name: "Hiera config for unit test" + - name: "hiera config for unit test" data_hash: yaml_data datadir: . paths: - "%{::fqdn}.yaml" - "%{::environment}.yaml" - - common.yaml + - name: "Second hierarchy not used for now" + path: 'common.yaml'