language-puppet 1.1.4.1 → 1.1.5
raw patch · 44 files changed
+2063/−1481 lines, 44 filesdep −Diffdep −bifunctorsdep −parsersdep ~aesondep ~ansi-wl-pprintdep ~attoparsec
Dependencies removed: Diff, bifunctors, parsers
Dependency ranges changed: aeson, ansi-wl-pprint, attoparsec, base, hruby, hslua, hspec, lens, megaparsec, mtl, optparse-applicative, process, scientific, strict-base-types, text, unix, unordered-containers, vector, yaml
Files
- CHANGELOG.markdown +17/−0
- Erb/Compute.hs +24/−10
- Erb/Evaluate.hs +19/−16
- Facter.hs +2/−2
- Hiera/Server.hs +18/−17
- Puppet/Daemon.hs +97/−85
- Puppet/Interpreter.hs +321/−296
- Puppet/Interpreter/IO.hs +22/−22
- Puppet/Interpreter/PrettyPrinter.hs +15/−6
- Puppet/Interpreter/Pure.hs +22/−9
- Puppet/Interpreter/Resolve.hs +51/−39
- Puppet/Interpreter/Types.hs +204/−365
- Puppet/Interpreter/Utils.hs +148/−0
- Puppet/Lens.hs +66/−119
- Puppet/Manifests.hs +19/−20
- Puppet/NativeTypes/Cron.hs +10/−7
- Puppet/NativeTypes/File.hs +6/−2
- Puppet/NativeTypes/Package.hs +2/−1
- Puppet/PP.hs +7/−3
- Puppet/Parser.hs +165/−170
- Puppet/Parser/PrettyPrinter.hs +31/−28
- Puppet/Parser/Types.hs +158/−97
- Puppet/Parser/Utils.hs +12/−0
- Puppet/Pathes.hs +0/−23
- Puppet/Paths.hs +23/−0
- Puppet/Preferences.hs +2/−2
- Puppet/Puppetlabs.hs +12/−10
- Puppet/Stats.hs +0/−1
- Puppet/Stdlib.hs +38/−14
- Puppet/Utils.hs +45/−11
- PuppetDB/Common.hs +3/−3
- PuppetDB/Remote.hs +4/−4
- PuppetDB/TestDB.hs +17/−17
- language-puppet.cabal +92/−50
- progs/PuppetResources.hs +28/−29
- progs/pdbQuery.hs +3/−3
- tests/Function/EachSpec.hs +52/−0
- tests/Function/MergeSpec.hs +49/−0
- tests/Function/ShellquoteSpec.hs +58/−0
- tests/Function/SizeSpec.hs +56/−0
- tests/Helpers.hs +43/−0
- tests/InterpreterSpec.hs +79/−0
- tests/Spec.hs +19/−0
- tests/hiera.hs +4/−0
CHANGELOG.markdown view
@@ -1,3 +1,20 @@+# v1.1.5 (TBA)++## New features++* Added the `pick_default` function+* `merge` now works with an arbitrary number of hashes+* Added the `hash` function+* puppet native type `file` resource accept selinux parameters+* Added the `shellquote` function++## Bugs fixed++* `create_resources` can now create virtual and exported resources+* puppet native type `file` fix for parameters `sourceselect` and `recurselimit`+* Hiera array merge now only keeps unique values+* `merge` now properly priorizes the lastest arguments+ # v1.1.4.1 (2015/11/15) ## New features
Erb/Compute.hs view
@@ -1,17 +1,13 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-}-module Erb.Compute(computeTemplate, initTemplateDaemon) where--import Puppet.Interpreter.Types-import Puppet.Interpreter.IO-import Puppet.Interpreter.Resolve-import Puppet.PP-import Puppet.Preferences-import Puppet.Stats-import Puppet.Utils+module Erb.Compute (+ computeTemplate+ , initTemplateDaemon+) where import Control.Concurrent+import Control.Exception import Control.Monad.Except import Data.Aeson.Lens import qualified Data.Either.Strict as S@@ -30,13 +26,22 @@ import Text.Parsec hiding (string) import Text.Parsec.Error import Text.Parsec.Pos- import Control.Lens+ import Data.Tuple.Strict import qualified Foreign.Ruby.Helpers as FR import qualified Foreign.Ruby.Bindings as FR import Foreign.Ruby+import GHC.Conc (labelThread) +import Puppet.Interpreter.Types+import Puppet.Interpreter.IO+import Puppet.Interpreter.Resolve+import Puppet.PP+import Puppet.Preferences+import Puppet.Stats+import Puppet.Utils+ instance IsString TemplateParseError where fromString s = TemplateParseError $ newErrorMessage (Message s) (initialPos "dummy") @@ -76,7 +81,10 @@ templateDaemon :: RubyInterpreter -> T.Text -> T.Text -> Chan TemplateQuery -> MStats -> FileCacheR TemplateParseError [RubyStatement] -> IO () templateDaemon intr modpath templatepath qchan mvstats filecache = do+ let nameThread :: String -> IO ()+ nameThread n = myThreadId >>= flip labelThread n nameThread "RubyTemplateDaemon"+ (respchan, fileinfo, stt, rdr) <- readChan qchan case fileinfo of Right filename -> do@@ -216,3 +224,9 @@ Right r -> FR.fromRuby r >>= \case Right result -> return (S.Right result) Left rr -> return (S.Left $ PrettyError ("Could not deserialiaze ruby output" <+> text rr))++eitherDocIO :: IO (S.Either PrettyError a) -> IO (S.Either PrettyError a)+eitherDocIO computation = (computation >>= check) `catch` (\e -> return $ S.Left $ PrettyError $ dullred $ text $ show (e :: SomeException))+ where+ check (S.Left r) = return (S.Left r)+ check (S.Right x) = return (S.Right x)
Erb/Evaluate.hs view
@@ -2,22 +2,25 @@ -- | Evaluates a ruby template from what's generated by "Erb.Parser". module Erb.Evaluate (rubyEvaluate, getVariable, extractFromState) where -import Puppet.PP-import qualified Text.PrettyPrint.ANSI.Leijen as P-import Puppet.Interpreter.PrettyPrinter()-import Puppet.Interpreter.Types-import Puppet.Interpreter.Resolve-import Erb.Ruby-import qualified Data.Text as T-import Puppet.Utils-import Control.Lens-import qualified Data.Vector as V-import Data.Char (isSpace)-import Data.Aeson.Lens-import Data.Tuple.Strict-import qualified Data.HashMap.Strict as HM-import Data.Maybe (fromMaybe)+import Control.Lens+import Data.Aeson.Lens+import Data.Char (isSpace)+import qualified Data.HashMap.Strict as HM+import Data.Maybe (fromMaybe)+import qualified Data.Text as T+import Data.Tuple.Strict+import qualified Data.Vector as V+import Erb.Ruby +import Puppet.Interpreter.PrettyPrinter ()+import Puppet.Interpreter.Resolve+import Puppet.Interpreter.Types+import Puppet.Interpreter.Utils+import Puppet.Parser.Utils+import Puppet.PP+import Puppet.Utils+import qualified Text.PrettyPrint.ANSI.Leijen as P+ extractFromState :: InterpreterState -> Maybe (T.Text, Container ScopeInformation) extractFromState stt = let cs = stt ^. curScope@@ -27,7 +30,7 @@ classes = (PArray . V.fromList . map PString . HM.keys) (stt ^. loadedClasses) scps = stt ^. scopes cd = fromMaybe ContRoot (scps ^? ix scp . scopeContainer . cctype) -- get the current containder description- cscps = scps & ix scp . scopeVariables . at "classes" ?~ ( classes :!: dummypos :!: cd )+ cscps = scps & ix scp . scopeVariables . at "classes" ?~ ( classes :!: dummyppos :!: cd ) in Just (scp, cscps) rubyEvaluate :: Container ScopeInformation -> T.Text -> [RubyStatement] -> Either Doc T.Text
Facter.hs view
@@ -167,10 +167,10 @@ modelnames = mapMaybe (fmap (dropWhile (`elem` ("\t :" :: String))) . stripPrefix "model name") (lines cpuinfo) return $ ("processorcount", show (length cpuinfos)) : cpuinfos -puppetDBFacts :: Nodename -> PuppetDBAPI IO -> IO (Container PValue)+puppetDBFacts :: NodeName -> PuppetDBAPI IO -> IO (Container PValue) puppetDBFacts node pdbapi = runEitherT (getFacts pdbapi (QEqual FCertname node)) >>= \case- Right facts@(_:_) -> return (HM.fromList (map (\f -> (f ^. factname, f ^. factval)) facts))+ Right facts@(_:_) -> return (HM.fromList (map (\f -> (f ^. factInfoName, f ^. factInfoVal)) facts)) _ -> do rawFacts <- fmap concat (sequence [factNET, factRAM, factOS, fversion, factMountPoints, factOS, factUser, factUName, fenv, factProcessor]) let ofacts = genFacts $ map (T.pack *** T.pack) rawFacts
Hiera/Server.hs view
@@ -14,7 +14,7 @@ startHiera , dummyHiera , hieraLoggerName- -- * Re-export (query API)+ -- * Query API , HieraQueryFunc ) where @@ -31,7 +31,7 @@ import qualified Data.FileCache as F import qualified Data.HashMap.Strict as HM import qualified Data.List as L-import Data.Maybe (fromMaybe)+import Data.Maybe (fromMaybe, catMaybes) import qualified Data.Text as T import qualified Data.Vector as V import qualified Data.Yaml as Y@@ -121,28 +121,29 @@ -- | The combinator for "normal" queries queryCombinator :: HieraQueryType -> [IO (Maybe PValue)] -> IO (Maybe PValue)-queryCombinator Priority = foldr (liftA2 mplus) (pure mzero)-queryCombinator ArrayMerge = fmap rejoin . sequence- where- rejoin = Just . PArray . V.concat . map toA- toA Nothing = V.empty- toA (Just (PArray r)) = r- toA (Just a) = V.singleton a-queryCombinator HashMerge = fmap (Just . PHash . mconcat . map toH) . sequence+queryCombinator qt = fmap (createOutput . catMaybes) . sequence where- toH Nothing = mempty- toH (Just (PHash h)) = h- toH _ = error "The hiera value was not a hash"+ createOutput :: [PValue] -> Maybe PValue+ createOutput [] = Nothing+ createOutput xs = case qt of+ Priority -> return (head xs)+ ArrayMerge -> return (rejoin xs)+ HashMerge -> PHash . mconcat <$> mapM toH xs+ rejoin = PArray . V.fromList . L.nub . concatMap toA+ toA (PArray r) = V.toList r+ toA a = [a]+ toH (PHash h) = Just h+ toH _ = Nothing interpolateText :: Container T.Text -> T.Text -> T.Text interpolateText vars t = fromMaybe t ((parseInterpolableString t ^? _Right) >>= resolveInterpolable vars) resolveInterpolable :: Container T.Text -> [HieraStringPart] -> Maybe T.Text resolveInterpolable vars = fmap T.concat . mapM resolvePart- where- resolvePart :: HieraStringPart -> Maybe T.Text- resolvePart (HString x) = Just x- resolvePart (HVariable v) = vars ^. at v+ where+ resolvePart :: HieraStringPart -> Maybe T.Text+ resolvePart (HString x) = Just x+ resolvePart (HVariable v) = vars ^. at v interpolatePValue :: Container T.Text -> PValue -> PValue interpolatePValue v (PHash h) = PHash . HM.fromList . map ( (_1 %~ interpolateText v) . (_2 %~ interpolatePValue v) ) . HM.toList $ h
Puppet/Daemon.hs view
@@ -2,7 +2,9 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} module Puppet.Daemon (- initDaemon+ Daemon(..)+ , initDaemon+ -- * Utils , checkError -- * Re-exports , module Puppet.Interpreter.Types@@ -11,10 +13,9 @@ import Control.Exception import Control.Exception.Lens-import qualified Control.Lens as L-import Control.Lens.Operators+import Control.Lens hiding (Strict) import qualified Data.Either.Strict as S-import Data.FileCache+import Data.FileCache as FileCache import qualified Data.HashMap.Strict as HM import qualified Data.Text as T import qualified Data.Text.IO as T@@ -45,54 +46,66 @@ import Puppet.Stats import Puppet.Utils -{-| This is a high level function, that will initialize the parsing and-interpretation infrastructure from the 'Preferences', and will return 'DaemonMethods'.-From there, you have access to 'getCatalog', a function that take a node name,-and the 'Facts' to return the result of the catalog computation. 'DaemonMethods' also returns-a few IO functions that can be used to query for statistics (see "Puppet.Stats").+{-| API for the Daemon.+The main method is `getCatalog`: given a node and a list of facts, it returns the result of the compilation.+This will be either an error, or a tuple containing:+- all the resources in this catalog+- the dependency map+- the exported resources+- a list of known resources, that might not be up to date, but are here for code coverage tests. -It will internaly initialize a thread for the LUA interpreter, and a thread for the Ruby one.+Notes :++* It might be buggy when top level statements that are not class\/define\/nodes+are altered, or when files loaded with require are changed.+* The catalog is not computed exactly the same way Puppet does. Some good practices are enforced, particularly in strict mode.+For instance, unknown variables are always an error. Querying a dictionary with a non existent key returns undef in puppet, whereas it would throw an error in strict mode.+-}+data Daemon = Daemon+ { getCatalog :: NodeName -> Facts -> IO (S.Either PrettyError (FinalCatalog, EdgeMap, FinalCatalog, [Resource]))+ , parserStats :: MStats+ , catalogStats :: MStats+ , templateStats :: MStats+ }++{-| Entry point to get a Daemon+It will initialize the parsing and interpretation infrastructure from the 'Preferences'.++Internally it initializes a thread for the LUA interpreter, and a thread for the Ruby one. It should cache the AST of every .pp file, and could use a bit of memory. As a comparison, it fits in 60 MB with the author's manifests, but really breathes when given 300 MB of heap space. In this configuration, even if it spawns a ruby process for every template evaluation, it is way faster than the puppet stack. -It can optionnaly talk with PuppetDB, by setting an URL via the 'prefPDB'.+It can optionally talk with PuppetDB, by setting an URL via the 'prefPDB'. The recommended way to set it to http://localhost:8080 and set a SSH tunnel : > ssh -L 8080:localhost:8080 puppet.host--Canveats :--* It might be buggy when top level statements that are not class\/define\/nodes-are altered, or when files loaded with require are changed.--* The catalog is not computed exactly the same way Puppet does. Some good practices are enforced, particularly in strict mode.-For instance, unknown variables are always an error. Querying a dictionary with a non existent key returns undef in puppet, whereas it would throw an error in strict mode.- -}-initDaemon :: Preferences IO -> IO DaemonMethods-initDaemon prefs = do- setupLogger (prefs ^. prefLogLevel)+initDaemon :: Preferences IO -> IO Daemon+initDaemon pref0 = do+ setupLogger (pref0 ^. prefLogLevel) logDebug "initDaemon" traceEventIO "initDaemon"- templateStats <- newStats- parserStats <- newStats- catalogStats <- newStats- pfilecache <- newFileCache- intr <- startRubyInterpreter- hquery <- case prefs ^. prefHieraPath of- Just p -> either error id <$> startHiera p- Nothing -> return dummyHiera- luacontainer <- initLuaMaster (T.pack (prefs ^. prefPuppetPaths.modulesPath))- let myprefs = prefs & prefExtFuncs %~ HM.union luacontainer- getStatements = parseFunction myprefs pfilecache parserStats- getTemplate <- initTemplateDaemon intr myprefs templateStats- return (DaemonMethods (gCatalog myprefs getStatements getTemplate catalogStats hquery) parserStats catalogStats templateStats)+ luacontainer <- initLuaMaster (T.pack (pref0 ^. prefPuppetPaths.modulesPath))+ let pref = pref0 & prefExtFuncs %~ HM.union luacontainer+ hquery <- case pref ^. prefHieraPath of+ Just p -> either error id <$> startHiera p+ Nothing -> return dummyHiera+ fcache <- newFileCache+ intr <- startRubyInterpreter+ templStats <- newStats+ getTemplate <- initTemplateDaemon intr pref templStats+ catStats <- newStats+ parseStats <- newStats+ return (Daemon+ (getCatalog' pref (parseFunc (pref ^. prefPuppetPaths) fcache parseStats) getTemplate catStats hquery)+ parseStats+ catStats+ templStats+ ) --- Public utils func to work with the daemon --- -- | In case of a Left value, print the error and exit immediately checkError :: Show e => Doc -> Either e a -> IO a checkError desc = either exit return@@ -101,73 +114,73 @@ display err = red desc <> ": " <+> (string . show) err --- Some utils func internal to this module --+-- Internal functions -gCatalog :: Preferences IO+getCatalog' :: Preferences IO -> ( TopLevelType -> T.Text -> IO (S.Either PrettyError Statement) ) -> (Either T.Text T.Text -> InterpreterState -> InterpreterReader IO -> IO (S.Either PrettyError T.Text)) -> MStats -> HieraQueryFunc IO- -> Nodename+ -> NodeName -> Facts -> IO (S.Either PrettyError (FinalCatalog, EdgeMap, FinalCatalog, [Resource]))-gCatalog prefs getStatements getTemplate stats hquery node facts = do+getCatalog' pref parsingfunc getTemplate stats hquery node facts = do logDebug ("Received query for node " <> node)- traceEventIO ("START gCatalog " <> T.unpack node)- let catalogComputation = getCatalog (InterpreterReader- (prefs ^. prefNatTypes)- getStatements- getTemplate- (prefs ^. prefPDB)- (prefs ^. prefExtFuncs)- node- hquery- defaultImpureMethods- (prefs ^. prefIgnoredmodules)- (prefs ^. prefExternalmodules)- (prefs ^. prefStrictness == Strict)- (prefs ^. prefPuppetPaths)- )- node- facts- (prefs ^. prefPuppetSettings)+ traceEventIO ("START getCatalog' " <> T.unpack node)+ let catalogComputation = interpretCatalog (InterpreterReader+ (pref ^. prefNatTypes)+ parsingfunc+ getTemplate+ (pref ^. prefPDB)+ (pref ^. prefExtFuncs)+ node+ hquery+ defaultImpureMethods+ (pref ^. prefIgnoredmodules)+ (pref ^. prefExternalmodules)+ (pref ^. prefStrictness == Strict)+ (pref ^. prefPuppetPaths)+ )+ node+ facts+ (pref ^. prefPuppetSettings) (stmts :!: warnings) <- measure stats node catalogComputation mapM_ (\(p :!: m) -> LOG.logM daemonLoggerName p (displayS (renderCompact (ttext node <> ":" <+> m)) "")) warnings- traceEventIO ("STOP gCatalog " <> T.unpack node)- if prefs ^. prefExtraTests+ traceEventIO ("STOP getCatalog' " <> T.unpack node)+ if pref ^. prefExtraTests then runOptionalTests stmts else return stmts where- runOptionalTests stm = case stm^?S._Right.L._1 of- Nothing -> return stm- (Just c) -> catching _PrettyError- (do {testCatalog prefs c; return stm})+ runOptionalTests stm = case stm ^? S._Right._1 of+ Nothing -> return stm+ (Just c) -> catching _PrettyError+ (do {testCatalog pref c; return stm}) (return . S.Left) -parseFunction :: Preferences IO -> FileCache (V.Vector Statement) -> MStats -> TopLevelType -> T.Text -> IO (S.Either PrettyError Statement)-parseFunction prefs filecache stats topleveltype toplevelname =- case compileFileList prefs topleveltype toplevelname of- S.Left rr -> return (S.Left rr)- S.Right fname -> do+-- | Return an HOF that would parse the file associated with a toplevel.+-- The toplevel is defined by the tuple (type, name)+-- The result of the parsing is a single Statement (which recursively contains others statements)+parseFunc :: PuppetDirPaths -> FileCache (V.Vector Statement) -> MStats -> TopLevelType -> T.Text -> IO (S.Either PrettyError Statement)+parseFunc ppath filecache stats = \toptype topname ->+ let nameparts = T.splitOn "::" topname in+ let topLevelFilePath :: TopLevelType -> T.Text -> Either PrettyError T.Text+ topLevelFilePath TopNode _ = Right $ T.pack (ppath^.manifestPath <> "/site.pp")+ topLevelFilePath _ name+ | length nameparts == 1 = Right $ T.pack (ppath^.modulesPath) <> "/" <> name <> "/manifests/init.pp"+ | null nameparts = Left $ PrettyError ("Invalid toplevel" <+> squotes (ttext name))+ | otherwise = Right $ T.pack (ppath^.modulesPath) <> "/" <> head nameparts <> "/manifests/" <> T.intercalate "/" (tail nameparts) <> ".pp"+ in+ case topLevelFilePath toptype topname of+ Left rr -> return (S.Left rr)+ Right fname -> do let sfname = T.unpack fname handleFailure :: SomeException -> IO (S.Either String (V.Vector Statement)) handleFailure e = return (S.Left (show e))- x <- measure stats fname (query filecache sfname (parseFile sfname `catch` handleFailure))+ x <- measure stats fname (FileCache.query filecache sfname (parseFile sfname `catch` handleFailure)) case x of- S.Right stmts -> filterStatements topleveltype toplevelname stmts+ S.Right stmts -> filterStatements toptype topname stmts S.Left rr -> return (S.Left (PrettyError (red (text rr)))) --- TODO this is wrong, see--- http://docs.puppetlabs.com/puppet/3/reference/lang_namespaces.html#behavior-compileFileList :: Preferences IO -> TopLevelType -> T.Text -> S.Either PrettyError T.Text-compileFileList prefs TopNode _ = S.Right (T.pack (prefs ^. prefPuppetPaths.manifestPath) <> "/site.pp")-compileFileList prefs _ name = moduleInfo- where- moduleInfo | length nameparts == 1 = S.Right (mpath <> "/" <> name <> "/manifests/init.pp")- | null nameparts = S.Left "no name parts, error in compilefilelist"- | otherwise = S.Right (mpath <> "/" <> head nameparts <> "/manifests/" <> T.intercalate "/" (tail nameparts) <> ".pp")- mpath = T.pack (prefs ^. prefPuppetPaths.modulesPath)- nameparts = T.splitOn "::" name parseFile :: FilePath -> IO (S.Either String (V.Vector Statement)) parseFile fname = do@@ -178,7 +191,6 @@ Left rr -> traceEventIO ("Stopped parsing " ++ fname ++ " (failure: " ++ show rr ++ ")") >> return (S.Left (show rr)) traceEventIO ("STOP parsing " ++ fname) return o- daemonLoggerName :: String daemonLoggerName = "Puppet.Daemon"
Puppet/Interpreter.hs view
@@ -2,22 +2,13 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} module Puppet.Interpreter- ( getCatalog+ ( interpretCatalog+ , evaluateStatement+ , computeCatalog ) where -import Puppet.Interpreter.PrettyPrinter (containerComma)-import Puppet.Interpreter.Resolve-import Puppet.Interpreter.Types-import Puppet.Interpreter.IO-import Puppet.Lens-import Puppet.NativeTypes-import Puppet.Parser.PrettyPrinter-import Puppet.Parser.Types-import Puppet.PP-import Puppet.Utils- import Control.Applicative-import Control.Lens+import Control.Lens hiding (ignored) import Control.Monad.Except import Control.Monad.Operational hiding (view) import Control.Monad.Trans.Except@@ -31,6 +22,7 @@ import qualified Data.Maybe.Strict as S import Data.Ord (comparing) import Data.Semigroup (Max(..))+import Data.Text (Text) import qualified Data.Text as T import Data.Traversable (for) import qualified Data.Tree as T@@ -38,23 +30,18 @@ import qualified Data.Vector as V import System.Log.Logger --- helpers-vmapM :: (Monad m, Foldable t) => (a -> m b) -> t a -> m [b]-vmapM f = mapM f . toList--normalizeRIdentifier :: T.Text -> T.Text -> RIdentifier-normalizeRIdentifier t = RIdentifier rt- where- rt = fromMaybe t (T.stripPrefix "::" t)--getModulename :: RIdentifier -> T.Text-getModulename (RIdentifier t n) =- let gm x = case T.splitOn "::" x of- [] -> x- (y:_) -> y- in case t of- "class" -> gm n- _ -> gm t+import Puppet.Interpreter.PrettyPrinter (containerComma)+import Puppet.Interpreter.Resolve+import Puppet.Interpreter.Types+import Puppet.Interpreter.Utils+import Puppet.Interpreter.IO+import Puppet.Lens+import Puppet.NativeTypes+import Puppet.Parser.PrettyPrinter+import Puppet.Parser.Types+import Puppet.Parser.Utils+import Puppet.PP+import Puppet.Utils {-| Call the operational 'interpretMonad' function to compute the catalog.@@ -66,17 +53,17 @@ 'InterpreterState' and might not be up to date. There are only useful for coverage testing (checking dependencies for instance). -}-getCatalog :: (Functor m, Monad m)+interpretCatalog :: (Functor m, Monad m) => InterpreterReader m -- ^ The whole environment required for computing catalog.- -> Nodename+ -> NodeName -> Facts- -> Container T.Text -- ^ Server settings+ -> Container Text -- ^ Server settings -> m (Pair (S.Either PrettyError (FinalCatalog, EdgeMap, FinalCatalog, [Resource])) [Pair Priority Doc])-getCatalog interpretReader node facts settings = do+interpretCatalog interpretReader node facts settings = do (output, _, warnings) <- interpretMonad interpretReader (initialState facts settings) (computeCatalog node) return (strictifyEither output :!: warnings) -isParent :: T.Text -> CurContainerDesc -> InterpreterMonad Bool+isParent :: Text -> CurContainerDesc -> InterpreterMonad Bool isParent cur (ContClass possibleparent) = preuse (scopes . ix cur . scopeParent) >>= \case Nothing -> throwPosError ("Internal error: could not find scope" <+> ttext cur <+> "possible parent" <+> ttext possibleparent) Just S.Nothing -> return False@@ -85,14 +72,14 @@ else isParent p (ContClass possibleparent) isParent _ _ = return False +-- | Apply resource defaults, references overrides and expand defines finalize :: [Resource] -> InterpreterMonad [Resource]-finalize rlist = do- -- step 1, apply defaults+finalize rx = do scp <- getScopeName- defs <- use (scopes . ix scp . scopeDefaults)+ resdefaults <- use (scopes . ix scp . scopeResDefaults) let getOver = use (scopes . ix scp . scopeOverrides) -- retrieves current overrides- addDefaults r = ifoldlM (addAttribute CantReplace) r thisresdefaults- where thisresdefaults = defs ^. ix (r ^. rid . itype) . defValues+ addResDefaults r = ifoldlM (addAttribute CantReplace) r resdefval+ where resdefval = resdefaults ^. ix (r ^. rid . itype) . resDefValues addOverrides r = getOver >>= foldlM addOverrides' r . view (at (r ^. rid)) addOverrides' r (ResRefOverride _ prms p) = do -- we used this override, so we discard it@@ -114,12 +101,12 @@ then return 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- withDefaults <- mapM (addOverrides >=> addDefaults) rlist+ -- step 1, apply resDefaults and resRefOverride+ withDefaults <- mapM (addOverrides >=> addResDefaults) rx -- There might be some overrides that could not be applied. The only -- valid reason is that they override something in exported resources. --- -- This will probably do something unexpected on defines, but let's do- -- it that way for now.+ -- it probably do something unexpected on defines, but let's keep it that way for now. let keepforlater (ResRefOverride resid resprms ropos) = resMod %= (appended : ) where appended = ResourceModifier (resid ^. itype) ModifierMustMatch DontRealize (REqualitySearch "title" (PString (resid ^. iname))) overrider ropos@@ -135,40 +122,77 @@ if n || r ^. rvirtuality /= Normal then return [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+ -- be affected. concat <$> mapM expandableDefine withDefaults--popScope :: InterpreterMonad ()-popScope = curScope %= tail--pushScope :: CurContainerDesc -> InterpreterMonad ()-pushScope s = curScope %= (s :)--evalTopLevel :: Statement -> InterpreterMonad ([Resource], Statement)-evalTopLevel (TopContainer tops s) = do- pushScope ContRoot- r <- vmapM evaluateStatement tops >>= finalize . concat- -- popScope- (nr, ns) <- evalTopLevel s- popScope- return (r <> nr, ns)-evalTopLevel x = return ([], x)+ where+ expandDefine :: Resource -> InterpreterMonad [Resource]+ expandDefine r = do+ let deftype = dropInitialColons (r ^. rid . itype)+ defname = r ^. rid . iname+ modulename = getModulename (r ^. rid)+ 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)+ link <- toList linkset+ return (LinkInformation (r ^. rid) dstid link 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+ ignored <- isIgnoredModule modulename+ out <- if ignored+ then return mempty+ else do+ 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+ finalize (spurious ++ res)+ when isImportedDefine popScope+ popScope+ return out -getstt :: TopLevelType -> T.Text -> InterpreterMonad ([Resource], Statement)-getstt topleveltype toplevelname =- -- check if this is a known class (spurious or inner class)- use (nestedDeclarations . at (topleveltype, toplevelname)) >>= \case+-- | Given a toplevel (type, name),+-- return the associated parsed statement together with its evaluated resources+interpretTopLevel :: TopLevelType -> Text -> InterpreterMonad ([Resource], Statement)+interpretTopLevel toptype topname =+ -- check if this is a known toplevel+ use (nestedDeclarations . at (toptype, topname)) >>= \case Just x -> return ([], x) -- it is known !- Nothing -> singleton (GetStatement topleveltype toplevelname) >>= evalTopLevel--extractPrism :: Prism' a b -> Doc -> a -> InterpreterMonad b-extractPrism p t a = case preview p a of- Just b -> return b- Nothing -> throwPosError ("Could not extract prism in " <> t)+ 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) -computeCatalog :: Nodename -> InterpreterMonad (FinalCatalog, EdgeMap, FinalCatalog, [Resource])-computeCatalog ndename = do- (restop, node') <- getstt TopNode ndename- node <- extractPrism _Node' "computeCatalog" node'+-- | 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 [] finalStep allres = do -- collect stuff and apply thingies@@ -179,9 +203,18 @@ -- replace the modified stuff let res = foldl' (\curm e -> curm & at (e ^. rid) ?~ e) realized refinalized return (toList res)- mainstage = Resource (RIdentifier "stage" "main") mempty mempty mempty [ContRoot] Normal mempty dummypos ndename- resnode <- evaluateNode node >>= finalStep . (++ (mainstage : restop))- let (real :!: exported) = foldl' classify (mempty :!: mempty) resnode++ mainstage = Resource (RIdentifier "stage" "main") mempty mempty mempty [ContRoot] Normal mempty dummyppos nodename++ evaluateNode :: NodeDecl -> InterpreterMonad [Resource]+ evaluateNode (NodeDecl _ sx inheritnode p) = do+ curPos .= p+ pushScope ContRoot+ unless (S.isNothing inheritnode) $ throwPosError "Node inheritance is not handled yet, and will probably never be"+ mapM evaluateStatement sx >>= finalize . concat++ noderes <- evaluateNode nd >>= finalStep . (++ (mainstage : topres))+ let (real :!: exported) = foldl' classify (mempty :!: mempty) noderes -- Classify sorts resources between exported and normal ones. It -- drops virtual resources, and puts in both categories resources -- that are at the same time exported and realized.@@ -195,14 +228,14 @@ Exported -> curr :!: i cure ExportedRealized -> i curr :!: i cure _ -> curr :!: cure- verified <- ifromList . map (\r -> (r ^. rid, r)) <$> mapM validateNativeType (toList real)- mp <- makeEdgeMap verified+ verified <- HM.fromList . map (\r -> (r ^. rid, r)) <$> mapM validateNativeType (HM.elems real)+ edgemap <- makeEdgeMap verified definedRes <- use definedResources- return (verified, mp, exported, HM.elems definedRes)+ return (verified, edgemap, exported, HM.elems definedRes) makeEdgeMap :: FinalCatalog -> InterpreterMonad EdgeMap makeEdgeMap ct = do- -- merge the looaded classes and resources+ -- merge the loaded classes and resources defs' <- HM.map (view rpos) <$> use definedResources clss' <- use loadedClasses let defs = defs' <> classes' <> aliases' <> names'@@ -210,7 +243,7 @@ -- generate fake resources for all extra aliases aliases' = ifromList $ do r <- ct ^.. traversed :: [Resource]- extraAliases <- r ^.. ralias . folded . filtered (/= r ^. rid . iname) :: [T.Text]+ extraAliases <- r ^.. ralias . folded . filtered (/= r ^. rid . iname) :: [Text] return (r ^. rid & iname .~ extraAliases, r ^. rpos) classes' = ifromList $ do (cn, _ :!: cp) <- itoList clss'@@ -247,8 +280,8 @@ checkResDef (ri, lifs) = do let checkExists r msg = do let modulename = getModulename r- ign <- singleton (IsIgnoredModule modulename)- unless (has (ix r) defs || ign) (throwPosError msg)+ ignored <- isIgnoredModule modulename+ unless (has (ix r) defs || ignored) (throwPosError msg) errmsg = "Unknown resource" <+> pretty ri <+> "used in the following relationships:" <+> vcat (map pretty lifs) checkExists ri errmsg let genlnk :: LinkInformation -> InterpreterMonad RIdentifier@@ -268,8 +301,8 @@ mkp (a,_,links) = resdesc <+> lnks where resdesc = case ct ^. at a of- Just r -> pretty r- _ -> pretty a+ Just r -> pretty r+ _ -> pretty a lnks = pretty links throwPosError $ "Dependency error, the following resources are strongly connected!" </> trees -- let edgePairs = concatMap (\(_,k,ls) -> [(k,l) | l <- ls]) edgeList@@ -294,9 +327,9 @@ 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 -> return (r & rvirtuality .~ Normal))+ RealizeCollected -> (vcheck (`elem` [Exported, ExportedRealized]), \r -> return (r & rvirtuality .~ ExportedRealized))+ DontRealize -> (vcheck (`elem` [Normal, ExportedRealized]), return) 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)@@ -314,25 +347,17 @@ resMod .= [] return result -evaluateNode :: Nd -> InterpreterMonad [Resource]-evaluateNode (Nd _ stmts inheritance p) = do- curPos .= p- pushScope ContRoot- unless (S.isNothing inheritance) $ throwPosError "Node inheritance is not handled yet, and will probably never be"- vmapM evaluateStatement stmts >>= finalize . concat--evaluateStatementsFoldable :: Foldable f => f Statement -> InterpreterMonad [Resource]-evaluateStatementsFoldable = fmap concat . vmapM evaluateStatement---- | Converts a list of pairs into a container, checking there is no--- duplicate-fromArgumentList :: [Pair T.Text a] -> InterpreterMonad (Container a)-fromArgumentList = foldM insertArgument mempty+-- | Fold all attribute declarations+-- checking for duplicates key locally inside a same resource.+fromAttributeDecls :: V.Vector AttributeDecl -> InterpreterMonad (Container PValue)+fromAttributeDecls = foldM resolve mempty where- insertArgument curmap (k :!: v) =- case curmap ^. at k of+ resolve acc (AttributeDecl k _ v) =+ case acc ^. at k of Just _ -> throwPosError ("Parameter" <+> dullyellow (ttext k) <+> "already defined!")- Nothing -> return (curmap & at k ?~ v)+ Nothing -> do+ pv <- resolveExpression v+ return (acc & at k ?~ pv) evaluateStatement :: Statement -> InterpreterMonad [Resource] evaluateStatement r@(ClassDeclaration (ClassDecl cname _ _ _ _)) =@@ -345,7 +370,7 @@ else scp <> "::" <> cname nestedDeclarations . at (TopClass, rcname) ?= r return []-evaluateStatement r@(DefineDeclaration (DefineDec dname _ _ _)) =+evaluateStatement r@(DefineDeclaration (DefineDecl dname _ _ _)) = if "::" `T.isInfixOf` dname then nestedDeclarations . at (TopDefine, dname) ?= r >> return [] else do@@ -353,19 +378,19 @@ if scp == "::" then nestedDeclarations . at (TopDefine, dname) ?= r >> return [] else nestedDeclarations . at (TopDefine, scp <> "::" <> dname) ?= r >> return []-evaluateStatement r@(ResourceCollection (RColl e resType searchExp mods p)) = do+evaluateStatement r@(ResourceCollectionDeclaration (ResCollDecl ct rtype searchexp mods p)) = do curPos .= p- unless (fnull mods || e == Collector) (throwPosError ("It doesnt seem possible to amend attributes with an exported resource collector:" </> pretty r))- rsearch <- resolveSearchExpression searchExp- let et = case e of- Collector -> RealizeVirtual+ unless (isEmpty mods || ct == Collector) (throwPosError ("It doesnt seem possible to amend attributes with an exported resource collector:" </> pretty r))+ rsearch <- resolveSearchExpression searchexp+ let et = case ct of+ Collector -> RealizeVirtual ExportedCollector -> RealizeCollected- resMod %= (ResourceModifier resType ModifierCollector et rsearch return p : )- -- Now collectd from the PuppetDB !+ resMod %= (ResourceModifier rtype ModifierCollector et rsearch (\r' -> foldM modifyCollectedAttribute r' mods) p : )+ -- Now collected from the PuppetDB ! if et == RealizeCollected then do- let q = searchExpressionToPuppetDB resType rsearch- fqdn <- singleton GetNodeName+ let q = searchExpressionToPuppetDB rtype rsearch+ fqdn <- getNodeName -- we must filter the resources that originated from this host -- here ! They are also turned into "normal" resources res <- toListOf (folded@@ -379,26 +404,26 @@ popScope return o else return []-evaluateStatement (Dependency (Dep (t1 :!: n1) (t2 :!: n2) lt p)) = do+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 []-evaluateStatement (ResourceDeclaration (ResDec rt ern eargs virt p)) = do+evaluateStatement (ResourceDeclaration (ResDecl t ern eargs virt p)) = do curPos .= p resnames <- resolveExpressionStrings ern- args <- vmapM resolveArgument eargs >>= fromArgumentList- concat <$> mapM (\n -> registerResource rt n args virt p) resnames-evaluateStatement (MainFunctionCall (MFC funcname funcargs p)) = do+ args <- fromAttributeDecls eargs+ concat <$> mapM (\n -> registerResource t n args virt p) resnames+evaluateStatement (MainFunctionDeclaration (MainFuncDecl funcname funcargs p)) = do curPos .= p- vmapM resolveExpression funcargs >>= mainFunctionCall funcname-evaluateStatement (VariableAssignment (VarAss varname varexpr p)) = do+ mapM resolveExpression (toList funcargs) >>= mainFunctionCall funcname+evaluateStatement (VarAssignmentDeclaration (VarAssignDecl varname varexpr p)) = do curPos .= p varval <- resolveExpression varexpr loadVariable varname varval return []-evaluateStatement (ConditionalStatement (CondStatement conds p)) = do+evaluateStatement (ConditionalDeclaration (ConditionalDecl conds p)) = do curPos .= p let checkCond [] = return [] checkCond ((e :!: stmts) : xs) = do@@ -407,47 +432,59 @@ then evaluateStatementsFoldable stmts else checkCond xs checkCond (toList conds)-evaluateStatement (DefaultDeclaration (DefaultDec resType decls p)) = do+evaluateStatement (ResourceDefaultDeclaration (ResDefaultDecl rtype decls p)) = do curPos .= p- let resolveDefaultValue (prm :!: v) = (prm :!:) <$> resolveExpression v- rdecls <- vmapM resolveDefaultValue decls >>= fromArgumentList+ rdecls <- fromAttributeDecls decls scp <- getScopeName- -- invariant that must be respected : the current scope must me create+ -- invariant that must be respected : the current scope must be created -- in "scopes", or nothing gets saved- let newDefaults = ResDefaults resType scp rdecls p- addDefaults x = scopes . ix scp . scopeDefaults . at resType ?= x+ preuse (scopes . ix scp) >>= maybe (throwPosError ("INTERNAL ERROR in evaluateStatement ResourceDefaultDeclaration: scope wasn't created - " <> pretty scp)) (const (return ()))+ let newDefaults = ResDefaults rtype scp rdecls p+ addDefaults x = scopes . ix scp . scopeResDefaults . at rtype ?= x -- default merging with parent- mergedDefaults curdef = newDefaults & defValues .~ (rdecls <> (curdef ^. defValues))- preuse (scopes . ix scp . scopeDefaults . ix resType) >>= \case+ mergedDefaults curdef = newDefaults & resDefValues .~ (rdecls <> (curdef ^. resDefValues))+ preuse (scopes . ix scp . scopeResDefaults . ix rtype) >>= \case Nothing -> addDefaults newDefaults- Just de -> if de ^. defSrcScope == scp- then throwPosError ("Defaults for resource" <+> ttext resType <+> "already declared at" <+> showPPos (de ^. defPos))- else addDefaults (mergedDefaults de)+ Just d -> if d ^. resDefSrcScope == scp+ then throwPosError ("Defaults for resource" <+> ttext rtype <+> "already declared at" <+> showPPos (d ^. resDefPos))+ else addDefaults (mergedDefaults d) return []-evaluateStatement (ResourceOverride (ResOver rt urn eargs p)) = do+evaluateStatement (ResourceOverrideDeclaration (ResOverrideDecl t urn eargs p)) = do curPos .= p- raassignements <- vmapM resolveArgument eargs >>= fromArgumentList+ raassignements <- fromAttributeDecls eargs rn <- resolveExpressionString urn scp <- getScopeName curoverrides <- use (scopes . ix scp . scopeOverrides)- let rident = normalizeRIdentifier rt rn+ let rident = normalizeRIdentifier t rn -- check that we didn't already override those values withAssignements <- case curoverrides ^. at rident of Just (ResRefOverride _ prevass prevpos) -> do let cm = prevass `HM.intersection` raassignements- unless (fnull cm) (throwPosError ("The following parameters were already overriden at" <+> showPPos prevpos <+> ":" <+> containerComma cm))+ unless (isEmpty cm) (throwPosError ("The following parameters were already overriden at" <+> showPPos prevpos <+> ":" <+> containerComma cm)) return (prevass <> raassignements) Nothing -> return raassignements scopes . ix scp . scopeOverrides . at rident ?= ResRefOverride rident withAssignements p return []-evaluateStatement (SHFunctionCall (SFC c p)) = curPos .= p >> evaluateHFC c+evaluateStatement (HigherOrderLambdaDeclaration (HigherOrderLambdaDecl c p)) = curPos .= p >> evaluateHFC c+ where+ evaluateHFC :: HOLambdaCall -> InterpreterMonad [Resource]+ evaluateHFC hf = do+ varassocs <- hfGenerateAssociations 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) evaluateStatement r = throwError (PrettyError ("Do not know how to evaluate this statement:" </> pretty r)) ----------------------------------------------------------- -- Class evaluation ----------------------------------------------------------- -loadVariable :: T.Text -> PValue -> InterpreterMonad ()+loadVariable :: Text -> PValue -> InterpreterMonad () loadVariable varname varval = do curcont <- getCurContainer scp <- getScopeName@@ -477,7 +514,7 @@ -- -- It is able to fill unset parameters with values from Hiera (for classes -- only) or default values.-loadParameters :: Foldable f => Container PValue -> f (Pair T.Text (S.Maybe Expression)) -> PPosition -> S.Maybe T.Text -> InterpreterMonad ()+loadParameters :: Foldable f => Container PValue -> f (Pair Text (S.Maybe Expression)) -> PPosition -> S.Maybe T.Text -> InterpreterMonad () loadParameters params classParams defaultPos wHiera = do p <- use curPos curPos .= defaultPos@@ -504,7 +541,7 @@ checkDefault S.Nothing = throwE (Max False) checkDefault (S.Just expr) = lift (resolveExpression expr) - unless (fnull spuriousParams) $ throwPosError ("The following parameters are unknown:" <+> tupled (map (dullyellow . ttext) $ toList spuriousParams) <> mclassdesc)+ unless (isEmpty spuriousParams) $ throwPosError ("The following parameters are unknown:" <+> tupled (map (dullyellow . ttext) $ toList spuriousParams) <> mclassdesc) -- try to set a value to all parameters -- The order of evaluation is defined / hiera / default@@ -515,11 +552,7 @@ Left (Max True) -> loadVariable k PUndef >> return [] Left (Max False) -> return [k] curPos .= p- unless (fnull unsetParams) $ throwPosError ("The following mandatory parameters were not set:" <+> tupled (map ttext $ toList unsetParams) <> mclassdesc)--data ScopeEnteringContext = SENormal- | SEChild !T.Text -- ^ We enter the scope as the child of another class- | SEParent !T.Text -- ^ We enter the scope as the parent of another class+ unless (isEmpty unsetParams) $ throwPosError ("The following mandatory parameters were not set:" <+> tupled (map ttext $ toList unsetParams) <> mclassdesc) -- | Enters a new scope, checks it is not already defined, and inherits the -- defaults from the current scope@@ -529,9 +562,9 @@ -- expanding the defines without the defaults applied enterScope :: ScopeEnteringContext -> CurContainerDesc- -> T.Text+ -> Text -> PPosition- -> InterpreterMonad T.Text+ -> InterpreterMonad Text enterScope secontext cont modulename p = do let scopename = scopeName cont -- This is a special hack for inheritance, because at this time we@@ -555,7 +588,7 @@ let Just psc = parentscope return (psc & scopeParent .~ S.Just prt) _ -> do- curdefs <- use (scopes . ix scp . scopeDefaults)+ curdefs <- use (scopes . ix scp . scopeResDefaults) return $ 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)@@ -564,108 +597,62 @@ debug ("enterScope, scopename=" <> ttext scopename <+> "caller_module_name=" <> pretty curcaller <+> "module_name=" <> ttext modulename) return scopename -dropInitialColons :: T.Text -> T.Text-dropInitialColons t = fromMaybe t (T.stripPrefix "::" t)--expandDefine :: Resource -> InterpreterMonad [Resource]-expandDefine r = do- let deftype = dropInitialColons (r ^. rid . itype)- defname = r ^. rid . iname- modulename = getModulename (r ^. rid)- let 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)- link <- toList linkset- return (LinkInformation (r ^. rid) dstid link p)- extraRelations <>= extr- void $ enterScope SENormal curContType modulename p- (spurious, dls') <- getstt TopDefine deftype- DefineDec _ defineParams stmts cp <- extractPrism _DefineDeclaration' "expandDefine" dls'- let isImported (ContImported _) = True- isImported _ = False- isImportedDefine <- isImported <$> getScope- curPos .= r ^. rpos- curscp <- getScope- when isImportedDefine (pushScope (ContImport (r ^. rnode) curscp ))- pushScope curContType- imods <- singleton (IsIgnoredModule modulename)- out <- if imods- then return mempty- else do- 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- finalize (spurious ++ res)- when isImportedDefine popScope- popScope- return out---loadClass :: T.Text- -> S.Maybe T.Text -- ^ Set if this is an inheritance load, so that we can set calling module properly+loadClass :: Text+ -> S.Maybe Text -- ^ Set if this is an inheritance load, so that we can set calling module properly -> Container PValue -> ClassIncludeType -> InterpreterMonad [Resource]-loadClass rclassname loadedfrom params cincludetype = do- let classname = dropInitialColons rclassname- ndn <- singleton GetNodeName- singleton (TraceEvent ('[' : T.unpack ndn ++ "] loadClass " ++ T.unpack classname))+loadClass name loadedfrom params incltype = do+ let name' = dropInitialColons name+ ndn <- getNodeName+ singleton (TraceEvent ('[' : T.unpack ndn ++ "] loadClass " ++ T.unpack name')) p <- use curPos -- check if the class has already been loaded -- http://docs.puppetlabs.com/puppet/3/reference/lang_classes.html#using-resource-like-declarations- use (loadedClasses . at classname) >>= \case- Just (prv :!: pp) -> do- when ( (cincludetype == IncludeResource)- || (prv == IncludeResource)- )- (throwPosError ("Can't include class" <+> ttext classname <+> "twice when using the resource-like syntax (first occurence at" <+> showPPos pp <> ")"))+ use (loadedClasses . at name') >>= \case+ Just (loadedincltype :!: pp) -> do+ when ((incltype == ClassResourceLike) || (loadedincltype == ClassResourceLike)) $+ throwPosError ("Can't include class" <+> ttext name' <+> "twice when using the resource-like syntax (first occurence at"+ <+> showPPos pp <> ")")+ -- already loaded, go on return []- -- already loaded, go on Nothing -> do- loadedClasses . at classname ?= (cincludetype :!: p)- -- load the actual class, note we are not changing the current position- -- right now- (spurious, cls') <- getstt TopClass classname- ClassDecl _ classParams inh stmts cp <- extractPrism _ClassDeclaration' "loadClass" cls'+ loadedClasses . at name' ?= (incltype :!: p)+ -- 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 -- 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.Just ihname -> loadClass ihname (S.Just classname) mempty IncludeStandard- let !scopedesc = ContClass classname- modulename = getModulename (RIdentifier "class" classname)+ S.Just ihname -> loadClass ihname (S.Just name') mempty ClassIncludeLike+ let !scopedesc = ContClass name'+ modulename = getModulename (RIdentifier "class" 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- classresource <- if cincludetype == IncludeStandard+ classresource <- if incltype == ClassIncludeLike then do scp <- use curScope- fqdn <- singleton GetNodeName- return [Resource (RIdentifier "class" classname) (HS.singleton classname) mempty mempty scp Normal mempty p fqdn]+ fqdn <- getNodeName+ return [Resource (RIdentifier "class" name') (HS.singleton name') mempty mempty scp Normal mempty p fqdn] else return [] pushScope scopedesc- imods <- singleton (IsIgnoredModule modulename)- out <- if imods+ ignored <- isIgnoredModule modulename+ out <- if ignored then return mempty else do- loadVariable "title" (PString classname)- loadVariable "name" (PString classname)- loadParameters params classParams cp (S.Just classname)+ loadVariable "title" (PString name')+ loadVariable "name" (PString name')+ loadParameters params classParams cp (S.Just name') curPos .= cp res <- evaluateStatementsFoldable stmts finalize (classresource ++ spurious ++ inhstmts ++ res) popScope return out+ ----------------------------------------------------------- -- Resource stuff -----------------------------------------------------------@@ -678,10 +665,10 @@ addRelationship _ PUndef r = return r addRelationship _ notrr _ = throwPosError ("Expected a resource reference, not:" <+> pretty notrr) -addTagResource :: Resource -> T.Text -> Resource+addTagResource :: Resource -> Text -> Resource addTagResource r rv = r & rtags . contains rv .~ True -addAttribute :: OverrideType -> T.Text -> Resource -> PValue -> InterpreterMonad Resource+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@@ -693,37 +680,71 @@ addAttribute _ "notify" r d = addRelationship RNotify d r addAttribute _ "require" r d = addRelationship RRequire d r addAttribute _ "subscribe" r d = addRelationship RSubscribe d r-addAttribute b t r v = case (r ^. rattributes . at t, b) of- (_, Replace) -> return (r & rattributes . at t ?~ v)- (Nothing, _) -> return (r & rattributes . at t ?~ v)- (_, CantReplace) -> return r- (Just curval, _) -> do- -- we must check if the resource scope is- -- a parent of the current scope- curscope <- getScopeName- i <- isParent curscope (rcurcontainer r)- if i- then return (r & rattributes . at t ?~ v)- else do- -- We will not bark if the same attribute- -- is defined multiple times with distinct- -- values.- let errmsg = "Attribute" <+> dullmagenta (ttext t) <+> "defined multiple times for" <+> pretty r- if curval == v- then checkStrict errmsg errmsg- else throwPosError errmsg- return r+addAttribute b t r v = go t r v+ where+ go = case b of+ CantOverride -> setAttribute+ Replace -> overrideAttribute+ CantReplace -> defaultAttribute+ AppendAttribute -> appendAttribute -registerResource :: T.Text -> T.Text -> Container PValue -> Virtuality -> PPosition -> InterpreterMonad [Resource]+setAttribute :: Text -> Resource -> PValue -> InterpreterMonad Resource+setAttribute attributename res value = case res ^. rattributes . at attributename of+ Nothing -> return (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)+ else do+ -- We will not bark if the same attribute+ -- is defined multiple times with identical+ -- values.+ let errmsg = "Attribute" <+> dullmagenta (ttext attributename) <+> "defined multiple times for" <+> pretty res+ if curval == value+ then checkStrict errmsg errmsg+ else throwPosError errmsg+ return res++overrideAttribute :: Text -> Resource -> PValue -> InterpreterMonad Resource+overrideAttribute attributename res value = return (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)++defaultAttribute :: Text -> Resource -> PValue -> InterpreterMonad Resource+defaultAttribute attributename res value = return $ case res ^. rattributes . at attributename of+ Nothing -> res & rattributes . at attributename ?~ value+ Just _ -> res++modifyCollectedAttribute :: Resource -> AttributeDecl -> InterpreterMonad Resource+modifyCollectedAttribute res (AttributeDecl attributename arrowop expr) = do+ value <- resolveExpression expr+ let optype = case arrowop of+ AppendArrow -> AppendAttribute+ AssignArrow -> Replace+ addAttribute optype attributename res value++registerResource :: Text -> T.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)" registerResource "class" _ _ Exported p = curPos .= p >> throwPosError "Cannot declare an exported class (or perhaps you can, but I do not know what this means)"-registerResource rt rn arg vrt p = do+registerResource t rn arg vrt p = do curPos .= p CurContainer cnt tgs <- getCurContainer -- default tags -- http://docs.puppetlabs.com/puppet/3/reference/lang_tags.html#automatic-tagging -- http://docs.puppetlabs.com/puppet/3/reference/lang_tags.html#containment- let !defaulttags = {-# SCC "rrGetTags" #-} HS.fromList (rt : classtags) <> tgs+ let !defaulttags = {-# SCC "rrGetTags" #-} HS.fromList (t : classtags) <> tgs allsegs x = x : T.splitOn "::" x (!classtags, !defaultLink) = getClassTags cnt getClassTags (ContClass cn ) = (allsegs cn,RIdentifier "class" cn)@@ -733,17 +754,17 @@ getClassTags (ContImport _ _ ) = ([],RIdentifier "class" "::") defaultRelation = HM.singleton defaultLink (HS.singleton RRequire) allScope <- use curScope- fqdn <- singleton GetNodeName- let baseresource = Resource (normalizeRIdentifier rt rn) (HS.singleton rn) mempty defaultRelation allScope vrt defaulttags p fqdn+ fqdn <- getNodeName+ let baseresource = Resource (normalizeRIdentifier t rn) (HS.singleton rn) mempty defaultRelation allScope vrt defaulttags p fqdn r <- ifoldlM (addAttribute CantOverride) baseresource arg- let resid = normalizeRIdentifier rt rn- case rt of+ let resid = normalizeRIdentifier t rn+ case t of "class" -> {-# SCC "rrClass" #-} do definedResources . at resid ?= r let attrs = r ^. rattributes fmap (r:) $ loadClass rn S.Nothing attrs $ if HM.null attrs- then IncludeStandard- else IncludeResource+ then ClassIncludeLike+ else ClassResourceLike _ -> {-# SCC "rrGeneralCase" #-} use (definedResources . at resid) >>= \case Just otheres -> throwPosError ("Resource" <+> pretty resid <+> "already defined:" </>@@ -754,18 +775,10 @@ definedResources . at resid ?= r return [r] --- A helper function for the various loggers-logWithModifier :: Priority -> (Doc -> Doc) -> [PValue] -> InterpreterMonad [Resource]-logWithModifier prio m [t] = do- p <- use curPos- rt <- resolvePValueString t- logWriter prio (m (ttext rt) <+> showPPos p)- return []-logWithModifier _ _ _ = throwPosError "This function takes a single argument" -- functions : this can't really be exported as it uses a lot of stuff from -- this module ...-mainFunctionCall :: T.Text -> [PValue] -> InterpreterMonad [Resource]+mainFunctionCall :: Text -> [PValue] -> InterpreterMonad [Resource] mainFunctionCall "showscope" _ = use curScope >>= warn . pretty >> return [] -- The logging functions mainFunctionCall "alert" a = logWithModifier ALERT red a@@ -780,26 +793,32 @@ where doContain e = do classname <- resolvePValueString e use (loadedClasses . at classname) >>= \case- Nothing -> loadClass classname S.Nothing mempty IncludeStandard+ Nothing -> loadClass classname S.Nothing mempty ClassIncludeLike Just _ -> return [] -- TODO check that this happened after class declaration mainFunctionCall "include" includes = concat <$> mapM doInclude includes where doInclude e = do classname <- resolvePValueString e- loadClass classname S.Nothing mempty IncludeStandard-mainFunctionCall "create_resources" [rtype, hs] = mainFunctionCall "create_resources" [rtype, hs, PHash mempty]-mainFunctionCall "create_resources" [PString rtype, PHash hs, PHash defs] = do+ loadClass classname S.Nothing mempty ClassIncludeLike+mainFunctionCall "create_resources" [t, hs] = mainFunctionCall "create_resources" [t, hs, PHash mempty]+mainFunctionCall "create_resources" [PString t, PHash hs, PHash defparams] = do+ let (ats, t') = T.span (== '@') t+ virtuality <- case T.length ats of+ 0 -> return Normal+ 1 -> return Virtual+ 2 -> return Exported+ _ -> throwPosError "Too many @'s" p <- use curPos- let genRes rname (PHash rargs) = registerResource rtype rname (rargs <> defs) Normal p+ let genRes rname (PHash rargs) = registerResource t' rname (rargs <> defparams) virtuality p genRes rname x = throwPosError ("create_resource(): the value corresponding to key" <+> ttext rname <+> "should be a hash, not" <+> pretty x) concat . HM.elems <$> itraverse genRes hs mainFunctionCall "create_resources" args = throwPosError ("create_resource(): expects between two and three arguments, of type [string,hash,hash], and not:" <+> pretty args) mainFunctionCall "ensure_packages" args = ensurePackages args mainFunctionCall "ensure_resource" args = ensureResource args mainFunctionCall "realize" args = do- p <- use curPos- let realiz (PResourceReference rt rn) = resMod %= (ResourceModifier rt ModifierMustMatch RealizeVirtual (REqualitySearch "title" (PString rn)) return p : )- realiz x = throwPosError ("realize(): all arguments must be resource references, not" <+> pretty x)- mapM_ realiz args+ pos <- use curPos+ let updateMod (PResourceReference t rn) = resMod %= (ResourceModifier t ModifierMustMatch RealizeVirtual (REqualitySearch "title" (PString rn)) return pos : )+ updateMod x = throwPosError ("realize(): all arguments must be resource references, not" <+> pretty x)+ mapM_ updateMod args return [] mainFunctionCall "tag" args = do scp <- getScopeName@@ -830,7 +849,7 @@ return [] mainFunctionCall fname args = do p <- use curPos- let representation = MainFunctionCall (MFC fname mempty p)+ 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) return []@@ -838,41 +857,47 @@ ensurePackages :: [PValue] -> InterpreterMonad [Resource] ensurePackages [packages] = ensurePackages [packages, PHash mempty] ensurePackages [PString p, x] = ensurePackages [ PArray (V.singleton (PString p)), x ]-ensurePackages [PArray packages, PHash defaults] = do+ensurePackages [PArray packages, PHash defparams] = do checkStrict "The use of the 'ensure_packages' function is a code smell." "The 'ensure_packages' function is not allowed in strict mode."- concat <$> for packages (resolvePValueString >=> ensureResource' "package" (HM.singleton "ensure" "present" <> defaults))+ concat <$> for packages (resolvePValueString >=> ensureResource' "package" (HM.singleton "ensure" "present" <> defparams)) ensurePackages [PArray _,_] = throwPosError "ensure_packages(): the second argument must be a hash." 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+-- Create the resource if it does not exist alreadyTakes a resource type, title, and a hash of attributes that describe the resource(s). ensureResource :: [PValue] -> InterpreterMonad [Resource]-ensureResource [PString tp, PString ttl, PHash params] = do+ensureResource [PString t, PString title, PHash params] = do checkStrict "The use of the 'ensure_resource' function is a code smell." "The 'ensure_resource' function is not allowed in strict mode."- ensureResource' tp params ttl-ensureResource [tp,ttl] = ensureResource [tp,ttl,PHash mempty]+ ensureResource' t params title+ensureResource [t,title] = ensureResource [t,title,PHash mempty] ensureResource [_, PString _, PHash _] = throwPosError "ensureResource(): The first argument must be a string." ensureResource [PString _, _, PHash _] = throwPosError "ensureResource(): The second argument must be a string." ensureResource [PString _, PString _, _] = throwPosError "ensureResource(): The thrid argument must be a hash." ensureResource _ = throwPosError "ensureResource(): expects 2 or 3 arguments." -ensureResource' :: T.Text -> HM.HashMap T.Text PValue -> T.Text -> InterpreterMonad [Resource]-ensureResource' tp params ttl = do- def <- has (ix (normalizeRIdentifier tp ttl)) <$> use definedResources- if def+ensureResource' :: Text -> HM.HashMap T.Text PValue -> T.Text -> InterpreterMonad [Resource]+ensureResource' t params title = do+ isdefined <- has (ix (normalizeRIdentifier t title)) <$> use definedResources+ if isdefined then return []- else use curPos >>= registerResource tp ttl params Normal+ else use curPos >>= registerResource t title params Normal --- Method stuff-evaluateHFC :: HFunctionCall -> InterpreterMonad [Resource]-evaluateHFC hf = do- varassocs <- hfGenerateAssociations hf- let runblock :: [(T.Text, PValue)] -> InterpreterMonad [Resource]- runblock assocs = do- saved <- hfSetvars assocs- res <- evaluateStatementsFoldable (hf ^. hfstatements)- hfRestorevars saved- return res- results <- mapM runblock varassocs- return (concat results)++-----------------------------------------------------------+-- Specific utils functions that depends on this modules+-----------------------------------------------------------++evaluateStatementsFoldable :: Foldable f => f Statement -> InterpreterMonad [Resource]+evaluateStatementsFoldable = fmap concat . mapM evaluateStatement . toList++-- A helper function for the various loggers+logWithModifier :: Priority -> (Doc -> Doc) -> [PValue] -> InterpreterMonad [Resource]+logWithModifier prio m [v] = do+ p <- use curPos+ v' <- resolvePValueString v+ logWriter prio (m (ttext v') <+> showPPos p)+ return []+logWithModifier _ _ _ = throwPosError "This function takes a single argument"
Puppet/Interpreter/IO.hs view
@@ -10,11 +10,6 @@ , interpretMonad ) where -import Puppet.Interpreter.PrettyPrinter ()-import Puppet.Interpreter.Types-import Puppet.Plugins ()-import Puppet.PP- import Control.Concurrent.MVar import Control.Exception import Control.Lens@@ -29,8 +24,13 @@ import GHC.Stack import qualified Scripting.Lua as Lua -defaultImpureMethods :: (Functor m, MonadIO m) => ImpureMethods m-defaultImpureMethods = ImpureMethods (liftIO currentCallStack)+import Puppet.Interpreter.PrettyPrinter ()+import Puppet.Interpreter.Types+import Puppet.Plugins ()+import Puppet.PP++defaultImpureMethods :: (Functor m, MonadIO m) => IoMethods m+defaultImpureMethods = IoMethods (liftIO currentCallStack) (liftIO . file) (liftIO . traceEventIO) (\c fname args -> liftIO (runlua c fname args))@@ -60,7 +60,7 @@ eval r s (a :>>= k) = let runInstr = interpretMonad r s . k -- run one instruction thpe = interpretMonad r s . throwPosError . getError- pdb = r^.pdbAPI+ pdb = r^.readerPdbApi strFail iof errf = iof >>= \case Left rr -> thpe (errf (string rr)) Right x -> runInstr x@@ -72,22 +72,22 @@ Right x -> runInstr x logStuff x c = (_3 %~ (x <>)) <$> c in case a of- IsStrict -> runInstr (r ^. isStrict)- ExternalFunction fname args -> case r ^. externalFunctions . at fname of+ IsStrict -> runInstr (r ^. readerIsStrict)+ ExternalFunction fname args -> case r ^. readerExternalFunc . at fname of Just fn -> interpretMonad r s ( fn args >>= k) Nothing -> thpe (PrettyError ("Unknown function: " <> ttext fname)) GetStatement topleveltype toplevelname- -> canFail ((r ^. getStatement) topleveltype toplevelname)- ComputeTemplate fn stt -> canFail ((r ^. computeTemplateFunction) fn stt r)+ -> canFail ((r ^. readerGetStatement) topleveltype toplevelname)+ ComputeTemplate fn stt -> canFail ((r ^. readerGetTemplate) fn stt r) WriterTell t -> logStuff t (runInstr ()) WriterPass _ -> thpe "WriterPass" WriterListen _ -> thpe "WriterListen"- PuppetPathes -> runInstr (r ^. ppathes)- GetNativeTypes -> runInstr (r ^. nativeTypes)+ PuppetPaths -> runInstr (r ^. readerPuppetPaths)+ GetNativeTypes -> runInstr (r ^. readerNativeTypes) ErrorThrow d -> return (Left d, s, mempty) ErrorCatch _ _ -> thpe "ErrorCatch"- GetNodeName -> runInstr (r ^. thisNodename)- HieraQuery scps q t -> canFail ((r ^. hieraQuery) scps q t)+ GetNodeName -> runInstr (r ^. readerNodename)+ HieraQuery scps q t -> canFail ((r ^. readerHieraQuery) scps q t) PDBInformation -> pdbInformation pdb >>= runInstr PDBReplaceCatalog w -> canFailE (replaceCatalog pdb w) PDBReplaceFacts fcts -> canFailE (replaceFacts pdb fcts)@@ -97,11 +97,11 @@ PDBGetNodes q -> canFailE (getNodes pdb q) PDBCommitDB -> canFailE (commitDB pdb) PDBGetResourcesOfNode nn q -> canFailE (getResourcesOfNode pdb nn q)- GetCurrentCallStack -> (r ^. ioMethods . imGetCurrentCallStack) >>= runInstr- ReadFile fls -> strFail ((r ^. ioMethods . imReadFile) fls) (const $ PrettyError ("No file found in " <> list (map ttext fls)))- TraceEvent e -> (r ^. ioMethods . imTraceEvent) e >>= runInstr- IsIgnoredModule m -> runInstr (r ^. ignoredModules . contains m)- IsExternalModule m -> runInstr (r ^. externalModules . contains m)- CallLua c fname args -> (r ^. ioMethods . imCallLua) c fname args >>= \case+ GetCurrentCallStack -> (r ^. readerIoMethods . ioGetCurrentCallStack) >>= runInstr+ ReadFile fls -> strFail ((r ^. readerIoMethods . ioReadFile) fls) (const $ PrettyError ("No file found in " <> list (map ttext fls)))+ TraceEvent e -> (r ^. readerIoMethods . ioTraceEvent) e >>= runInstr+ IsIgnoredModule m -> runInstr (r ^. readerIgnoredModules . contains m)+ IsExternalModule m -> runInstr (r ^. readerExternalModules . contains m)+ CallLua c fname args -> (r ^. readerIoMethods . ioCallLua) c fname args >>= \case Right x -> runInstr x Left rr -> thpe (PrettyError (string rr))
Puppet/Interpreter/PrettyPrinter.hs view
@@ -14,13 +14,14 @@ import qualified Data.HashMap.Strict as HM import qualified Data.HashSet as HS import Data.List+import Data.Text (Text) import qualified Data.Text as T import qualified Data.Vector as V import GHC.Exts import Data.Aeson (ToJSON, encode)-import Text.PrettyPrint.ANSI.Leijen ((<$>)) import Prelude hiding ((<$>))+import Text.PrettyPrint.ANSI.Leijen ((<$>)) containerComma'' :: Pretty a => [(Doc, a)] -> Doc containerComma'' x = indent 2 ins@@ -32,11 +33,14 @@ containerComma' = braces . containerComma'' containerComma :: Pretty a => Container a -> Doc-containerComma hm = containerComma' (map (\(a,b) -> (fill maxalign (ttext a), b)) hml)+containerComma hm = containerComma' (map (\(a,b) -> (fill maxalign (pretty a), b)) hml) where hml = HM.toList hm maxalign = maximum (map (T.length . fst) hml) +instance Pretty Text where+ pretty = ttext+ instance Pretty PValue where pretty (PBoolean True) = dullmagenta $ text "true" pretty (PBoolean False) = dullmagenta $ text "false"@@ -51,7 +55,6 @@ pretty TopNode = dullyellow (text "node") pretty TopDefine = dullyellow (text "define") pretty TopClass = dullyellow (text "class")- pretty TopSpurious = dullyellow (text "spurious") instance Pretty RIdentifier where pretty (RIdentifier t n) = pretty (PResourceReference t n)@@ -83,11 +86,16 @@ maxalign' [] = 0 maxalign' x = maximum . map (T.length . fst) $ x +resourceRelations :: Resource -> [(RIdentifier, LinkType)]+resourceRelations = concatMap expandSet . HM.toList . view rrelations+ where+ expandSet (ri, lts) = [(ri, lt) | lt <- HS.toList lts]+ instance Pretty Resource where prettyList lst =- let grouped = HM.toList $ HM.fromListWith (++) [ (r ^. rid . itype, [r]) | r <- lst ] :: [ (T.Text, [Resource]) ]+ let grouped = HM.toList $ HM.fromListWith (++) [ (r ^. rid . itype, [r]) | r <- lst ] :: [ (Text, [Resource]) ] sorted = sortWith fst (map (second (sortWith (view (rid.iname)))) grouped)- showGroup :: (T.Text, [Resource]) -> Doc+ showGroup :: (Text, [Resource]) -> Doc showGroup (rt, res) = dullyellow (ttext rt) <+> lbrace <$> indent 2 (vcat (map resourceBody res)) <$> rbrace in vcat (map showGroup sorted) pretty r = dullyellow (ttext (r ^. rid . itype)) <+> lbrace <$> indent 2 (resourceBody r) <$> rbrace@@ -104,6 +112,7 @@ instance Pretty ResourceModifier where pretty (ResourceModifier rt ModifierMustMatch RealizeVirtual (REqualitySearch "title" (PString x)) _ p) = "realize" <> parens (pretty (PResourceReference rt x)) <+> showPPos p+ -- pretty (ResourceModifier rt ModifierCollector ct (REqualitySearch _ (PString x)) _ p) = "collect" <> parens (pretty (PResourceReference rt x)) <+> showPPos p pretty _ = "TODO pretty ResourceModifier" instance Pretty RSearchExpression where@@ -120,7 +129,7 @@ showQuery = string . BSL.unpack . encode instance Pretty (InterpreterInstr a) where- pretty PuppetPathes = pf "PuppetPathes" []+ pretty PuppetPaths = pf "PuppetPathes" [] pretty IsStrict = pf "IsStrict" [] pretty GetNativeTypes = pf "GetNativeTypes" [] pretty (GetStatement tlt nm) = pf "GetStatement" [pretty tlt,ttext nm]
Puppet/Interpreter/Pure.hs view
@@ -7,31 +7,45 @@ -- > Right (PString "3") module Puppet.Interpreter.Pure where +import Control.Lens+import qualified Data.Either.Strict as S+import qualified Data.HashMap.Strict as HM+import qualified Data.Text as T+ import Erb.Evaluate import Erb.Parser import Puppet.Interpreter.IO import Puppet.Interpreter.Types+import Puppet.Interpreter.Utils import Puppet.NativeTypes import Puppet.Parser.Types-import Puppet.Pathes+import Puppet.Paths import Puppet.PP import PuppetDB.Dummy -import Control.Lens-import qualified Data.Either.Strict as S-import qualified Data.HashMap.Strict as HM-import qualified Data.Text as T -- | Worst name ever, this is a set of pure stub for the 'ImpureMethods' -- type.-impurePure :: ImpureMethods Identity-impurePure = ImpureMethods (return []) (const (return (Left "Can't read file"))) (\_ -> return ()) (\_ _ _ -> return (Left "Can't call lua"))+impurePure :: IoMethods Identity+impurePure = IoMethods (return []) (const (return (Left "Can't read file"))) (\_ -> return ()) (\_ _ _ -> return (Left "Can't call lua")) -- | 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, T.Text) Statement -- ^ A top-level statement map -> InterpreterReader Identity-pureReader sttmap = InterpreterReader baseNativeTypes getstatementdummy templatedummy dummyPuppetDB mempty "dummy" hieradummy impurePure mempty mempty True (defaultPathes "/etc/puppet")+pureReader sttmap = InterpreterReader+ baseNativeTypes+ getstatementdummy+ templatedummy+ dummyPuppetDB+ mempty+ "dummy"+ hieradummy+ impurePure+ mempty+ mempty+ True+ (puppetPaths "/etc/puppet") where templatedummy (Right _) _ _ = return (S.Left "Can't interpret files") templatedummy (Left cnt) stt _ = return $ case extractFromState stt of@@ -55,7 +69,6 @@ where startingState = initialState facts $ HM.fromList [ ("confdir", "/etc/puppet") ]- -- | A bunch of facts that can be used for pure evaluation. dummyFacts :: Facts
Puppet/Interpreter/Resolve.hs view
@@ -13,7 +13,6 @@ resolvePValueString, resolveExpressionString, resolveExpressionStrings,- resolveArgument, resolveFunction', runHiera, isNativeType,@@ -32,8 +31,9 @@ import Puppet.Interpreter.PrettyPrinter () import Puppet.Interpreter.RubyRandom import Puppet.Interpreter.Types+import Puppet.Interpreter.Utils import Puppet.Parser.Types-import Puppet.Pathes+import Puppet.Paths import Puppet.PP import Puppet.Utils @@ -49,6 +49,7 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Base16 as B16 import Data.CaseInsensitive (mk)+import Data.Char (isAlphaNum) import qualified Data.HashMap.Strict as HM import qualified Data.HashSet as HS import Data.Maybe (mapMaybe,fromMaybe)@@ -302,15 +303,15 @@ case (ra, rb) of (PArray ha, v) -> return (PArray (V.snoc ha v)) _ -> integerOperation a b (\x -> shiftL x . fromIntegral)-resolveExpression a@(FunctionApplication e (Terminal (UHFunctionCall hf))) = do- unless (S.isNothing (hf ^. hfexpr)) (throwPosError ("You can't combine chains of higher order functions (with .) and giving them parameters, in:" <+> pretty a))- resolveValue (UHFunctionCall (hf & hfexpr .~ S.Just e))+resolveExpression a@(FunctionApplication e (Terminal (UHOLambdaCall hol))) = do+ unless (S.isNothing (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)) resolveExpression (FunctionApplication _ x) = throwPosError ("Expected function application here, not" <+> pretty x) resolveExpression (Negate x) = PNumber . negate <$> resolveExpressionNumber x --- | Resolves an 'UValue' (terminal for the 'Expression' data type) into+-- | Resolves an 'UnresolvedValue' (terminal for the 'Expression' data type) into -- a 'PValue'-resolveValue :: UValue -> InterpreterMonad PValue+resolveValue :: UnresolvedValue -> InterpreterMonad PValue resolveValue (UNumber n) = return (PNumber n) resolveValue n@(URegexp _) = throwPosError ("Regular expressions are not allowed in this context: " <+> pretty n) resolveValue (UBoolean x) = return (PBoolean x)@@ -328,7 +329,7 @@ resPair (k :!: v) = (,) `fmap` resolveExpressionString k <*> resolveExpression v resolveValue (UVariableReference v) = resolveVariable v resolveValue (UFunctionCall fname args) = resolveFunction fname args-resolveValue (UHFunctionCall hf) = evaluateHFCPure hf+resolveValue (UHOLambdaCall hol) = evaluateHFCPure hol -- | Turns strings, numbers and booleans into 'T.Text', or throws an error. resolvePValueString :: PValue -> InterpreterMonad T.Text@@ -364,10 +365,6 @@ PArray a -> mapM resolvePValueString (V.toList a) y -> fmap return (resolvePValueString y) --- | A special helper function for argument like argument like pairs.-resolveArgument :: Pair T.Text Expression -> InterpreterMonad (Pair T.Text PValue)-resolveArgument (argname :!: argval) = (:!:) `fmap` pure argname <*> resolveExpression argval- -- | Turns a 'PValue' into a 'Bool', as explained in the reference -- documentation. pValue2Bool :: PValue -> Bool@@ -451,6 +448,21 @@ Right x -> fmap (PArray . V.fromList) (mapM (fmap PString . safeDecodeUtf8) x) resolveFunction' "sha1" [pstr] = fmap (PString . T.decodeUtf8 . B16.encode . sha1 . T.encodeUtf8) (resolvePValueString pstr) resolveFunction' "sha1" _ = throwPosError "sha1(): Expects a single argument"+resolveFunction' "shellquote" args = do+ sargs <- forM args $ \arg -> case arg of+ PArray vals -> mapM resolvePValueString vals+ _ -> V.singleton <$> resolvePValueString arg+ let escape str | T.all isSafe str = str+ | not (T.any isDangerous str) = between "\"" str+ | T.any (== '\'') str = between "\"" (T.concatMap escapeDangerous str)+ | otherwise = between "'" str+ isSafe x = isAlphaNum x || x `elem` ("@%_+=:,./-" :: String)+ isDangerous x = x `elem` ("!\"`$\\" :: String)+ escapeDangerous x | isDangerous x = T.snoc "\\" x+ | otherwise = T.singleton x+ between c s = c <> s <> c+ return $ PString $ T.unwords $ V.toList $ fmap escape $ mconcat sargs+ resolveFunction' "mysql_password" [pstr] = fmap (PString . T.decodeUtf8 . B16.encode . sha1 . sha1 . T.encodeUtf8) (resolvePValueString pstr) resolveFunction' "mysql_password" _ = throwPosError "mysql_password(): Expects a single argument" resolveFunction' "file" args = mapM (resolvePValueString >=> fixFilePath) args >>= fmap PString . singleton . ReadFile@@ -459,7 +471,7 @@ | T.head s == '/' = return s | otherwise = case T.splitOn "/" s of (md:x:rst) -> do- moduledir <- view modulesPath <$> getPuppetPathes+ moduledir <- view modulesPath <$> getPuppetPaths return (T.intercalate "/" (T.pack moduledir : md : "files" : x : rst)) _ -> throwPosError ("file() argument invalid: " <> ttext s) resolveFunction' "tagged" ptags = do@@ -575,13 +587,13 @@ -- | Generates variable associations for evaluation of blocks. Each item -- corresponds to an iteration in the calling block.-hfGenerateAssociations :: HFunctionCall -> InterpreterMonad [[(T.Text, PValue)]]-hfGenerateAssociations hf = do- sourceexpression <- case hf ^. hfexpr of+hfGenerateAssociations :: HOLambdaCall -> InterpreterMonad [[(T.Text, PValue)]]+hfGenerateAssociations hol = do+ sourceexpression <- case hol ^. hoLambdaExpr of S.Just x -> return x- S.Nothing -> throwPosError ("No expression to run the function on" <+> pretty hf)+ S.Nothing -> throwPosError ("No expression to run the function on" <+> pretty hol) sourcevalue <- resolveExpression sourceexpression- case (sourcevalue, hf ^. hfparams) of+ case (sourcevalue, hol ^. hoLambdaParams) of (PArray pr, BPSingle varname) -> return (map (\x -> [(varname, x)]) (V.toList pr)) (PArray pr, BPPair idx var) -> return $ do (i,v) <- Prelude.zip ([0..] :: [Int]) (V.toList pr)@@ -622,44 +634,44 @@ evalPureStatement :: Statement -> InterpreterMonad () evalPureStatement _ = throwPosError "So called 'pure' statements are not yet supported" --- | This extracts the final expression from an HFunctionCall.+-- | This extracts the final expression from an HOLambdaCall. -- When it does not exists, it checks if the last statement is in fact -- a function call-transformPureHf :: HFunctionCall -> InterpreterMonad (HFunctionCall, Expression)-transformPureHf hf =- case hf ^. hfexpression of- S.Just x -> return (hf, x)+transformPureHf :: HOLambdaCall -> InterpreterMonad (HOLambdaCall, Expression)+transformPureHf hol =+ case hol ^. hoLambdaLastExpr of+ S.Just x -> return (hol, x) S.Nothing -> do- let statements = hf ^. hfstatements+ let statements = hol ^. hoLambdaStatements if V.null statements- then throwPosError ("The statement block must not be empty" <+> pretty hf)+ then throwPosError ("The statement block must not be empty" <+> pretty hol) else case V.last statements of- (MainFunctionCall (MFC fn args _)) ->+ (MainFunctionDeclaration (MainFuncDecl fn args _)) -> let expr = Terminal (UFunctionCall fn args)- in return (hf & hfstatements %~ V.init- & hfexpression .~ S.Just expr+ in return (hol & hoLambdaStatements %~ V.init+ & hoLambdaLastExpr .~ S.Just expr , expr)- _ -> throwPosError ("The statement block must end with an expression" <+> pretty hf)+ _ -> throwPosError ("The statement block must end with an expression" <+> pretty hol) -- | All the "higher order function" stuff, for "value" mode. In this case -- we are in "pure" mode, and only a few statements are allowed.-evaluateHFCPure :: HFunctionCall -> InterpreterMonad PValue-evaluateHFCPure hf' = do- (hf, finalexpression) <- transformPureHf hf'- varassocs <- hfGenerateAssociations hf+evaluateHFCPure :: HOLambdaCall -> InterpreterMonad PValue+evaluateHFCPure hol' = do+ (hol, finalexpression) <- transformPureHf hol'+ varassocs <- hfGenerateAssociations hol let runblock :: [(T.Text, PValue)] -> InterpreterMonad PValue runblock assocs = do saved <- hfSetvars assocs- V.mapM_ evalPureStatement (hf ^. hfstatements)+ V.mapM_ evalPureStatement (hol ^. hoLambdaStatements) r <- resolveExpression finalexpression hfRestorevars saved return r- case hf ^. hftype of- HFEach -> throwPosError "The 'each' function can't be used at the value level in language-puppet. Please use map."- HFMap -> fmap (PArray . V.fromList) (mapM runblock varassocs)- HFFilter -> do+ 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 res <- mapM (fmap pValue2Bool . runblock) varassocs- sourcevalue <- case hf ^. hfexpr of+ sourcevalue <- case hol ^. hoLambdaExpr of S.Just x -> resolveExpression x S.Nothing -> throwPosError "Internal error evaluateHFCPure 1" case sourcevalue of
Puppet/Interpreter/Types.hs view
@@ -20,28 +20,26 @@ , RIdentifier(RIdentifier) , HasScopeInformation(..) , ScopeInformation(ScopeInformation)+ , ScopeEnteringContext(..) , HasResourceModifier(..) , ResourceModifier(ResourceModifier)- , HasImpureMethods(..)- , ImpureMethods(ImpureMethods)+ , HasIoMethods(..)+ , IoMethods(IoMethods) , HasCurContainer(..) , CurContainer(CurContainer) , HasNativeTypeMethods(..) , NativeTypeMethods(NativeTypeMethods)+ , NodeInfo(NodeInfo)+ , HasNodeInfo(..)+ , FactInfo(FactInfo)+ , HasFactInfo(..)+ , HasWireCatalog(..) -- ** Operational instructions , InterpreterInstr(..) , HasInterpreterReader(..) , InterpreterReader(InterpreterReader) , HasInterpreterState(..)- , InterpreterState- -- * Record & field lenses- , PNodeInfo(PNodeInfo)- , nodename- , PFactInfo(PFactInfo)- , factname- , wResources- , wEdges- , factval+ , InterpreterState(InterpreterState) -- * Sum types , PValue(..) , CurContainerDesc(..)@@ -58,7 +56,6 @@ , ResRefOverride(..) , ResourceField(..) , OverrideType(..)- , DaemonMethods(..) , ClassIncludeType(..) -- ** PuppetDB , PuppetEdge(PuppetEdge)@@ -69,7 +66,7 @@ , InterpreterWriter , FinalCatalog , NativeTypeValidate- , Nodename+ , NodeName , Container , HieraQueryFunc , Scope@@ -77,32 +74,9 @@ , EdgeMap -- * Classes , MonadThrowPos(..)- -- * Utils+ -- * definitions , metaparameters- , initialState- , getCurContainer- , text2Scientific- , safeDecodeUtf8- , getScope- , getScopeName- , getPuppetPathes- , scopeName- , resourceRelations- , checkStrict- , dummypos- , iinsertWith- , ikeys- , isingleton- , ifromListWith- , ifromList- , iunionWith , showPos- , fnull- , rcurcontainer- , logWriter- , warn- , debug- , eitherDocIO ) where import Control.Concurrent.MVar (MVar)@@ -115,18 +89,15 @@ import Control.Monad.Writer.Class import Data.Aeson as A import Data.Aeson.Lens-import Data.Attoparsec.Text (parseOnly, rational)-import qualified Data.ByteString as BS import qualified Data.Either.Strict as S-import qualified Data.Foldable as F import Data.Hashable import qualified Data.HashMap.Strict as HM import qualified Data.HashSet as HS-import Data.Maybe (fromMaybe) import qualified Data.Maybe.Strict as S import Data.Monoid import Data.Scientific import Data.String (IsString (..))+import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T import Data.Time.Clock@@ -143,16 +114,17 @@ import Puppet.Parser.PrettyPrinter import Puppet.Parser.Types-import Puppet.Pathes+import Puppet.Paths import Puppet.PP hiding (rational)-import Puppet.Stats+import Puppet.Utils -metaparameters :: HS.HashSet T.Text+metaparameters :: HS.HashSet Text metaparameters = HS.fromList ["tag","stage","name","title","alias","audit","check","loglevel","noop","schedule", "EXPORTEDSOURCE", "require", "before", "register", "notify"] -type Nodename = T.Text--type Container = HM.HashMap T.Text+type NodeName = Text+type Container = HM.HashMap Text+type Scope = Text+type Facts = Container PValue newtype PrettyError = PrettyError { getError :: Doc } @@ -168,55 +140,66 @@ instance Exception PrettyError --- | The intepreter can run in two modes : a strict mode (recommended), and--- a permissive mode. The permissive mode let known antipatterns work with--- the interpreter.-data Strictness = Strict | Permissive- deriving (Show, Eq) -instance FromJSON Strictness where- parseJSON (Bool True) = pure Strict- parseJSON (Bool False) = pure Permissive- parseJSON _ = mzero-- data PValue = PBoolean !Bool | PUndef- | PString !T.Text -- integers and doubles are internally serialized as strings by puppet- | PResourceReference !T.Text !T.Text+ | PString !Text -- integers and doubles are internally serialized as strings by puppet+ | PResourceReference !Text !T.Text | PArray !(V.Vector PValue) | PHash !(Container PValue) | PNumber !Scientific deriving (Eq, Show) +instance IsString PValue where+ fromString = PString . T.pack++instance AsNumber PValue where+ _Number = prism num2PValue toNumber+ where+ num2PValue :: Scientific -> PValue+ num2PValue = PNumber+ toNumber :: PValue -> Either PValue Scientific+ toNumber (PNumber n) = Right n+ toNumber p@(PString x) = case text2Scientific x of+ Just o -> Right o+ _ -> Left p+ toNumber p = Left p+ -- | The different kind of hiera queries data HieraQueryType = Priority -- ^ standard hiera query | ArrayMerge -- ^ hiera_array | HashMerge -- ^ hiera_hash -- | The type of the Hiera API function-type HieraQueryFunc m = Container T.Text -- ^ All the variables that Hiera can interpolate, the top level ones being prefixed with ::- -> T.Text -- ^ The query+type HieraQueryFunc m = Container Text -- ^ All the variables that Hiera can interpolate, the top level ones being prefixed with ::+ -> Text -- ^ The query -> HieraQueryType -> m (S.Either PrettyError (Maybe PValue)) -data RSearchExpression = REqualitySearch !T.Text !PValue- | RNonEqualitySearch !T.Text !PValue+-- | The intepreter can run in two modes : a strict mode (recommended), and+-- a permissive mode. The permissive mode let known antipatterns work with+-- the interpreter.+data Strictness = Strict | Permissive+ deriving (Show, Eq)++instance FromJSON Strictness where+ parseJSON (Bool True) = pure Strict+ parseJSON (Bool False) = pure Permissive+ parseJSON _ = mzero++data RSearchExpression = REqualitySearch !Text !PValue+ | RNonEqualitySearch !Text !PValue | RAndSearch !RSearchExpression !RSearchExpression | ROrSearch !RSearchExpression !RSearchExpression | RAlwaysTrue- deriving Eq--instance IsString PValue where- fromString = PString . T.pack+ deriving (Show, Eq) -data ClassIncludeType = IncludeStandard | IncludeResource+-- | Puppet has two main ways to declare classes: include-like and resource-like+-- https://docs.puppetlabs.com/puppet/latest/reference/lang_classes.html#include-like-vs-resource-like+data ClassIncludeType = ClassIncludeLike -- ^ using the include or contain function+ | ClassResourceLike -- ^ resource like declaration deriving (Eq) -type Scope = T.Text--type Facts = Container PValue- -- |This type is used to differenciate the distinct top level types that are -- exposed by the DSL. data TopLevelType@@ -226,47 +209,49 @@ | TopDefine -- |This is for classes. | TopClass- -- |This one is special. It represents top level statements that are not- -- part of a node, define or class. It is defined as spurious because it is- -- not what you are supposed to be. Also the caching system doesn't like- -- them too much right now.- | TopSpurious deriving (Generic,Eq) instance Hashable TopLevelType +-- | From the evaluation of Resource Default Declaration data ResDefaults = ResDefaults- { _defType :: !T.Text- , _defSrcScope :: !T.Text- , _defValues :: !(Container PValue)- , _defPos :: !PPosition+ { _resDefType :: !Text+ , _resDefSrcScope :: !Text+ , _resDefValues :: !(Container PValue)+ , _resDefPos :: !PPosition } +-- | From the evaluation of Resource Override Declaration+data ResRefOverride = ResRefOverride+ { _rrid :: !RIdentifier+ , _rrparams :: !(Container PValue)+ , _rrpos :: !PPosition+ } deriving (Eq)+ data CurContainerDesc = ContRoot -- ^ Contained at node or root level- | ContClass !T.Text -- ^ Contained in a class- | ContDefine !T.Text !T.Text !PPosition -- ^ Contained in a define, along with the position where this define was ... defined+ | ContClass !Text -- ^ Contained in a class+ | ContDefine !Text !T.Text !PPosition -- ^ Contained in a define, along with the position where this define was ... defined | ContImported !CurContainerDesc -- ^ Dummy container for imported resources, so that we know we must update the nodename- | ContImport !Nodename !CurContainerDesc -- ^ This one is used when finalizing imported resources, and contains the current node name+ | ContImport !NodeName !CurContainerDesc -- ^ This one is used when finalizing imported resources, and contains the current node name deriving (Eq, Generic, Ord, Show) +data ScopeEnteringContext = SENormal+ | SEChild !Text -- ^ We enter the scope as the child of another class+ | SEParent !Text -- ^ We enter the scope as the parent of another class++-- | TODO related to Scope: explain ... data CurContainer = CurContainer { _cctype :: !CurContainerDesc- , _cctags :: !(HS.HashSet T.Text)- } deriving (Eq)--data ResRefOverride = ResRefOverride- { _rrid :: !RIdentifier- , _rrparams :: !(Container PValue)- , _rrpos :: !PPosition+ , _cctags :: !(HS.HashSet Text) } deriving (Eq) data ScopeInformation = ScopeInformation- { _scopeVariables :: !(Container (Pair (Pair PValue PPosition) CurContainerDesc))- , _scopeDefaults :: !(Container ResDefaults)- , _scopeExtraTags :: !(HS.HashSet T.Text)- , _scopeContainer :: !CurContainer- , _scopeOverrides :: !(HM.HashMap RIdentifier ResRefOverride)- , _scopeParent :: !(S.Maybe T.Text)+ { _scopeVariables :: !(Container (Pair (Pair PValue PPosition) CurContainerDesc))+ , _scopeResDefaults :: !(Container ResDefaults)+ , _scopeExtraTags :: !(HS.HashSet Text)+ , _scopeContainer :: !CurContainer+ , _scopeOverrides :: !(HM.HashMap RIdentifier ResRefOverride)+ , _scopeParent :: !(S.Maybe Text) } data InterpreterState = InterpreterState@@ -275,46 +260,46 @@ , _definedResources :: !(HM.HashMap RIdentifier Resource) , _curScope :: ![CurContainerDesc] , _curPos :: !PPosition- , _nestedDeclarations :: !(HM.HashMap (TopLevelType,T.Text) Statement)+ , _nestedDeclarations :: !(HM.HashMap (TopLevelType,Text) Statement) , _extraRelations :: ![LinkInformation] , _resMod :: ![ResourceModifier] } data InterpreterReader m = InterpreterReader- { _nativeTypes :: !(Container NativeTypeMethods)- , _getStatement :: TopLevelType -> T.Text -> m (S.Either PrettyError Statement)- , _computeTemplateFunction :: Either T.Text T.Text -> InterpreterState -> InterpreterReader m -> m (S.Either PrettyError T.Text)- , _pdbAPI :: PuppetDBAPI m- , _externalFunctions :: Container ([PValue] -> InterpreterMonad PValue)- , _thisNodename :: T.Text- , _hieraQuery :: HieraQueryFunc m- , _ioMethods :: ImpureMethods m- , _ignoredModules :: HS.HashSet T.Text- , _externalModules :: HS.HashSet T.Text- , _isStrict :: Bool- , _ppathes :: PuppetDirPaths+ { _readerNativeTypes :: !(Container NativeTypeMethods)+ , _readerGetStatement :: TopLevelType -> Text -> m (S.Either PrettyError Statement)+ , _readerGetTemplate :: Either Text T.Text -> InterpreterState -> InterpreterReader m -> m (S.Either PrettyError T.Text)+ , _readerPdbApi :: PuppetDBAPI m+ , _readerExternalFunc :: Container ([PValue] -> InterpreterMonad PValue)+ , _readerNodename :: Text+ , _readerHieraQuery :: HieraQueryFunc m+ , _readerIoMethods :: IoMethods m+ , _readerIgnoredModules :: HS.HashSet Text+ , _readerExternalModules :: HS.HashSet Text+ , _readerIsStrict :: Bool+ , _readerPuppetPaths :: PuppetDirPaths } -data ImpureMethods m = ImpureMethods- { _imGetCurrentCallStack :: m [String]- , _imReadFile :: [T.Text] -> m (Either String T.Text)- , _imTraceEvent :: String -> m ()- , _imCallLua :: MVar Lua.LuaState -> T.Text -> [PValue] -> m (Either String PValue)+data IoMethods m = IoMethods+ { _ioGetCurrentCallStack :: m [String]+ , _ioReadFile :: [Text] -> m (Either String T.Text)+ , _ioTraceEvent :: String -> m ()+ , _ioCallLua :: MVar Lua.LuaState -> Text -> [PValue] -> m (Either String PValue) } data InterpreterInstr a where -- Utility for using what's in "InterpreterReader" GetNativeTypes :: InterpreterInstr (Container NativeTypeMethods)- GetStatement :: TopLevelType -> T.Text -> InterpreterInstr Statement- ComputeTemplate :: Either T.Text T.Text -> InterpreterState -> InterpreterInstr T.Text- ExternalFunction :: T.Text -> [PValue] -> InterpreterInstr PValue- GetNodeName :: InterpreterInstr T.Text- HieraQuery :: Container T.Text -> T.Text -> HieraQueryType -> InterpreterInstr (Maybe PValue)+ GetStatement :: TopLevelType -> Text -> InterpreterInstr Statement+ ComputeTemplate :: Either Text T.Text -> InterpreterState -> InterpreterInstr T.Text+ ExternalFunction :: Text -> [PValue] -> InterpreterInstr PValue+ GetNodeName :: InterpreterInstr Text+ HieraQuery :: Container Text -> T.Text -> HieraQueryType -> InterpreterInstr (Maybe PValue) GetCurrentCallStack :: InterpreterInstr [String]- IsIgnoredModule :: T.Text -> InterpreterInstr Bool- IsExternalModule :: T.Text -> InterpreterInstr Bool+ IsIgnoredModule :: Text -> InterpreterInstr Bool+ IsExternalModule :: Text -> InterpreterInstr Bool IsStrict :: InterpreterInstr Bool- PuppetPathes :: InterpreterInstr PuppetDirPaths+ PuppetPaths :: InterpreterInstr PuppetDirPaths -- error ErrorThrow :: PrettyError -> InterpreterInstr a ErrorCatch :: InterpreterMonad a -> (PrettyError -> InterpreterMonad a) -> InterpreterInstr a@@ -325,164 +310,147 @@ -- puppetdb wrappers, see 'PuppetDBAPI' for details PDBInformation :: InterpreterInstr Doc PDBReplaceCatalog :: WireCatalog -> InterpreterInstr ()- PDBReplaceFacts :: [(Nodename, Facts)] -> InterpreterInstr ()- PDBDeactivateNode :: Nodename -> InterpreterInstr ()- PDBGetFacts :: Query FactField -> InterpreterInstr [PFactInfo]+ PDBReplaceFacts :: [(NodeName, Facts)] -> InterpreterInstr ()+ PDBDeactivateNode :: NodeName -> InterpreterInstr ()+ PDBGetFacts :: Query FactField -> InterpreterInstr [FactInfo] PDBGetResources :: Query ResourceField -> InterpreterInstr [Resource]- PDBGetNodes :: Query NodeField -> InterpreterInstr [PNodeInfo]+ PDBGetNodes :: Query NodeField -> InterpreterInstr [NodeInfo] PDBCommitDB :: InterpreterInstr ()- PDBGetResourcesOfNode :: Nodename -> Query ResourceField -> InterpreterInstr [Resource]+ PDBGetResourcesOfNode :: NodeName -> Query ResourceField -> InterpreterInstr [Resource] -- Reading the first file that can be read in a list- ReadFile :: [T.Text] -> InterpreterInstr T.Text+ ReadFile :: [Text] -> InterpreterInstr T.Text -- Tracing events TraceEvent :: String -> InterpreterInstr () -- Calling Lua- CallLua :: MVar Lua.LuaState -> T.Text -> [PValue] -> InterpreterInstr PValue+ CallLua :: MVar Lua.LuaState -> Text -> [PValue] -> InterpreterInstr PValue -type InterpreterLog = Pair LOG.Priority Doc-type InterpreterWriter = [InterpreterLog]--getPuppetPathes :: InterpreterMonad PuppetDirPaths-getPuppetPathes = singleton PuppetPathes--warn :: (Monad m, MonadWriter InterpreterWriter m) => Doc -> m ()-warn d = tell [LOG.WARNING :!: d]--debug :: (Monad m, MonadWriter InterpreterWriter m) => Doc -> m ()-debug d = tell [LOG.DEBUG :!: d]--logWriter :: (Monad m, MonadWriter InterpreterWriter m) => LOG.Priority -> Doc -> m ()-logWriter prio d = tell [prio :!: d]- -- | The main monad type InterpreterMonad = ProgramT InterpreterInstr (State InterpreterState)- instance MonadError PrettyError InterpreterMonad where 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 data RIdentifier = RIdentifier- { _itype :: !T.Text- , _iname :: !T.Text+ { _itype :: !Text+ , _iname :: !Text } deriving (Show,Eq,Generic,Ord) instance Hashable RIdentifier +data ResourceModifier = ResourceModifier+ { _rmResType :: !Text+ , _rmModifierType :: !ModifierType+ , _rmType :: !ResourceCollectorType+ , _rmSearch :: !RSearchExpression+ , _rmMutation :: !(Resource -> InterpreterMonad Resource)+ , _rmDeclaration :: !PPosition+ }++instance Show ResourceModifier where+ show (ResourceModifier rt mt ct se _ p) = unwords ["ResourceModifier", show rt, show mt, show ct, "(" ++ show se ++ ")", "???", show p]+ data ModifierType = ModifierCollector -- ^ For collectors, optional resources | ModifierMustMatch -- ^ For stuff like realize- deriving Eq+ deriving (Show, Eq) data OverrideType = CantOverride -- ^ Overriding forbidden, will throw an error | Replace -- ^ Can silently replace | CantReplace -- ^ Silently ignore errors+ | AppendAttribute -- ^ Can append values+ deriving (Show, Eq) data ResourceCollectorType = RealizeVirtual | RealizeCollected | DontRealize- deriving Eq---data ResourceModifier = ResourceModifier- { _rmResType :: !T.Text- , _rmModifierType :: !ModifierType- , _rmType :: !ResourceCollectorType- , _rmSearch :: !RSearchExpression- , _rmMutation :: !(Resource -> InterpreterMonad Resource)- , _rmDeclaration :: !PPosition- }+ deriving (Show, Eq) data LinkInformation = LinkInformation { _linksrc :: !RIdentifier , _linkdst :: !RIdentifier , _linkType :: !LinkType , _linkPos :: !PPosition- }+ } deriving Show type EdgeMap = HM.HashMap RIdentifier [LinkInformation] {-| A fully resolved puppet resource that will be used in the 'FinalCatalog'. -} data Resource = Resource { _rid :: !RIdentifier -- ^ Resource name.- , _ralias :: !(HS.HashSet T.Text) -- ^ All the resource aliases+ , _ralias :: !(HS.HashSet Text) -- ^ All the resource aliases , _rattributes :: !(Container PValue) -- ^ Resource parameters. , _rrelations :: !(HM.HashMap RIdentifier (HS.HashSet LinkType)) -- ^ Resource relations. , _rscope :: ![CurContainerDesc] -- ^ Resource scope when it was defined, the real container will be the first item , _rvirtuality :: !Virtuality- , _rtags :: !(HS.HashSet T.Text)+ , _rtags :: !(HS.HashSet Text) , _rpos :: !PPosition -- ^ Source code position of the resource definition.- , _rnode :: !Nodename -- ^ The node were this resource was created, if remote+ , _rnode :: !NodeName -- ^ The node were this resource was created, if remote }- deriving Eq+ deriving (Eq, Show) type NativeTypeValidate = Resource -> Either PrettyError Resource -- | Attributes (and providers) of a puppet resource type bundled with validation rules data NativeTypeMethods = NativeTypeMethods { _puppetValidate :: NativeTypeValidate- , _puppetFields :: HS.HashSet T.Text+ , _puppetFields :: HS.HashSet Text } type FinalCatalog = HM.HashMap RIdentifier Resource -data DaemonMethods = DaemonMethods- { -- | The most important function, computing catalogs.- -- Given a node name and a list of facts, it returns the result of the catalog compilation : either an error, or a tuple containing all the resources in this catalog, the dependency map, the exported resources, and a list of known resources, that might not be up to date, but are here for code coverage tests.- _dGetCatalog :: Nodename -> Facts -> IO (S.Either PrettyError (FinalCatalog, EdgeMap, FinalCatalog, [Resource]))- , _dParserStats :: MStats- , _dCatalogStats :: MStats- , _dTemplateStats :: MStats- }--data PuppetEdge = PuppetEdge RIdentifier RIdentifier LinkType+-- | Used to represent a relationship between two resources within the wired format (json).+-- See <http://docs.puppetlabs.com/puppetdb/2.3/api/wire_format/catalog_format_v5.html#data-type-edge>+data PuppetEdge = PuppetEdge RIdentifier RIdentifier LinkType deriving Show -- | Wire format, see <http://docs.puppetlabs.com/puppetdb/1.5/api/wire_format/catalog_format.html>. data WireCatalog = WireCatalog- { _wireCatalogNodename :: !Nodename- , _wireCatalogWVersion :: !T.Text- , _wireCatalogWEdges :: !(V.Vector PuppetEdge)- , _wireCatalogWResources :: !(V.Vector Resource)- , _wireCatalogTransactionUUID :: !T.Text- }+ { _wireCatalogNodename :: !NodeName+ , _wireCatalogVersion :: !Text+ , _wireCatalogEdges :: !(V.Vector PuppetEdge)+ , _wireCatalogResources :: !(V.Vector Resource)+ , _wireCatalogTransactionUUID :: !Text+ } deriving Show -data PFactInfo = PFactInfo- { _pFactInfoNodename :: !T.Text- , _pFactInfoFactname :: !T.Text- , _pFactInfoFactval :: !PValue+data FactInfo = FactInfo+ { _factInfoNodename :: !NodeName+ , _factInfoName :: !Text+ , _factInfoVal :: !PValue } -data PNodeInfo = PNodeInfo- { _pNodeInfoNodename :: !Nodename- , _pNodeInfoDeactivated :: !Bool- , _pNodeInfoCatalogT :: !(S.Maybe UTCTime)- , _pNodeInfoFactsT :: !(S.Maybe UTCTime)- , _pNodeInfoReportT :: !(S.Maybe UTCTime)+data NodeInfo = NodeInfo+ { _nodeInfoName :: !NodeName+ , _nodeInfoDeactivated :: !Bool+ , _nodeInfoCatalogT :: !(S.Maybe UTCTime)+ , _nodeInfoFactsT :: !(S.Maybe UTCTime)+ , _nodeInfoReportT :: !(S.Maybe UTCTime) } data PuppetDBAPI m = PuppetDBAPI { pdbInformation :: m Doc , replaceCatalog :: WireCatalog -> EitherT PrettyError m () -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/commands.html#replace-catalog-version-3>- , replaceFacts :: [(Nodename, Facts)] -> EitherT PrettyError m () -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/commands.html#replace-facts-version-1>- , deactivateNode :: Nodename -> EitherT PrettyError m () -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/commands.html#deactivate-node-version-1>- , getFacts :: Query FactField -> EitherT PrettyError m [PFactInfo] -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/query/v3/facts.html#get-v3facts>+ , replaceFacts :: [(NodeName, Facts)] -> EitherT PrettyError m () -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/commands.html#replace-facts-version-1>+ , deactivateNode :: NodeName -> EitherT PrettyError m () -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/commands.html#deactivate-node-version-1>+ , getFacts :: Query FactField -> EitherT PrettyError m [FactInfo] -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/query/v3/facts.html#get-v3facts> , getResources :: Query ResourceField -> EitherT PrettyError m [Resource] -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/query/v3/resources.html#get-v3resources>- , getNodes :: Query NodeField -> EitherT PrettyError m [PNodeInfo]+ , getNodes :: Query NodeField -> EitherT PrettyError m [NodeInfo] , commitDB :: EitherT PrettyError m () -- ^ This is only here to tell the test PuppetDB to save its content to disk.- , getResourcesOfNode :: Nodename -> Query ResourceField -> EitherT PrettyError m [Resource]+ , getResourcesOfNode :: NodeName -> Query ResourceField -> EitherT PrettyError m [Resource] } -- | Pretty straightforward way to define the various PuppetDB queries-data Query a = QEqual a T.Text+data Query a = QEqual a Text | QG a Integer | QL a Integer | QGE a Integer | QLE a Integer- | QMatch T.Text T.Text+ | QMatch Text T.Text | QAnd [Query a] | QOr [Query a] | QNot (Query a)@@ -494,12 +462,12 @@ | FCertname -- | Fields for the node endpoint-data NodeField = NName | NFact T.Text+data NodeField = NName | NFact Text -- | Fields for the resource endpoint data ResourceField = RTag | RCertname- | RParameter T.Text+ | RParameter Text | RType | RTitle | RExported@@ -511,20 +479,17 @@ makeClassy ''LinkInformation makeClassy ''ResDefaults makeClassy ''ResourceModifier-makeClassy ''DaemonMethods makeClassy ''NativeTypeMethods makeClassy ''ScopeInformation makeClassy ''Resource makeClassy ''InterpreterState makeClassy ''InterpreterReader-makeClassy ''ImpureMethods+makeClassy ''IoMethods makeClassy ''CurContainer-makeFields ''WireCatalog-makeFields ''PFactInfo-makeFields ''PNodeInfo+makeClassy ''NodeInfo+makeClassy ''WireCatalog+makeClassy ''FactInfo -rcurcontainer :: Resource -> CurContainerDesc-rcurcontainer r = fromMaybe ContRoot (r ^? rscope . _head) class Monad m => MonadThrowPos m where throwPosError :: Doc -> m a@@ -548,29 +513,18 @@ else mempty </> string (renderStack stack) throwError (PrettyError (s <+> "at" <+> showPos p <> dstack)) -getCurContainer :: InterpreterMonad CurContainer-{-# INLINABLE getCurContainer #-}-getCurContainer = do- scp <- getScopeName- preuse (scopes . ix scp . scopeContainer) >>= \case- Just x -> return x- Nothing -> throwPosError ("Internal error: can't find the current container for" <+> green (string (T.unpack scp)))--scopeName :: CurContainerDesc -> T.Text-scopeName (ContRoot ) = "::"-scopeName (ContImported x ) = "::imported::" `T.append` scopeName x-scopeName (ContClass x ) = x-scopeName (ContDefine dt dn _) = "#define/" `T.append` dt `T.append` "/" `T.append` dn-scopeName (ContImport _ x ) = "::import::" `T.append` scopeName x+instance ToRuby PValue where+ toRuby = toRuby . toJSON+instance FromRuby PValue where+ fromRuby = fmap chk . fromRuby+ where+ chk (Left x) = Left x+ chk (Right x) = case fromJSON x of+ Error rr -> Left rr -getScopeName :: InterpreterMonad T.Text-getScopeName = fmap scopeName getScope+ Success suc -> Right suc -getScope :: InterpreterMonad CurContainerDesc-{-# INLINABLE getScope #-}-getScope = use curScope >>= \s -> if null s- then throwPosError "Internal error: empty scope!"- else return (head s)+-- JSON INSTANCES -- instance FromJSON PValue where parseJSON Null = return PUndef@@ -589,70 +543,6 @@ toJSON (PHash x) = Object (HM.map toJSON x) toJSON (PNumber n) = Number n -instance ToRuby PValue where- toRuby = toRuby . toJSON-instance FromRuby PValue where- fromRuby = fmap chk . fromRuby- where- chk (Left x) = Left x- chk (Right x) = case fromJSON x of- Error rr -> Left rr- Success suc -> Right suc--eitherDocIO :: IO (S.Either PrettyError a) -> IO (S.Either PrettyError a)-eitherDocIO computation = (computation >>= check) `catch` (\e -> return $ S.Left $ PrettyError $ dullred $ text $ show (e :: SomeException))- where- check (S.Left r) = return (S.Left r)- check (S.Right x) = return (S.Right x)--safeDecodeUtf8 :: BS.ByteString -> InterpreterMonad T.Text-{-# INLINABLE safeDecodeUtf8 #-}-safeDecodeUtf8 i = return (T.decodeUtf8 i)--resourceRelations :: Resource -> [(RIdentifier, LinkType)]-resourceRelations = concatMap expandSet . HM.toList . _rrelations- where- expandSet (ri, lts) = [(ri, lt) | lt <- HS.toList lts]---- | helper for hashmap, in case we want another kind of map ..-ifromList :: (Monoid m, At m, F.Foldable f) => f (Index m, IxValue m) -> m-{-# INLINABLE ifromList #-}-ifromList = F.foldl' (\curm (k,v) -> curm & at k ?~ v) mempty--ikeys :: (Eq k, Hashable k) => HM.HashMap k v -> HS.HashSet k-{-# INLINABLE ikeys #-}-ikeys = HS.fromList . HM.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, F.Foldable f) => (IxValue m -> IxValue m -> IxValue m) -> f (Index m, IxValue m) -> m-{-# INLINABLE ifromListWith #-}-ifromListWith f = F.foldl' (\curmap (k,v) -> iinsertWith f k v curmap) mempty--iinsertWith :: At m => (IxValue m -> IxValue m -> IxValue m) -> Index m -> IxValue m -> m -> m-{-# INLINABLE iinsertWith #-}-iinsertWith f k v m = m & at k %~ mightreplace- where- mightreplace Nothing = Just v- mightreplace (Just x) = Just (f v x)--iunionWith :: (Hashable k, Eq k) => (v -> v -> v) -> HM.HashMap k v -> HM.HashMap k v -> HM.HashMap k v-{-# INLINABLE iunionWith #-}-iunionWith = HM.unionWith--fnull :: (Eq x, Monoid x) => x -> Bool-{-# INLINABLE fnull #-}-fnull = (== mempty)--rid2text :: RIdentifier -> T.Text-rid2text (RIdentifier t n) = capitalizeRT t `T.append` "[" `T.append` capn `T.append` "]"- where- capn = if t == "classe"- then capitalizeRT n- else n- instance ToJSON Resource where toJSON r = object [ ("type", String $ r ^. rid . itype) , ("title", String $ r ^. rid . iname)@@ -667,10 +557,16 @@ relations = r ^. rrelations & HM.fromListWith (V.++) . concatMap changeRelations . HM.toList & HM.map toValue toValue v | V.length v == 1 = V.head v | otherwise = Array v- changeRelations :: (RIdentifier, HS.HashSet LinkType) -> [(T.Text, V.Vector Value)]+ changeRelations :: (RIdentifier, HS.HashSet LinkType) -> [(Text, V.Vector Value)] changeRelations (k,v) = do c <- HS.toList v return (rel2text c, V.singleton (String (rid2text k)))+ rid2text :: RIdentifier -> Text+ rid2text (RIdentifier t n) = capitalizeRT t `T.append` "[" `T.append` capn `T.append` "]"+ where+ capn = if t == "classe"+ then capitalizeRT n+ else n instance FromJSON Resource where parseJSON (Object v) = do@@ -690,7 +586,7 @@ _ -> Nothing getResourceIdentifier _ = Nothing -- TODO : properly handle metaparameters- separate :: (Container PValue, HM.HashMap RIdentifier (HS.HashSet LinkType)) -> T.Text -> PValue -> (Container PValue, HM.HashMap RIdentifier (HS.HashSet LinkType))+ separate :: (Container PValue, HM.HashMap RIdentifier (HS.HashSet LinkType)) -> Text -> PValue -> (Container PValue, HM.HashMap RIdentifier (HS.HashSet LinkType)) separate (curAttribs, curRelations) k val = case (fromJSON (String k), getResourceIdentifier val) of (Success rel, Just ri) -> (curAttribs, curRelations & at ri . non mempty . contains rel .~ True) _ -> (curAttribs & at k ?~ val, curRelations)@@ -818,82 +714,25 @@ , ("transaction-uuid", String t) ] -instance ToJSON PFactInfo where- toJSON (PFactInfo n f v) = object [("certname", String n), ("name", String f), ("value", toJSON v)]+instance ToJSON FactInfo where+ toJSON (FactInfo n f v) = object [("certname", String n), ("name", String f), ("value", toJSON v)] -instance FromJSON PFactInfo where- parseJSON (Object v) = PFactInfo <$> v .: "certname" <*> v .: "name" <*> v .: "value"+instance FromJSON FactInfo where+ parseJSON (Object v) = FactInfo <$> v .: "certname" <*> v .: "name" <*> v .: "value" parseJSON _ = fail "invalid fact info" -instance ToJSON PNodeInfo where- toJSON p = object [ ("name" , toJSON (p ^. nodename))- , ("deactivated" , toJSON (p ^. deactivated))- , ("catalog_timestamp", toJSON (p ^. catalogT))- , ("facts_timestamp" , toJSON (p ^. factsT))- , ("report_timestamp" , toJSON (p ^. reportT))+instance ToJSON NodeInfo where+ toJSON p = object [ ("name" , toJSON (p ^. nodeInfoName))+ , ("deactivated" , toJSON (p ^. nodeInfoDeactivated))+ , ("catalog_timestamp", toJSON (p ^. nodeInfoCatalogT))+ , ("facts_timestamp" , toJSON (p ^. nodeInfoFactsT))+ , ("report_timestamp" , toJSON (p ^. nodeInfoReportT)) ] -instance FromJSON PNodeInfo where- parseJSON (Object v) = PNodeInfo <$> v .: "name"+instance FromJSON NodeInfo where+ parseJSON (Object v) = NodeInfo <$> v .: "name" <*> v .:? "deactivated" .!= False <*> v .: "catalog_timestamp" <*> v .: "facts_timestamp" <*> v .: "report_timestamp" parseJSON _ = fail "invalide node info"--text2Scientific :: T.Text -> Maybe Scientific-text2Scientific t = case parseOnly rational t of- Left _ -> Nothing- Right s -> Just s--instance AsNumber PValue where- _Number = prism num2PValue toNumber- where- num2PValue :: Scientific -> PValue- num2PValue = PNumber- toNumber :: PValue -> Either PValue Scientific- toNumber (PNumber n) = Right n- toNumber p@(PString x) = case text2Scientific x of- Just o -> Right o- _ -> Left p- toNumber p = Left p--initialState :: Facts- -> Container T.Text -- ^ Server settings- -> InterpreterState-initialState facts settings = InterpreterState baseVars initialclass mempty [ContRoot] dummypos mempty [] []- where- callervars = HM.fromList [("caller_module_name", PString "::" :!: dummypos :!: ContRoot), ("module_name", PString "::" :!: dummypos :!: ContRoot)]- factvars = fmap (\x -> x :!: initialPPos "facts" :!: ContRoot) facts- settingvars = fmap (\x -> PString x :!: initialPPos "settings" :!: ContClass "settings") settings- baseVars = HM.fromList [ ("::", ScopeInformation (factvars `mappend` callervars) mempty mempty (CurContainer ContRoot mempty) mempty S.Nothing)- , ("settings", ScopeInformation settingvars mempty mempty (CurContainer (ContClass "settings") mempty) mempty S.Nothing)- ]- initialclass = mempty & at "::" ?~ (IncludeStandard :!: dummypos)--dummypos :: PPosition-dummypos = initialPPos "dummy"---- | Throws an error if we are in strict mode--- A warning in permissive mode-checkStrict :: Doc -- ^ The warning message.- -> Doc -- ^ The error message.- -> InterpreterMonad ()-checkStrict wrn err = do- extMod <- isExternalModule- let priority = if extMod then LOG.NOTICE else LOG.WARNING- str <- singleton IsStrict- if str && not extMod- then throwPosError err- else do- srcname <- use (curPos._1.lSourceName)- logWriter priority (wrn <+> "at" <+> string srcname)--isExternalModule :: InterpreterMonad Bool-isExternalModule =- getScope >>= \case- ContClass n -> isExternal n- ContDefine n _ _ -> isExternal n- _ -> return False- where- isExternal = singleton . IsExternalModule . head . T.splitOn "::"
+ Puppet/Interpreter/Utils.hs view
@@ -0,0 +1,148 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RankNTypes #-}++-- | The module should not depend on the Interpreter module+module Puppet.Interpreter.Utils where++import Control.Lens hiding (Strict)+import Control.Monad.Operational+import Control.Monad.Writer.Class+import qualified Data.ByteString as BS+import qualified Data.HashMap.Strict as HM+import Data.Maybe (fromMaybe)+import qualified Data.Maybe.Strict as S+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Data.Tuple.Strict+import qualified System.Log.Logger as LOG++import Puppet.Interpreter.Types+import Puppet.Parser.Types+import Puppet.Parser.Utils+import Puppet.Paths+import Puppet.PP++initialState :: Facts+ -> Container Text -- ^ Server settings+ -> InterpreterState+initialState facts settings = InterpreterState baseVars initialclass mempty [ContRoot] dummyppos mempty [] []+ where+ callervars = HM.fromList [("caller_module_name", PString "::" :!: dummyppos :!: ContRoot), ("module_name", PString "::" :!: dummyppos :!: ContRoot)]+ factvars = fmap (\x -> x :!: initialPPos "facts" :!: ContRoot) facts+ settingvars = fmap (\x -> PString x :!: initialPPos "settings" :!: ContClass "settings") settings+ baseVars = HM.fromList [ ("::", ScopeInformation (factvars `mappend` callervars) mempty mempty (CurContainer ContRoot mempty) mempty S.Nothing)+ , ("settings", ScopeInformation settingvars mempty mempty (CurContainer (ContClass "settings") mempty) mempty S.Nothing)+ ]+ initialclass = mempty & at "::" ?~ (ClassIncludeLike :!: dummyppos)+++getModulename :: RIdentifier -> Text+getModulename (RIdentifier t n) =+ let gm x = case T.splitOn "::" x of+ [] -> x+ (y:_) -> y+ in case t of+ "class" -> gm n+ _ -> gm t+++extractPrism :: Doc -> Prism' a b -> a -> InterpreterMonad b+extractPrism msg p a = case preview p a of+ Just b -> return b+ Nothing -> throwPosError ("Could not extract prism in" <+> msg)++-- Scope+popScope :: InterpreterMonad ()+popScope = curScope %= tail++pushScope :: CurContainerDesc -> InterpreterMonad ()+pushScope s = curScope %= (s :)++getScopeName :: InterpreterMonad Text+getScopeName = scopeName <$> getScope++scopeName :: CurContainerDesc -> Text+scopeName (ContRoot ) = "::"+scopeName (ContImported x ) = "::imported::" `T.append` scopeName x+scopeName (ContClass x ) = x+scopeName (ContDefine dt dn _) = "#define/" `T.append` dt `T.append` "/" `T.append` dn+scopeName (ContImport _ x ) = "::import::" `T.append` scopeName x++getScope :: InterpreterMonad CurContainerDesc+{-# INLINABLE getScope #-}+getScope = use curScope >>= \s -> if null s+ then throwPosError "Internal error: empty scope!"+ else return (head s)+++getCurContainer :: InterpreterMonad CurContainer+{-# INLINABLE getCurContainer #-}+getCurContainer = do+ scp <- getScopeName+ preuse (scopes . ix scp . scopeContainer) >>= \case+ Just x -> return x+ Nothing -> throwPosError ("Internal error: can't find the current container for" <+> green (string (T.unpack scp)))++rcurcontainer :: Resource -> CurContainerDesc+rcurcontainer r = fromMaybe ContRoot (r ^? rscope . _head)++-- Singleton getters available in the InterpreterMonad --+getPuppetPaths :: InterpreterMonad PuppetDirPaths+getPuppetPaths = singleton PuppetPaths++getNodeName:: InterpreterMonad NodeName+getNodeName = singleton GetNodeName++isIgnoredModule :: Text -> InterpreterMonad Bool+isIgnoredModule m = singleton (IsIgnoredModule m)++-- | Throws an error if we are in strict mode+-- A warning in permissive mode+checkStrict :: Doc -- ^ The warning message.+ -> Doc -- ^ The error message.+ -> InterpreterMonad ()+checkStrict wrn err = do+ extMod <- isExternalModule+ let priority = if extMod then LOG.NOTICE else LOG.WARNING+ str <- singleton IsStrict+ if str && not extMod+ then throwPosError err+ else do+ srcname <- use (curPos._1.lSourceName)+ logWriter priority (wrn <+> "at" <+> string srcname)++isExternalModule :: InterpreterMonad Bool+isExternalModule =+ getScope >>= \case+ ContClass n -> isExternal n+ ContDefine n _ _ -> isExternal n+ _ -> return False+ where+ isExternal = singleton . IsExternalModule . head . T.splitOn "::"+++-- Logging --+warn :: (Monad m, MonadWriter InterpreterWriter m) => Doc -> m ()+warn d = tell [LOG.WARNING :!: d]++debug :: (Monad m, MonadWriter InterpreterWriter m) => Doc -> m ()+debug d = tell [LOG.DEBUG :!: d]++logWriter :: (Monad m, MonadWriter InterpreterWriter m) => LOG.Priority -> Doc -> m ()+logWriter prio d = tell [prio :!: d]++-- General --+isEmpty :: (Eq x, Monoid x) => x -> Bool+isEmpty = (== mempty)++safeDecodeUtf8 :: BS.ByteString -> InterpreterMonad Text+{-# INLINABLE safeDecodeUtf8 #-}+safeDecodeUtf8 i = return (T.decodeUtf8 i)++dropInitialColons :: Text -> T.Text+dropInitialColons t = fromMaybe t (T.stripPrefix "::" t)++normalizeRIdentifier :: Text -> T.Text -> RIdentifier+normalizeRIdentifier = RIdentifier . dropInitialColons
Puppet/Lens.hs view
@@ -13,33 +13,19 @@ , _PArray -- * Parsing prism -- * Lenses and Prisms for 'Statement's- , _ResourceDeclaration- , _DefaultDeclaration- , _ResourceOverride- , _ConditionalStatement- , _ClassDeclaration- , _DefineDeclaration- , _Node- , _VariableAssignment- , _MainFunctionCall- , _SHFunctionCall- , _ResourceCollection- , _Dependency- , _TopContainer , _Statements- -- * More primitive prisms for 'Statement's- , _ResourceDeclaration'- , _DefaultDeclaration'- , _ResourceOverride'- , _ConditionalStatement'- , _ClassDeclaration'- , _DefineDeclaration'- , _Node'- , _VariableAssignment'- , _MainFunctionCall'- , _SHFunctionCall'- , _ResourceCollection'- , _Dependency'+ , _ResDecl+ , _ResDefaultDecl+ , _ResOverrDecl+ , _ResCollDecl+ , _ConditionalDecl+ , _ClassDecl+ , _DefineDecl+ , _NodeDecl+ , _VarAssignDecl+ , _MainFuncDecl+ , _HigherOrderLambdaDecl+ , _DepDecl -- * Lenses and Prisms for 'Expression's , _Equal , _Different@@ -78,8 +64,6 @@ import qualified Data.Vector as V import qualified Data.HashMap.Strict as HM-import qualified Data.Text as T-import qualified Data.Maybe.Strict as S import Data.Tuple.Strict hiding (uncurry) import Control.Exception (SomeException, toException, fromException) @@ -88,101 +72,64 @@ --makePrisms ''Statement makePrisms ''Expression -makePrisms ''ResDec-makePrisms ''DefaultDec-makePrisms ''ResOver-makePrisms ''CondStatement-makePrisms ''ClassDecl-makePrisms ''DefineDec-makePrisms ''Nd-makePrisms ''VarAss-makePrisms ''MFC-makePrisms ''SFC-makePrisms ''RColl-makePrisms ''Dep-- _PrettyError :: Prism' SomeException PrettyError _PrettyError = prism' toException fromException -_ResourceDeclaration' :: Prism' Statement ResDec-_ResourceDeclaration' = prism ResourceDeclaration $ \x -> case x of- ResourceDeclaration a -> Right a+_ResDecl :: Prism' Statement ResDecl+_ResDecl = prism ResourceDeclaration $ \x -> case x of+ ResourceDeclaration a -> Right a+ _ -> Left x+_ResDefaultDecl :: Prism' Statement ResDefaultDecl+_ResDefaultDecl = prism ResourceDefaultDeclaration $ \x -> case x of+ ResourceDefaultDeclaration a -> Right a+ _ -> Left x+_ResOverrDecl :: Prism' Statement ResOverrideDecl+_ResOverrDecl = prism ResourceOverrideDeclaration $ \x -> case x of+ ResourceOverrideDeclaration a -> Right a _ -> Left x-_DefaultDeclaration' :: Prism' Statement DefaultDec-_DefaultDeclaration' = prism DefaultDeclaration $ \x -> case x of- DefaultDeclaration a -> Right a- _ -> Left x-_ResourceOverride' :: Prism' Statement ResOver-_ResourceOverride' = prism ResourceOverride $ \x -> case x of- ResourceOverride a -> Right a- _ -> Left x-_ConditionalStatement' :: Prism' Statement CondStatement-_ConditionalStatement' = prism ConditionalStatement $ \x -> case x of- ConditionalStatement a -> Right a- _ -> Left x-_ClassDeclaration' :: Prism' Statement ClassDecl-_ClassDeclaration' = prism ClassDeclaration $ \x -> case x of- ClassDeclaration a -> Right a- _ -> Left x-_DefineDeclaration' :: Prism' Statement DefineDec-_DefineDeclaration' = prism DefineDeclaration $ \x -> case x of- DefineDeclaration a -> Right a- _ -> Left x-_Node' :: Prism' Statement Nd-_Node' = prism Node $ \x -> case x of- Node a -> Right a- _ -> Left x-_VariableAssignment' :: Prism' Statement VarAss-_VariableAssignment' = prism VariableAssignment $ \x -> case x of- VariableAssignment a -> Right a+_ResCollDecl :: Prism' Statement ResCollDecl+_ResCollDecl = prism ResourceCollectionDeclaration $ \x -> case x of+ ResourceCollectionDeclaration a -> Right a+ _ -> Left x+_ConditionalDecl :: Prism' Statement ConditionalDecl+_ConditionalDecl = prism ConditionalDeclaration $ \x -> case x of+ ConditionalDeclaration a -> Right a _ -> Left x-_MainFunctionCall' :: Prism' Statement MFC-_MainFunctionCall' = prism MainFunctionCall $ \x -> case x of- MainFunctionCall a -> Right a- _ -> Left x-_SHFunctionCall' :: Prism' Statement SFC-_SHFunctionCall' = prism SHFunctionCall $ \x -> case x of- SHFunctionCall a -> Right a- _ -> Left x-_ResourceCollection' :: Prism' Statement RColl-_ResourceCollection' = prism ResourceCollection $ \x -> case x of- ResourceCollection a -> Right a+_ClassDecl :: Prism' Statement ClassDecl+_ClassDecl = prism ClassDeclaration $ \x -> case x of+ ClassDeclaration a -> Right a+ _ -> Left x+_DefineDecl :: Prism' Statement DefineDecl+_DefineDecl = prism DefineDeclaration $ \x -> case x of+ DefineDeclaration a -> Right a+ _ -> Left x+_NodeDecl :: Prism' Statement NodeDecl+_NodeDecl = prism NodeDeclaration $ \x -> case x of+ NodeDeclaration a -> Right a+ _ -> Left x++_VarAssignDecl :: Prism' Statement VarAssignDecl+_VarAssignDecl = prism VarAssignmentDeclaration $ \x -> case x of+ VarAssignmentDeclaration a -> Right a _ -> Left x-_Dependency' :: Prism' Statement Dep-_Dependency' = prism Dependency $ \x -> case x of- Dependency a -> Right a- _ -> Left x+_MainFuncDecl :: Prism' Statement MainFuncDecl+_MainFuncDecl = prism MainFunctionDeclaration $ \x -> case x of+ MainFunctionDeclaration a -> Right a+ _ -> Left x+_HigherOrderLambdaDecl :: Prism' Statement HigherOrderLambdaDecl+_HigherOrderLambdaDecl = prism HigherOrderLambdaDeclaration $ \x -> case x of+ HigherOrderLambdaDeclaration a -> Right a+ _ -> Left x+_DepDecl :: Prism' Statement DepDecl+_DepDecl = prism DependencyDeclaration $ \x -> case x of+ DependencyDeclaration a -> Right a+ _ -> Left x+ _TopContainer :: Prism' Statement (V.Vector Statement, Statement) _TopContainer = prism (uncurry TopContainer) $ \x -> case x of TopContainer vs s -> Right (vs,s) _ -> Left x -_ResourceDeclaration :: Prism' Statement (T.Text, Expression, V.Vector (Pair T.Text Expression), Virtuality, PPosition)-_ResourceDeclaration = _ResourceDeclaration' . _ResDec-_DefaultDeclaration :: Prism' Statement (T.Text, V.Vector (Pair T.Text Expression), PPosition)-_DefaultDeclaration = _DefaultDeclaration' . _DefaultDec-_ResourceOverride :: Prism' Statement (T.Text, Expression, V.Vector (Pair T.Text Expression), PPosition)-_ResourceOverride = _ResourceOverride' . _ResOver-_ConditionalStatement :: Prism' Statement (V.Vector (Pair Expression (V.Vector Statement)), PPosition)-_ConditionalStatement = _ConditionalStatement' . _CondStatement-_ClassDeclaration :: Prism' Statement (T.Text, V.Vector (Pair T.Text (S.Maybe Expression)), S.Maybe T.Text, V.Vector Statement, PPosition)-_ClassDeclaration = _ClassDeclaration' . _ClassDecl-_DefineDeclaration :: Prism' Statement (T.Text, V.Vector (Pair T.Text (S.Maybe Expression)), V.Vector Statement, PPosition)-_DefineDeclaration = _DefineDeclaration' . _DefineDec-_Node :: Prism' Statement (NodeDesc, V.Vector Statement, S.Maybe NodeDesc, PPosition)-_Node = _Node' . _Nd-_VariableAssignment :: Prism' Statement (T.Text, Expression, PPosition)-_VariableAssignment = _VariableAssignment' . _VarAss-_MainFunctionCall :: Prism' Statement (T.Text, V.Vector Expression, PPosition)-_MainFunctionCall = _MainFunctionCall' . _MFC-_SHFunctionCall :: Prism' Statement (HFunctionCall, PPosition)-_SHFunctionCall = _SHFunctionCall' . _SFC-_ResourceCollection :: Prism' Statement (CollectorType, T.Text, SearchExpression, V.Vector (Pair T.Text Expression), PPosition)-_ResourceCollection = _ResourceCollection' . _RColl-_Dependency :: Prism' Statement (Pair T.Text Expression, Pair T.Text Expression, LinkType, PPosition)-_Dependency = _Dependency' . _Dep- -- | Incomplete _PResolveExpression :: Prism' Expression PValue _PResolveExpression = prism reinject extract@@ -192,7 +139,7 @@ Left _ -> Left e reinject = Terminal . review _PResolveValue -_PResolveValue :: Prism' UValue PValue+_PResolveValue :: Prism' UnresolvedValue PValue _PResolveValue = prism toU toP where toP uv = case dummyEval (resolveValue uv) of@@ -213,15 +160,15 @@ where sget :: Statement -> V.Vector Statement sget (ClassDeclaration (ClassDecl _ _ _ s _)) = s- sget (DefineDeclaration (DefineDec _ _ s _)) = s- sget (Node (Nd _ s _ _)) = s+ sget (DefineDeclaration (DefineDecl _ _ s _)) = s+ sget (NodeDeclaration (NodeDecl _ s _ _)) = s sget (TopContainer s _) = s- sget (SHFunctionCall (SFC (HFunctionCall _ _ _ s _) _)) = s+ sget (HigherOrderLambdaDeclaration (HigherOrderLambdaDecl (HOLambdaCall _ _ _ s _) _)) = s sget _ = V.empty sset :: Statement -> V.Vector Statement -> Statement sset (ClassDeclaration (ClassDecl n args inh _ p)) s = ClassDeclaration (ClassDecl n args inh s p)- sset (Node (Nd ns _ nd' p)) s = Node (Nd ns s nd' p)- sset (DefineDeclaration (DefineDec n args _ p)) s = DefineDeclaration (DefineDec n args s p)+ sset (NodeDeclaration (NodeDecl ns _ nd' p)) s = NodeDeclaration (NodeDecl ns s nd' p)+ sset (DefineDeclaration (DefineDecl n args _ p)) s = DefineDeclaration (DefineDecl n args s p) sset (TopContainer _ p) s = TopContainer s p- sset (SHFunctionCall (SFC (HFunctionCall t e pr _ e2) p)) s = SHFunctionCall (SFC (HFunctionCall t e pr s e2) p)+ sset (HigherOrderLambdaDeclaration (HigherOrderLambdaDecl (HOLambdaCall t e pr _ e2) p)) s = HigherOrderLambdaDeclaration (HigherOrderLambdaDecl (HOLambdaCall t e pr s e2) p) sset x _ = x
Puppet/Manifests.hs view
@@ -1,22 +1,22 @@-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GADTs #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-} module Puppet.Manifests (filterStatements) where -import Puppet.PP-import Puppet.Parser.Types-import Puppet.Interpreter.Types+import Control.Applicative+import Control.Lens+import Control.Monad.Except+import qualified Data.Either.Strict as S+import qualified Data.HashMap.Strict as HM+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Data.Tuple.Strict+import qualified Data.Vector as V+import Text.Regex.PCRE.ByteString.Utils -import Text.Regex.PCRE.ByteString.Utils-import Control.Lens-import Control.Applicative-import Control.Monad.Except-import qualified Data.Vector as V-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import Data.Tuple.Strict-import qualified Data.Either.Strict as S-import qualified Data.HashMap.Strict as HM+import Puppet.Interpreter.Types+import Puppet.Parser.Types+import Puppet.PP -- TODO pre-triage stuff filterStatements :: TopLevelType -> T.Text -> V.Vector Statement -> IO (S.Either PrettyError Statement)@@ -24,9 +24,9 @@ filterStatements TopNode ndename stmts = -- this operation should probably get cached let (!spurious, !directnodes, !regexpmatches, !defaultnode) = V.foldl' triage (V.empty, HM.empty, V.empty, Nothing) stmts- triage curstuff n@(Node (Nd (NodeName !nm) _ _ _)) = curstuff & _2 . at nm ?~ n- triage curstuff n@(Node (Nd (NodeMatch (CompRegex _ !rg)) _ _ _)) = curstuff & _3 %~ (|> (rg :!: n))- triage curstuff n@(Node (Nd NodeDefault _ _ _)) = curstuff & _4 ?~ n+ triage curstuff n@(NodeDeclaration (NodeDecl (NodeName !nm) _ _ _)) = curstuff & _2 . at nm ?~ n+ triage curstuff n@(NodeDeclaration (NodeDecl (NodeMatch (CompRegex _ !rg)) _ _ _)) = curstuff & _3 %~ (|> (rg :!: n))+ triage curstuff n@(NodeDeclaration (NodeDecl NodeDefault _ _ _)) = curstuff & _4 ?~ n triage curstuff x = curstuff & _1 %~ (|> x) bsnodename = T.encodeUtf8 ndename checkRegexp :: [Pair Regex Statement] -> ExceptT PrettyError IO (Maybe Statement)@@ -48,14 +48,13 @@ filterStatements x ndename stmts = let (!spurious, !defines, !classes) = V.foldl' triage (V.empty, HM.empty, HM.empty) stmts triage curstuff n@(ClassDeclaration (ClassDecl cname _ _ _ _)) = curstuff & _3 . at cname ?~ n- triage curstuff n@(DefineDeclaration (DefineDec cname _ _ _)) = curstuff & _2 . at cname ?~ n+ triage curstuff n@(DefineDeclaration (DefineDecl cname _ _ _)) = curstuff & _2 . at cname ?~ n triage curstuff n = curstuff & _1 %~ (|> n) tc n = if V.null spurious then n else TopContainer spurious n in case x of TopNode -> return (S.Left "Case already covered, shoudln't happen in Puppet.Manifests")- TopSpurious -> return (S.Left "Should not ask for a TopSpurious!!!") TopDefine -> case defines ^. at ndename of Just n -> return (S.Right (tc n)) Nothing -> return (S.Left (PrettyError ("Couldn't find define " <+> ttext ndename)))
Puppet/NativeTypes/Cron.hs view
@@ -1,12 +1,15 @@-module Puppet.NativeTypes.Cron (nativeCron) where+module Puppet.NativeTypes.Cron+ (nativeCron)+where +import Control.Lens+import Data.Scientific+import qualified Data.Text as T+import qualified Data.Vector as V+import Puppet.Interpreter.Types+import Puppet.NativeTypes.Helpers+import Puppet.Utils import qualified Text.PrettyPrint.ANSI.Leijen as P-import Puppet.NativeTypes.Helpers-import Puppet.Interpreter.Types-import qualified Data.Text as T-import Control.Lens-import qualified Data.Vector as V-import Data.Scientific nativeCron :: (NativeTypeName, NativeTypeMethods) nativeCron = ("cron", nativetypemethods parameterfunctions return )
Puppet/NativeTypes/File.hs view
@@ -37,9 +37,13 @@ ,("provider" , [values ["posix","windows"]]) ,("purge" , [string, values ["true","false"]]) ,("recurse" , [string, values ["inf","true","false","remote"]])- ,("recurselimit " , [integer])+ ,("recurselimit" , [integer]) ,("replace" , [string, values ["true","false"]])- ,("sourceselect " , [values ["first","all"]])+ ,("sourceselect" , [values ["first","all"]])+ ,("seltype" , [string])+ ,("selrange" , [string])+ ,("selinux_ignore_defaults", [string, values ["true","false"]])+ ,("selrole" , [string]) ,("target" , [string]) ,("source" , [rarray, strings, flip runarray checkSource]) ,("seluser" , [string])
Puppet/NativeTypes/Package.hs view
@@ -14,6 +14,7 @@ nativePackage :: (NativeTypeName, NativeTypeMethods) nativePackage = ("package", nativetypemethods parameterfunctions (getFeature >=> checkFeatures)) +-- Features are abilities that some providers may not support. data PackagingFeatures = Holdable | InstallOptions | Installable | Purgeable | UninstallOptions | Uninstallable | Upgradeable | Versionable deriving (Show, Eq, Generic) instance Hashable PackagingFeatures@@ -22,7 +23,7 @@ isFeatureSupported = HM.fromList [ ("aix", HS.fromList [Installable, Uninstallable, Upgradeable, Versionable]) , ("appdmg", HS.fromList [Installable]) , ("apple", HS.fromList [Installable])- , ("apt", HS.fromList [Holdable, Installable, Purgeable, Uninstallable, Upgradeable, Versionable])+ , ("apt", HS.fromList [Holdable, InstallOptions, Installable, Purgeable, Uninstallable, Upgradeable, Versionable]) , ("aptitude", HS.fromList [Holdable, Installable, Purgeable, Uninstallable, Upgradeable, Versionable]) , ("aptrpm", HS.fromList [Installable, Purgeable, Uninstallable, Upgradeable, Versionable]) , ("blastwave", HS.fromList [Installable, Uninstallable, Upgradeable])
Puppet/PP.hs view
@@ -1,19 +1,23 @@ module Puppet.PP ( ttext- , pshow+ , prettyToText , displayNocolor -- * Re-exports , module Text.PrettyPrint.ANSI.Leijen ) where +import Data.Text (Text) import qualified Data.Text as T import Text.PrettyPrint.ANSI.Leijen hiding ((<$>), (<>)) ttext :: T.Text -> Doc ttext = text . T.unpack -pshow :: Doc -> String-pshow d = displayS (renderPretty 0.4 120 d) ""+prettyToText :: Doc -> Text+prettyToText = T.pack . prettyToShow++prettyToShow :: Doc -> String+prettyToShow d = displayS (renderCompact d) "" -- | A rendering function that drops colors: displayNocolor :: Doc -> String
Puppet/Parser.hs view
@@ -8,29 +8,26 @@ , expression ) where +import Control.Applicative+import Control.Lens hiding (noneOf)+import Control.Monad+import Data.Char+import qualified Data.Foldable as F+import qualified Data.Maybe.Strict as S+import Data.Scientific import qualified Data.Text as T import qualified Data.Text.Encoding as T-import qualified Data.Vector as V-import qualified Data.Maybe.Strict as S-import qualified Data.Foldable as F import Data.Tuple.Strict hiding (fst,zip)+import qualified Data.Vector as V+import Text.Megaparsec hiding (token)+import Text.Megaparsec.Expr+import qualified Text.Megaparsec.Lexer as L+import Text.Megaparsec.Text import Text.Regex.PCRE.ByteString.Utils -import Data.Char-import Control.Monad-import Control.Applicative-import Control.Lens hiding (noneOf)- import Puppet.Parser.Types import Puppet.Utils -import Data.Scientific--import Text.Megaparsec hiding (token)-import Text.Megaparsec.Expr-import Text.Megaparsec.Text-import qualified Text.Megaparsec.Lexer as L- -- | Run a puppet parser against some 'T.Text' input. runPParser :: String -> T.Text -> Either ParseError (V.Vector Statement) runPParser = parse puppetParser@@ -219,10 +216,10 @@ T.pack . concat <$> many ( do { void (char '\\') ; x <- anyChar; return ['\\', x] } <|> some (noneOf "/\\") ) <* symbolic '/' -puppetArray :: Parser UValue+puppetArray :: Parser UnresolvedValue puppetArray = fmap (UArray . V.fromList) (brackets (sepComma expression)) <?> "Array" -puppetHash :: Parser UValue+puppetHash :: Parser UnresolvedValue puppetHash = fmap (UHash . V.fromList) (braces (sepComma hashPart)) <?> "Hash" where hashPart = (:!:) <$> (expression <* operator "=>")@@ -239,7 +236,7 @@ resnames <- brackets (expression `sepBy1` comma) <?> "Resource reference values" return (restype, resnames) -resourceReference :: Parser UValue+resourceReference :: Parser UnresolvedValue resourceReference = do (restype, resnames) <- resourceReferenceRaw return $ UResourceReference restype $ case resnames of@@ -268,12 +265,8 @@ else fail "Function arguments C" return (fname, V.fromList args) -functionCall :: Parser UValue-functionCall = do- (fname, args) <- genFunctionCall False- return $ UFunctionCall fname args -literalValue :: Parser UValue+literalValue :: Parser UnresolvedValue literalValue = token (fmap UString stringLiteral' <|> fmap UString bareword <|> fmap UNumber numericalvalue <?> "Literal Value") where numericalvalue = integerOrDouble >>= \i -> case i of@@ -303,7 +296,12 @@ termRegexp = regexp >>= compileRegexp terminal :: Parser Expression-terminal = terminalG (fmap Terminal (fmap UHFunctionCall (try hfunctionCall) <|> try functionCall))+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@@ -344,30 +342,41 @@ stringExpression :: Parser Expression stringExpression = fmap (Terminal . UInterpolable) interpolableString <|> (reserved "undef" *> return (Terminal UUndef)) <|> fmap (Terminal . UBoolean) puppetBool <|> variable <|> fmap Terminal literalValue -variableAssignment :: Parser VarAss-variableAssignment = do+varAssign :: Parser VarAssignDecl+varAssign = do p <- getPosition v <- variableReference void $ symbolic '=' e <- expression when (T.all isDigit v) (fail "Can't assign fully numeric variables") pe <- getPosition- return (VarAss v e (p :!: pe))+ return (VarAssignDecl v e (p :!: pe)) -nodeStmt :: Parser [Nd]-nodeStmt = do+nodeDecl :: Parser [NodeDecl]+nodeDecl = do p <- getPosition reserved "node" let toString (UString s) = s toString (UNumber n) = scientific2text n- toString _ = error "Can't happen at nodeStmt"+ toString _ = error "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 <- getPosition- return [Nd n st inheritance (p :!: pe) | n <- ns]+ return [NodeDecl n st inheritance (p :!: pe) | n <- ns] +defineDecl :: Parser DefineDecl+defineDecl = do+ p <- getPosition+ reserved "define"+ name <- typeName+ -- TODO check native type+ params <- option V.empty puppetClassParameters+ st <- braces statementList+ pe <- getPosition+ return (DefineDecl name params st (p :!: pe))+ puppetClassParameters :: Parser (V.Vector (Pair T.Text (S.Maybe Expression))) puppetClassParameters = V.fromList <$> parens (sepComma var) where@@ -378,29 +387,18 @@ <$> variableReference <*> (toStrictMaybe <$> optional (symbolic '=' *> expression)) -defineStmt :: Parser DefineDec-defineStmt = do- p <- getPosition- reserved "define"- name <- typeName- -- TODO check native type- params <- option V.empty puppetClassParameters- st <- braces statementList- pe <- getPosition- return (DefineDec name params st (p :!: pe))- puppetIfStyleCondition :: Parser (Pair Expression (V.Vector Statement)) puppetIfStyleCondition = (:!:) <$> expression <*> braces statementList -unlessCondition :: Parser CondStatement+unlessCondition :: Parser ConditionalDecl unlessCondition = do p <- getPosition reserved "unless" (cond :!: stmts) <- puppetIfStyleCondition pe <- getPosition- return (CondStatement (V.singleton (Not cond :!: stmts)) (p :!: pe))+ return (ConditionalDecl (V.singleton (Not cond :!: stmts)) (p :!: pe)) -ifCondition :: Parser CondStatement+ifCondition :: Parser ConditionalDecl ifCondition = do p <- getPosition reserved "if"@@ -411,9 +409,9 @@ then [] else [Terminal (UBoolean True) :!: elsecond] pe <- getPosition- return (CondStatement (V.fromList (maincond : others ++ ec)) (p :!: pe))+ return (ConditionalDecl (V.fromList (maincond : others ++ ec)) (p :!: pe)) -caseCondition :: Parser CondStatement+caseCondition :: Parser ConditionalDecl caseCondition = do let puppetRegexpCase = do reg <- termRegexp@@ -440,7 +438,7 @@ expr1 <- expression condlist <- braces (some (puppetRegexpCase <|> defaultCase <|> puppetCase)) pe <- getPosition- return (CondStatement (V.fromList (map (condsToExpression expr1) (concat condlist))) (p :!: pe) )+ return (ConditionalDecl (V.fromList (map (condsToExpression expr1) (concat condlist))) (p :!: pe) ) data OperatorChain a = OperatorChain a LinkType (OperatorChain a) | EndOfChain a@@ -461,42 +459,16 @@ depOperator = (operator "->" *> pure RBefore) <|> (operator "~>" *> pure RNotify) --- | Used to parse chains of resource relations-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) -resourceGroup :: Parser [ResDec]-resourceGroup = do- let resourceName = token stringExpression- resourceDeclaration = do- p <- getPosition- names <- brackets (sepComma1 resourceName) <|> fmap return resourceName- void $ symbolic ':'- vals <- fmap V.fromList (sepComma assignment)- pe <- getPosition- 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 [ ResDec rtype rname conts virtuality pos | (rname, conts, pos) <- concat x ] -assignment :: Parser (Pair T.Text Expression)-assignment = (:!:) <$> bw <*> (symbol "=>" *> expression)+assignment :: Parser AttributeDecl+assignment = AttributeDecl <$> key <*> arrowOp <*> expression where- bw = identl (satisfy isAsciiLower) (satisfy acceptable) <?> "Assignment key"+ key = identl (satisfy isAsciiLower) (satisfy acceptable) <?> "Assignment key" acceptable x = isAsciiLower x || isAsciiUpper x || isDigit x || (x == '_') || (x == '-')+ arrowOp =+ (symbol "=>" *> pure AssignArrow)+ <|> (symbol "+>" *> pure AppendArrow) searchExpression :: Parser SearchExpression searchExpression = makeExprParser (token searchterm) searchTable@@ -512,8 +484,8 @@ term <- stringExpression return (opr attrib term) -resourceCollection :: Position -> T.Text -> Parser RColl-resourceCollection p restype = do+resCollDecl :: Position -> T.Text -> Parser ResCollDecl+resCollDecl p restype = do openchev <- some (char '<') when (length openchev > 2) (fail "Too many brackets") void $ symbolic '|'@@ -526,10 +498,10 @@ then Collector else ExportedCollector pe <- getPosition- return (RColl collectortype restype e (V.fromList overrides) (p :!: pe) )+ return (ResCollDecl collectortype restype e (V.fromList overrides) (p :!: pe) ) -classDefinition :: Parser ClassDecl-classDefinition = do+classDecl :: Parser ClassDecl+classDecl = do p <- getPosition reserved "class" ClassDecl <$> className@@ -538,70 +510,61 @@ <*> braces statementList <*> ( (p :!:) <$> getPosition ) -mainFunctionCall :: Parser MFC-mainFunctionCall = do+mainFuncDecl :: Parser MainFuncDecl+mainFuncDecl = do p <- getPosition (fname, args) <- genFunctionCall True pe <- getPosition- return (MFC fname args (p :!: pe))+ return (MainFuncDecl fname args (p :!: pe)) -mainHFunctionCall :: Parser SFC-mainHFunctionCall = do+hoLambdaDecl :: Parser HigherOrderLambdaDecl+hoLambdaDecl = do p <- getPosition- fc <- try hfunctionCall+ fc <- try lambdaCall pe <- getPosition- return (SFC fc (p :!: pe))+ return (HigherOrderLambdaDecl fc (p :!: pe)) -dotCall :: Parser SFC-dotCall = do+dotLambdaDecl :: Parser HigherOrderLambdaDecl+dotLambdaDecl = do p <- getPosition ex <- expression pe <- getPosition hf <- case ex of- FunctionApplication e (Terminal (UHFunctionCall hf)) -> do- unless (S.isNothing (hf ^. hfexpr)) (fail "Can't call a function with . and ()")- return (hf & hfexpr .~ S.Just e)- Terminal (UHFunctionCall hf) -> do- when (S.isNothing (hf ^. hfexpr)) (fail "This function needs data to operate on")+ 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 ^. hftype == HFEach) (fail "Expected 'each', the other types of method calls are not supported by language-puppet at the statement level.")- return (SFC hf (p :!: pe))+ 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)) -data ChainableStuff = ChainResColl RColl- | ChainResDecl ResDec- | ChainResRefr T.Text [Expression] PPosition -resourceDefaults :: Parser DefaultDec-resourceDefaults = do+resDefaultDecl :: Parser ResDefaultDecl+resDefaultDecl = do p <- getPosition rnd <- resourceNameRef let assignmentList = V.fromList <$> sepComma1 assignment asl <- braces assignmentList pe <- getPosition- return (DefaultDec rnd asl (p :!: pe))+ return (ResDefaultDecl rnd asl (p :!: pe)) -resourceOverride :: Parser [ResOver]-resourceOverride = do+resOverrideDecl :: Parser [ResOverrideDecl]+resOverrideDecl = do p <- getPosition restype <- resourceNameRef names <- brackets (expression `sepBy1` comma) <?> "Resource reference values" assignments <- V.fromList <$> braces (sepComma assignment) pe <- getPosition- return [ ResOver restype n assignments (p :!: pe) | n <- names ]--extractResRef :: ChainableStuff -> [(T.Text, Expression, PPosition)]-extractResRef (ChainResColl _) = []-extractResRef (ChainResDecl (ResDec rt rn _ _ pp)) = [(rt,rn,pp)]-extractResRef (ChainResRefr rt rns pp) = [(rt,rn,pp) | rn <- rns]--extractChainStatement :: ChainableStuff -> [Statement]-extractChainStatement (ChainResColl r) = [ResourceCollection r]-extractChainStatement (ChainResDecl d) = [ResourceDeclaration d]-extractChainStatement ChainResRefr{} = []+ return [ ResOverrideDecl restype n assignments (p :!: pe) | n <- names ] -chainableStuff :: Parser [Statement]-chainableStuff = do+-- | 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 <- getPosition restype <- resourceNameRef@@ -610,67 +573,99 @@ resnames <- brackets (expression `sepBy1` comma) pe <- getPosition pure (ChainResRefr restype resnames (p :!: pe))- _ -> ChainResColl <$> resourceCollection p restype- chain <- parseRelationships $ pure <$> try withresname <|> map ChainResDecl <$> resourceGroup+ _ -> 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 (Dep (rt1 :!: rn1) (rt2 :!: rn2) lt (pe1 :!: ps2))- return $ map Dependency relations <> (chain ^.. folded . folded . to extractChainStatement . folded)+ return (DepDecl (rt1 :!: rn1) (rt2 :!: rn2) lt (pe1 :!: ps2))+ return $ map DependencyDeclaration relations <> (chain ^.. folded . folded . to extractChainStatement . folded)+ where+ extractResRef :: ChainableRes -> [(T.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 = token stringExpression+ resourceDeclaration = do+ p <- getPosition+ names <- brackets (sepComma1 resourceName) <|> fmap return resourceName+ void $ symbolic ':'+ vals <- fmap V.fromList (sepComma assignment)+ pe <- getPosition+ 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 . SHFunctionCall <$> try dotCall)- <|> (pure . VariableAssignment <$> variableAssignment)- <|> (map Node <$> nodeStmt)- <|> (pure . DefineDeclaration <$> defineStmt)- <|> (pure . ConditionalStatement <$> unlessCondition)- <|> (pure . ConditionalStatement <$> ifCondition)- <|> (pure . ConditionalStatement <$> caseCondition)- <|> (pure . DefaultDeclaration <$> try resourceDefaults)- <|> (map ResourceOverride <$> try resourceOverride)- <|> chainableStuff- {-- <|> resourceGroup- <|> rrGroup- -}- <|> (pure . ClassDeclaration <$> classDefinition)- <|> (pure . SHFunctionCall <$> mainHFunctionCall)- <|> (pure . MainFunctionCall <$> mainFunctionCall)+ (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" -statementList :: Parser (V.Vector Statement)-statementList = fmap (V.fromList . concat) (many statement) -{--- Stuff related to the new functions with "lambdas"--}--parseHFunction :: Parser HigherFuncType-parseHFunction = (reserved "each" *> pure HFEach)- <|> (reserved "map" *> pure HFMap )- <|> (reserved "reduce" *> pure HFReduce)- <|> (reserved "filter" *> pure HFFilter)- <|> (reserved "slice" *> pure HFSlice)--parseHParams :: Parser BlockParameters-parseHParams = between (symbolic '|') (symbolic '|') hp- where- acceptablePart = T.pack <$> identifier- hp = do- vars <- (char '$' *> acceptablePart) `sepBy1` comma- case vars of- [a] -> return (BPSingle a)- [a,b] -> return (BPPair a b)- _ -> fail "Invalid number of variables between the pipes"+statementList :: Parser (V.Vector Statement)+statementList = (V.fromList . concat) <$> many statement -hfunctionCall :: Parser HFunctionCall-hfunctionCall = do+lambdaCall :: Parser HOLambdaCall+lambdaCall = do let toStrict (Just x) = S.Just x toStrict Nothing = S.Nothing- HFunctionCall <$> parseHFunction+ HOLambdaCall <$> lambFunc <*> fmap (toStrict . join) (optional (parens (optional expression)))- <*> parseHParams+ <*> lambParams <*> (symbolic '{' *> fmap (V.fromList . concat) (many (try statement))) <*> fmap toStrict (optional expression) <* symbolic '}'+ where+ lambFunc :: Parser LambdaFunc+ lambFunc = (reserved "each" *> pure LambEach)+ <|> (reserved "map" *> pure LambMap )+ <|> (reserved "reduce" *> pure LambReduce)+ <|> (reserved "filter" *> pure LambFilter)+ <|> (reserved "slice" *> pure LambSlice)+ lambParams :: Parser LambdaParameters+ lambParams = between (symbolic '|') (symbolic '|') hp+ where+ acceptablePart = T.pack <$> identifier+ hp = do+ vars <- (char '$' *> acceptablePart) `sepBy1` comma+ case vars of+ [a] -> return (BPSingle a)+ [a,b] -> return (BPPair a b)+ _ -> fail "Invalid number of variables between the pipes"
Puppet/Parser/PrettyPrinter.hs view
@@ -60,14 +60,14 @@ pretty (Terminal a) = pretty a pretty (FunctionApplication e1 e2) = parens (pretty e1) <> text "." <> pretty e2 -instance Pretty HigherFuncType where- pretty HFEach = bold $ red $ text "each"- pretty HFMap = bold $ red $ text "map"- pretty HFReduce = bold $ red $ text "reduce"- pretty HFFilter = bold $ red $ text "filter"- pretty HFSlice = bold $ red $ text "slice"+instance Pretty LambdaFunc where+ pretty LambEach = bold $ red $ text "each"+ pretty LambMap = bold $ red $ text "map"+ pretty LambReduce = bold $ red $ text "reduce"+ pretty LambFilter = bold $ red $ text "filter"+ pretty LambSlice = bold $ red $ text "slice" -instance Pretty BlockParameters where+instance Pretty LambdaParameters where pretty b = magenta (char '|') <+> vars <+> magenta (char '|') where vars = case b of@@ -81,7 +81,7 @@ pretty (AndSearch s1 s2) = parens (pretty s1) <+> text "and" <+> parens (pretty s2) pretty (OrSearch s1 s2) = parens (pretty s1) <+> text "and" <+> parens (pretty s2) -instance Pretty UValue where+instance Pretty UnresolvedValue where pretty (UBoolean True) = dullmagenta $ text "true" pretty (UBoolean False) = dullmagenta $ text "false" pretty (UString s) = char '"' <> dullcyan (ttext (stringEscape s)) <> char '"'@@ -99,10 +99,10 @@ pretty (URegexp (CompRegex r _)) = char '/' <> text (T.unpack r) <> char '/' pretty (UVariableReference v) = dullblue (char '$' <> text (T.unpack v)) pretty (UFunctionCall f args) = showFunc f args- pretty (UHFunctionCall c) = pretty c+ pretty (UHOLambdaCall c) = pretty c -instance Pretty HFunctionCall where- pretty (HFunctionCall hf me bp stts mee) = pretty hf <> mme <+> pretty bp <+> nest 2 (char '{' <$> ppStatements stts <> mmee) <$> char '}'+instance Pretty HOLambdaCall where+ pretty (HOLambdaCall hf me bp stts mee) = pretty hf <> mme <+> pretty bp <+> nest 2 (char '{' <$> ppStatements stts <> mmee) <$> char '}' where mme = case me of S.Just x -> mempty <+> pretty x@@ -120,20 +120,23 @@ pretty RBefore = "->" pretty RSubscribe = "<~" +instance Pretty ArrowOp where+ pretty AssignArrow = "=>"+ pretty AppendArrow = "+>"+ showPos :: Position -> Doc showPos p = green (char '#' <+> string (show p)) showPPos :: PPosition -> Doc showPPos p = green (char '#' <+> string (show (S.fst p))) -showAss :: V.Vector (Pair T.Text Expression) -> Doc-showAss v = folddoc (\a b -> a <> char ',' <$> b) rh lst+showAss :: V.Vector AttributeDecl -> Doc+showAss vx = folddoc (\a b -> a <> char ',' <$> b) prettyDecl (V.toList vx) where folddoc _ _ [] = empty- folddoc docAppend docGen (x:xs) = foldl docAppend (docGen x) (map docGen xs)- lst = V.toList v- maxlen = maximum (map (T.length . S.fst) lst)- rh (k :!: val) = dullblue (fill maxlen (text (T.unpack k))) <+> text "=>" <+> pretty val+ folddoc acc docGen (x:xs) = foldl acc (docGen x) (map docGen xs)+ maxlen = maximum (fmap (\(AttributeDecl k _ _) -> T.length k) vx)+ prettyDecl (AttributeDecl k op v) = dullblue (fill maxlen (ttext k)) <+> pretty op <+> pretty v showArgs :: V.Vector (Pair T.Text (S.Maybe Expression)) -> Doc showArgs vec = tupled (map ra lst)@@ -156,8 +159,8 @@ pretty (NodeMatch r) = pretty (URegexp r) instance Pretty Statement where- pretty (SHFunctionCall (SFC c p)) = pretty c <+> showPPos p- pretty (ConditionalStatement (CondStatement conds p))+ pretty (HigherOrderLambdaDeclaration (HigherOrderLambdaDecl c p)) = pretty c <+> showPPos p+ pretty (ConditionalDeclaration (ConditionalDecl conds p)) | V.null conds = empty | otherwise = text "if" <+> pretty firstcond <+> showPPos p <+> braceStatements firststts <$> vcat (map rendernexts xs) where@@ -165,10 +168,10 @@ rendernexts (Terminal (UBoolean True) :!: st) = text "else" <+> braceStatements st rendernexts (c :!: st) | V.null st = empty | otherwise = text "elsif" <+> pretty c <+> braceStatements st- pretty (MainFunctionCall (MFC funcname args p)) = showFunc funcname args <+> showPPos p- pretty (DefaultDeclaration (DefaultDec rtype defaults p)) = capitalize rtype <+> nest 2 (char '{' <+> showPPos p <$> showAss defaults) <$> char '}'- pretty (ResourceOverride (ResOver rtype rnames overs p)) = pretty (UResourceReference rtype rnames) <+> nest 2 (char '{' <+> showPPos p <$> showAss overs) <$> char '}'- pretty (ResourceDeclaration (ResDec rtype rname args virt p)) = nest 2 (red vrt <> dullgreen (text (T.unpack rtype)) <+> char '{' <+> showPPos p+ pretty (MainFunctionDeclaration (MainFuncDecl funcname args p)) = showFunc funcname args <+> showPPos p+ pretty (ResourceDefaultDeclaration (ResDefaultDecl rtype defaults p)) = capitalize rtype <+> nest 2 (char '{' <+> showPPos p <$> showAss defaults) <$> char '}'+ pretty (ResourceOverrideDeclaration (ResOverrideDecl rtype rnames overs p)) = pretty (UResourceReference rtype rnames) <+> nest 2 (char '{' <+> showPPos p <$> showAss overs) <$> char '}'+ pretty (ResourceDeclaration (ResDecl rtype rname args virt p)) = nest 2 (red vrt <> dullgreen (text (T.unpack rtype)) <+> char '{' <+> showPPos p <$> nest 2 (pretty rname <> char ':' <$> showAss args)) <$> char '}' where@@ -177,22 +180,22 @@ Virtual -> char '@' Exported -> text "@@" ExportedRealized -> text "!!"- pretty (DefineDeclaration (DefineDec cname args stts p)) = dullyellow (text "define") <+> dullgreen (ttext cname) <> showArgs args <+> showPPos p <$> braceStatements stts+ pretty (DefineDeclaration (DefineDecl cname args stts p)) = dullyellow (text "define") <+> dullgreen (ttext cname) <> showArgs args <+> showPPos p <$> braceStatements stts pretty (ClassDeclaration (ClassDecl cname args inherit stts p)) = dullyellow (text "class") <+> dullgreen (text (T.unpack cname)) <> showArgs args <> inheritance <+> showPPos p <$> braceStatements stts where inheritance = case inherit of S.Nothing -> empty S.Just x -> empty <+> text "inherits" <+> text (T.unpack x)- pretty (VariableAssignment (VarAss a b p)) = dullblue (char '$' <> text (T.unpack a)) <+> char '=' <+> pretty b <+> showPPos p- pretty (Node (Nd nodename stmts i p)) = dullyellow (text "node") <+> pretty nodename <> inheritance <+> showPPos p <$> braceStatements stmts+ pretty (VarAssignmentDeclaration (VarAssignDecl a b p)) = dullblue (char '$' <> text (T.unpack a)) <+> char '=' <+> pretty b <+> showPPos p+ pretty (NodeDeclaration (NodeDecl nodename stmts i p)) = dullyellow (text "node") <+> pretty nodename <> inheritance <+> showPPos p <$> braceStatements stmts where inheritance = case i of S.Nothing -> empty S.Just n -> empty <+> text "inherits" <+> pretty n- pretty (Dependency (Dep (st :!: sn) (dt :!: dn) lt p)) = pretty (UResourceReference st sn) <+> pretty lt <+> pretty (UResourceReference dt dn) <+> showPPos p+ pretty (DependencyDeclaration (DepDecl (st :!: sn) (dt :!: dn) lt p)) = pretty (UResourceReference st sn) <+> pretty lt <+> pretty (UResourceReference dt dn) <+> showPPos p pretty (TopContainer a b) = text "TopContainer:" <+> braces ( nest 2 (string "TOP" <$> braceStatements a <$> string "STATEMENT" <$> pretty b))- pretty (ResourceCollection (RColl coltype restype search overrides p)) = capitalize restype <> enc (pretty search) <+> overs+ pretty (ResourceCollectionDeclaration (ResCollDecl coltype restype search overrides p)) = capitalize restype <> enc (pretty search) <+> overs where overs | V.null overrides = showPPos p | otherwise = nest 2 (char '{' <+> showPPos p <$> showAss overrides) <$> char '}'
Puppet/Parser/Types.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-} -- | All the types used for parsing, and helpers working on these types. module Puppet.Parser.Types ( -- * Position management@@ -18,11 +19,12 @@ -- ** Expressions Expression(..), SelectorCase(..),- UValue(..),- HigherFuncType(..),- HFunctionCall(..),- HasHFunctionCall(..),- BlockParameters(..),+ UnresolvedValue(..),+ LambdaFunc(..),+ HOLambdaCall(..),+ ChainableRes(..),+ HasHOLambdaCall(..),+ LambdaParameters(..), CompRegex(..), CollectorType(..), Virtuality(..),@@ -31,44 +33,46 @@ -- ** Search Expressions SearchExpression(..), -- ** Statements- Statement(..),- ResDec(..),- DefaultDec(..),- ResOver(..),- CondStatement(..),+ ArrowOp(..),+ AttributeDecl(..),+ ConditionalDecl(..), ClassDecl(..),- DefineDec(..),- Nd(..),- VarAss(..),- MFC(..),- SFC(..),- RColl(..),- Dep(..)+ ResDefaultDecl(..),+ DepDecl(..),+ Statement(..),+ ResDecl(..),+ ResOverrideDecl(..),+ DefineDecl(..),+ NodeDecl(..),+ VarAssignDecl(..),+ MainFuncDecl(..),+ HigherOrderLambdaDecl(..),+ ResCollDecl(..) ) where - import Control.Lens- import Data.Aeson import Data.Char (toUpper) import Data.Hashable import qualified Data.Maybe.Strict as S import Data.Scientific import Data.String+import Data.Text (Text) import qualified Data.Text as T import Data.Tuple.Strict import qualified Data.Vector as V +import GHC.Exts import GHC.Generics import Text.Megaparsec.Pos import Text.Regex.PCRE.String -- | Properly capitalizes resource types-capitalizeRT :: T.Text -> T.Text+capitalizeRT :: Text -> Text capitalizeRT = T.intercalate "::" . map capitalize' . T.splitOn "::" where- capitalize' :: T.Text -> T.Text+ capitalize' :: Text -> Text capitalize' t | T.null t = T.empty | otherwise = T.cons (toUpper (T.head t)) (T.tail t) @@ -88,71 +92,92 @@ lSourceColumn = lens sourceColumn setSourceColumn -- | Generates an initial position based on a filename.-initialPPos :: T.Text -> PPosition+initialPPos :: Text -> PPosition initialPPos x = let i = initialPos (T.unpack x) in (i :!: i) -- | Generates a 'PPosition' based on a filename and line number.-toPPos :: T.Text -> Int -> PPosition+toPPos :: Text -> Int -> PPosition toPPos fl ln = let p = newPos (T.unpack fl) ln (-1) in (p :!: p) --- | The distinct Puppet /higher order functions/-data HigherFuncType = HFEach- | HFMap- | HFReduce- | HFFilter- | HFSlice- deriving (Eq, Show)+-- | High Order "lambdas"+data LambdaFunc+ = LambEach+ | LambMap+ | LambReduce+ | LambFilter+ | LambSlice+ deriving (Eq, Show) --- | Currently only two types of block parameters are supported, single--- values and pairs.-data BlockParameters = BPSingle !T.Text -- ^ @|k|@- | BPPair !T.Text !T.Text -- ^ @|k,v|@- deriving (Eq, Show)+-- | Lambda block parameters:+-- Currently only two types of block parameters are supported:+-- single values and pairs.+data LambdaParameters+ = BPSingle !Text -- ^ @|k|@+ | BPPair !Text !Text -- ^ @|k,v|@+ deriving (Eq, Show) --- The description of the /higher level function/ call.-data HFunctionCall = HFunctionCall- { _hftype :: !HigherFuncType- , _hfexpr :: !(S.Maybe Expression)- , _hfparams :: !BlockParameters- , _hfstatements :: !(V.Vector Statement)- , _hfexpression :: !(S.Maybe Expression)+-- 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 CompRegex = CompRegex !T.Text !Regex+data ChainableRes+ = ChainResColl !ResCollDecl+ | ChainResDecl !ResDecl+ | ChainResRefr !Text [Expression] !PPosition+ deriving (Show, Eq)++data AttributeDecl = AttributeDecl !Text !ArrowOp !Expression+ deriving (Show, Eq)+data ArrowOp+ = AppendArrow -- ^ `+>`+ | AssignArrow -- ^ `=>`+ deriving (Show, Eq)++data CompRegex = CompRegex !Text !Regex instance Show CompRegex where show (CompRegex t _) = show t instance Eq CompRegex where (CompRegex a _) == (CompRegex b _) = a == b -- | An unresolved value, typically the parser's output.-data UValue+data UnresolvedValue = UBoolean !Bool -- ^ Special tokens generated when parsing the @true@ or @false@ literals.- | UString !T.Text -- ^ Raw string.+ | 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 !T.Text !Expression -- ^ A Resource[reference]+ | 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 !T.Text- | UFunctionCall !T.Text !(V.Vector Expression)- | UHFunctionCall !HFunctionCall- | UNumber Scientific+ | UVariableReference !Text+ | UFunctionCall !Text !(V.Vector Expression)+ | UHOLambdaCall !HOLambdaCall+ | UNumber !Scientific deriving (Show, Eq) +instance IsList UnresolvedValue where+ type Item UnresolvedValue = Expression+ fromList = UArray . V.fromList+ toList u = case u of+ UArray lst -> V.toList lst+ _ -> [Terminal u] -instance IsString UValue where+instance IsString UnresolvedValue where fromString = UString . T.pack ---data SelectorCase = SelectorValue UValue- | SelectorDefault- deriving (Eq, Show)+data SelectorCase+ = SelectorValue !UnresolvedValue+ | SelectorDefault+ deriving (Eq, Show) -- | The 'Expression's data Expression@@ -179,9 +204,16 @@ | 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 !UValue+ | Terminal !UnresolvedValue -- ^ Terminal object contains no expression deriving (Eq, Show) +instance IsList Expression where+ type Item Expression = Expression+ fromList = Terminal . fromList+ toList u = case u of+ Terminal t -> toList t+ _ -> [u]+ instance Num Expression where (+) = Addition (-) = Substraction@@ -200,33 +232,43 @@ instance IsString Expression where fromString = Terminal . fromString +-- | Search expression inside collector `<| searchexpr |>` data SearchExpression- = EqualitySearch !T.Text !Expression- | NonEqualitySearch !T.Text !Expression+ = EqualitySearch !Text !Expression+ | NonEqualitySearch !Text !Expression | AndSearch !SearchExpression !SearchExpression | OrSearch !SearchExpression !SearchExpression | AlwaysTrue deriving (Eq, Show) -data CollectorType = Collector | ExportedCollector+data CollectorType+ = Collector+ | ExportedCollector deriving (Eq, Show) -data Virtuality = Normal -- ^ Normal resource, that will be included in the catalog- | Virtual -- ^ Type for virtual resources- | Exported -- ^ Type for exported resources- | ExportedRealized -- ^ These are resources that are exported AND included in the catalog- deriving (Generic, Eq, Show)+data Virtuality+ = Normal -- ^ Normal resource, that will be included in the catalog+ | Virtual -- ^ Type for virtual resources+ | Exported -- ^ Type for exported resources+ | ExportedRealized -- ^ These are resources that are exported AND included in the catalogderiving (Generic, Eq, Show)+ deriving (Eq, Show) -data NodeDesc = NodeName !T.Text- | NodeMatch !CompRegex- | NodeDefault- deriving (Show, Eq)+data NodeDesc+ = NodeName !Text+ | NodeMatch !CompRegex+ | NodeDefault+ deriving (Show, Eq) -- | Relationship link type.-data LinkType = RNotify | RRequire | RBefore | RSubscribe deriving(Show, Eq,Generic)+data LinkType+ = RNotify+ | RRequire+ | RBefore+ | RSubscribe+ deriving(Show, Eq,Generic) instance Hashable LinkType -rel2text :: LinkType -> T.Text+rel2text :: LinkType -> Text rel2text RNotify = "notify" rel2text RRequire = "require" rel2text RBefore = "before"@@ -242,38 +284,57 @@ instance ToJSON LinkType where toJSON = String . rel2text -data ResDec = ResDec !T.Text !Expression !(V.Vector (Pair T.Text Expression)) !Virtuality !PPosition deriving (Eq, Show)-data DefaultDec = DefaultDec !T.Text !(V.Vector (Pair T.Text Expression)) !PPosition deriving (Eq, Show)-data ResOver = ResOver !T.Text !Expression !(V.Vector (Pair T.Text Expression)) !PPosition deriving (Eq, Show)+-- | Resource declaration: e.g `file { mode => 755}`+data ResDecl = ResDecl !Text !Expression !(V.Vector AttributeDecl) !Virtuality !PPosition deriving (Eq, Show)++-- | Resource default: e.g `File { mode => 755 }`+-- https://docs.puppetlabs.com/puppet/latest/reference/lang_defaults.html#language:-resource-default-statements+data ResDefaultDecl = ResDefaultDecl !Text !(V.Vector AttributeDecl) !PPosition deriving (Eq, Show)++-- | Resource override: e.g `File['title'] { mode => 755}`+-- https://docs.puppetlabs.com/puppet/latest/reference/lang_resources_advanced.html#amending-attributes-with-a-resource-reference+data ResOverrideDecl = ResOverrideDecl !Text !Expression !(V.Vector AttributeDecl) !PPosition deriving (Eq, Show)+ -- | All types of conditional statements (@case@, @if@, etc.) are stored as an ordered list of pair (condition, statements) -- (interpreted as "if first cond is true, choose first statements, else take the next pair, check the condition ...")-data CondStatement = CondStatement !(V.Vector (Pair Expression (V.Vector Statement))) !PPosition deriving (Eq, Show)-data ClassDecl = ClassDecl !T.Text !(V.Vector (Pair T.Text (S.Maybe Expression))) !(S.Maybe T.Text) !(V.Vector Statement) !PPosition deriving (Eq, Show)-data DefineDec = DefineDec !T.Text !(V.Vector (Pair T.Text (S.Maybe Expression))) !(V.Vector Statement) !PPosition deriving (Eq, Show)-data Nd = Nd !NodeDesc !(V.Vector Statement) !(S.Maybe NodeDesc) !PPosition deriving (Eq, Show)-data VarAss = VarAss !T.Text !Expression !PPosition deriving (Eq, Show)-data MFC = MFC !T.Text !(V.Vector Expression) !PPosition deriving (Eq, Show)+data ConditionalDecl = ConditionalDecl !(V.Vector (Pair Expression (V.Vector Statement))) !PPosition deriving (Eq, Show)++data ClassDecl = ClassDecl !Text !(V.Vector (Pair Text (S.Maybe Expression))) !(S.Maybe Text) !(V.Vector Statement) !PPosition deriving (Eq, Show)+data DefineDecl = DefineDecl !Text !(V.Vector (Pair Text (S.Maybe Expression))) !(V.Vector Statement) !PPosition deriving (Eq, Show)++-- | A node is a collection of statements + maybe an inherit node+data NodeDecl = NodeDecl !NodeDesc !(V.Vector Statement) !(S.Maybe NodeDesc) !PPosition deriving (Eq, Show)++-- | e.g $newvar = 'world'+data VarAssignDecl = VarAssignDecl !Text !Expression !PPosition deriving (Eq, Show)++data MainFuncDecl = MainFuncDecl !Text !(V.Vector Expression) !PPosition deriving (Eq, Show)+ -- | /Higher order function/ call.-data SFC = SFC !HFunctionCall !PPosition deriving (Eq, Show)--- | For all types of collectors.-data RColl = RColl !CollectorType !T.Text !SearchExpression !(V.Vector (Pair T.Text Expression)) !PPosition deriving (Eq, Show)-data Dep = Dep !(Pair T.Text Expression) !(Pair T.Text Expression) !LinkType !PPosition deriving (Eq, Show)+data HigherOrderLambdaDecl = HigherOrderLambdaDecl !HOLambdaCall !PPosition deriving (Eq, Show) +-- | Resource Collector including exported collector (`<<| |>>`)+-- e.g `User <| title == 'jenkins' |> { groups +> "docker"}`+-- https://docs.puppetlabs.com/puppet/latest/reference/lang_collectors.html#language:-resource-collectors+data ResCollDecl = ResCollDecl !CollectorType !Text !SearchExpression !(V.Vector AttributeDecl) !PPosition deriving (Eq, Show)++data DepDecl = DepDecl !(Pair Text Expression) !(Pair Text Expression) !LinkType !PPosition deriving (Eq, Show)+ -- | All the possible statements data Statement- = ResourceDeclaration !ResDec- | DefaultDeclaration !DefaultDec- | ResourceOverride !ResOver- | ConditionalStatement !CondStatement+ = ResourceDeclaration !ResDecl+ | ResourceDefaultDeclaration !ResDefaultDecl+ | ResourceOverrideDeclaration !ResOverrideDecl+ | ResourceCollectionDeclaration !ResCollDecl | ClassDeclaration !ClassDecl- | DefineDeclaration !DefineDec- | Node !Nd- | VariableAssignment !VarAss- | MainFunctionCall !MFC- | SHFunctionCall !SFC- | ResourceCollection !RColl- | Dependency !Dep- | TopContainer !(V.Vector Statement) !Statement -- ^ This is a special statement that is used to include the expressions that are top level. This is certainly buggy, but probably just like the original implementation.+ | 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) -makeClassy ''HFunctionCall+makeClassy ''HOLambdaCall
+ Puppet/Parser/Utils.hs view
@@ -0,0 +1,12 @@+module Puppet.Parser.Utils where++import Text.Megaparsec.Pos++import Puppet.Parser.Types+++dummyppos :: PPosition+dummyppos = initialPPos "dummy"++dummypos :: Position+dummypos = initialPos "dummy"
− Puppet/Pathes.hs
@@ -1,23 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-module Puppet.Pathes where--import Control.Lens-import Data.Monoid--data PuppetDirPaths = PuppetDirPaths- { _baseDir :: FilePath -- ^ Puppet base working directory- , _manifestPath :: FilePath -- ^ The path to the manifests.- , _modulesPath :: FilePath -- ^ The path to the modules.- , _templatesPath :: FilePath -- ^ The path to the template.- , _testPath :: FilePath -- ^ The path to a tests folders to hold tests files such as the pdbfiles.- }--makeClassy ''PuppetDirPaths--defaultPathes :: String -> PuppetDirPaths-defaultPathes basedir = PuppetDirPaths basedir manifestdir modulesdir templatedir testdir- where- manifestdir = basedir <> "/manifests"- modulesdir = basedir <> "/modules"- templatedir = basedir <> "/templates"- testdir = basedir <> "/tests"
+ Puppet/Paths.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE TemplateHaskell #-}+module Puppet.Paths where++import Control.Lens+import Data.Monoid++data PuppetDirPaths = PuppetDirPaths+ { _baseDir :: FilePath -- ^ Puppet base working directory+ , _manifestPath :: FilePath -- ^ The path to the manifests.+ , _modulesPath :: FilePath -- ^ The path to the modules.+ , _templatesPath :: FilePath -- ^ The path to the template.+ , _testPath :: FilePath -- ^ The path to a tests folders to hold tests files such as the pdbfiles.+ }++makeClassy ''PuppetDirPaths++puppetPaths :: FilePath -> PuppetDirPaths+puppetPaths basedir = PuppetDirPaths basedir manifestdir modulesdir templatedir testdir+ where+ manifestdir = basedir <> "/manifests"+ modulesdir = basedir <> "/modules"+ templatedir = basedir <> "/templates"+ testdir = basedir <> "/tests"
Puppet/Preferences.hs view
@@ -28,7 +28,7 @@ import Puppet.NativeTypes.Helpers import Puppet.Plugins import Puppet.Stdlib-import Puppet.Pathes+import Puppet.Paths import qualified Puppet.Puppetlabs as Puppetlabs import Puppet.Utils import PuppetDB.Dummy@@ -83,7 +83,7 @@ dfPreferences :: FilePath -> IO (Preferences IO) dfPreferences basedir = do- let dirpaths = defaultPathes basedir+ let dirpaths = puppetPaths basedir modulesdir = dirpaths ^. modulesPath testdir = dirpaths ^. testPath typenames <- fmap (map takeBaseName) (getFiles (T.pack modulesdir) "lib/puppet/type" ".rb")
Puppet/Puppetlabs.hs view
@@ -29,8 +29,8 @@ , ("/docker", "docker_run_flags", mockDockerRunFlags) , ("/postgresql", "postgresql_acls_to_resources_hash", pgAclsToHash) , ("/postgresql", "postgresql_password", pgPassword)- , ("/foreman", "random_password", randomPassword)- , ("/foreman", "cache_data", mockCacheData)+ , ("/extlib", "random_password", randomPassword)+ , ("/extlib", "cache_data", mockCacheData) ] -- | Build the map of available ext functions@@ -58,21 +58,17 @@ -- | The function is pure and always return the same "random" password randomPassword :: MonadThrowPos m => [PValue] -> m PValue-randomPassword x@[PNumber s] =- PString . Text.pack . randomChars <$> toInt s+randomPassword [PNumber s] =+ PString . Text.pack . randomChars <$> scientificToInt s where randomChars n = take n $ randomRs ('a', 'z') (mkStdGen 1)- toInt :: MonadThrowPos m => Scientific -> m Int- toInt s = maybe (throwPosError $ "Unable to convert" <+> pretty x <+> "into an int.")- return- (Sci.toBoundedInteger s) randomPassword _ = throwPosError "expect one single string arguments" mockCacheData :: MonadThrowPos m => [PValue] -> m PValue-mockCacheData [_, b] = return b-mockCacheData arg@_ = throwPosError $ "expect 2 string arguments" <+> pretty arg+mockCacheData [_, _, b] = return b+mockCacheData arg@_ = throwPosError $ "expect 3 string arguments" <+> pretty arg -- | Simple implemenation that does not handle all cases. -- For instance 'auth_option' is currently not implemented.@@ -109,3 +105,9 @@ mockDockerRunFlags :: MonadThrowPos m => [PValue] -> m PValue mockDockerRunFlags arg@[PHash _]= (return . PString . Text.pack . displayNocolor . pretty . head) arg mockDockerRunFlags 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" <+> string (show s) <+> "into an int.")+ return+ (Sci.toBoundedInteger s)
Puppet/Stats.hs view
@@ -22,7 +22,6 @@ type StatsTable = HM.HashMap T.Text StatsPoint newtype MStats = MStats { unMStats :: MVar StatsTable }- -- | Returns the actual statistical values. getStats :: MStats -> IO StatsTable getStats = readMVar . unMStats
Puppet/Stdlib.hs view
@@ -1,17 +1,16 @@ {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TupleSections #-} module Puppet.Stdlib (stdlibFunctions) where -import Puppet.Interpreter.Resolve-import Puppet.Interpreter.Types-import Puppet.PP- import Control.Lens import Control.Monad import Data.Aeson.Lens import qualified Data.ByteString.Base16 as B16 import Data.Char import qualified Data.HashMap.Strict as HM+import Data.Maybe (mapMaybe) import Data.Monoid+import Data.List.Split (chunksOf) import qualified Data.Text as T import qualified Data.Text.Encoding as T import Data.Traversable (for)@@ -21,6 +20,11 @@ import qualified Text.PrettyPrint.ANSI.Leijen as PP import Text.Regex.PCRE.ByteString.Utils +import Puppet.Interpreter.Resolve+import Puppet.Interpreter.Types+import Puppet.Interpreter.Utils+import Puppet.PP+ -- | Contains the implementation of the StdLib functions. stdlibFunctions :: Container ( [PValue] -> InterpreterMonad PValue ) stdlibFunctions = HM.fromList [ singleArgument "abs" puppetAbs@@ -42,6 +46,7 @@ , singleArgument "getvar" getvar , ("getparam", const $ throwPosError "The getparam function is uncool and shall not be implemented in language-puppet") , ("grep", _grep)+ , ("hash", hash) , singleArgument "is_array" isArray , singleArgument "is_domain_name" isDomainName , singleArgument "is_integer" isInteger@@ -55,6 +60,7 @@ , ("merge", merge) , ("member", member) , ("pick", pick)+ , ("pick_default", pickDefault) , ("rstrip", stringArrayFunction T.stripEnd) , singleArgument "size" size , singleArgument "str2bool" str2Bool@@ -138,9 +144,10 @@ bool2num x = throwPosError ("bool2num(): Can't convert" <+> pretty x <+> "to boolean") puppetConcat :: [PValue] -> InterpreterMonad PValue-puppetConcat [PArray a, PArray b] = return (PArray (a <> b))-puppetConcat [a,b] = throwPosError ("concat(): both arguments must be arrays, not" <+> pretty a <+> "or" <+> pretty b)-puppetConcat _ = throwPosError "concat(): expects 2 arguments"+puppetConcat = return . PArray . V.concat . map toArr+ where+ toArr (PArray x) = x+ toArr x = V.singleton x puppetCount :: [PValue] -> InterpreterMonad PValue puppetCount [PArray x] = return (_Integer # V.foldl' cnt 0 x)@@ -207,6 +214,14 @@ _grep [x,_] = throwPosError ("grep(): The first argument must be an Array, not" <+> pretty x) _grep _ = throwPosError "grep(): Expected two arguments." +hash :: [PValue] -> InterpreterMonad PValue+hash [PArray elems] = do+ let xs = mapMaybe assocPairs $ chunksOf 2 $ V.toList elems+ assocPairs [a,b] = Just (a,b)+ assocPairs _ = Nothing+ PHash . HM.fromList <$> mapM (\(k,v) -> (,v) <$> resolvePValueString k) xs+hash _ = throwPosError "hash(): Expected and array."+ isArray :: PValue -> InterpreterMonad PValue isArray = return . PBoolean . has _PArray @@ -262,20 +277,29 @@ hasKey _ = throwPosError "has_key(): expected two arguments." merge :: [PValue] -> InterpreterMonad PValue-merge [PHash a, PHash b] = return (PHash (b `HM.union` a))-merge [a,b] = throwPosError ("merge(): Expects two hashes, not" <+> pretty a <+> pretty b)-merge _ = throwPosError "merge(): Expects two hashes"+merge xs | length xs < 2 = throwPosError "merge(): Expects at least two hashes"+ | otherwise = let hashcontents = mapM (preview _PHash) xs+ in case hashcontents of+ Nothing -> throwPosError "merge(): Expects hashes"+ Just hashes -> return $ PHash (getDual $ foldMap Dual hashes) pick :: [PValue] -> InterpreterMonad PValue pick [] = throwPosError "pick(): must receive at least one non empty value"-pick (a:as)- | a `elem` [PUndef, PString "", PString "undef"] = pick as- | otherwise = return a+pick xs = case filter (`notElem` [PUndef, PString "", PString "undef"]) xs of+ [] -> throwPosError "pick(): no value suitable to be picked"+ (x:_) -> return x +pickDefault :: [PValue] -> InterpreterMonad PValue+pickDefault [] = throwPosError "pick_default(): must receive at least one non empty value"+pickDefault xs = case filter (`notElem` [PUndef, PString "", PString "undef"]) xs of+ [] -> return (last xs)+ (x:_) -> return x+ size :: PValue -> InterpreterMonad PValue size (PHash h) = return (_Integer # fromIntegral (HM.size h)) size (PArray v) = return (_Integer # fromIntegral (V.length v))-size x = throwPosError ("size(): Expects a hash, not" <+> pretty x)+size (PString s) = return (_Integer # fromIntegral (T.length s))+size x = throwPosError ("size(): Expects a hash, and array or a string, not" <+> pretty x) str2Bool :: PValue -> InterpreterMonad PValue str2Bool PUndef = return (PBoolean False)
Puppet/Utils.hs view
@@ -1,31 +1,41 @@ {-# LANGUAGE LambdaCase #-} -- | Those are utility functions, most of them being pretty much self -- explanatory.-module Puppet.Utils- ( textElem- , module Data.Monoid+module Puppet.Utils (+ textElem , getDirectoryContents , takeBaseName , takeDirectory , strictifyEither- , nameThread , loadYamlFile , scientific2text- ) where+ , text2Scientific+ , ifromList, ikeys, isingleton, ifromListWith, iunionWith, iinsertWith+ -- * re-export+ , module Data.Monoid+) where +import Data.Attoparsec.Text (parseOnly, rational) import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.ByteString as BS+import qualified Data.Foldable as F+import Data.Hashable+import qualified Data.HashMap.Strict as HM+import qualified Data.HashSet as HS import Data.Monoid import System.Posix.Directory.ByteString import qualified Data.Either.Strict as S-import Control.Concurrent (myThreadId)-import GHC.Conc (labelThread) import Data.Scientific import Control.Lens import Data.Aeson.Lens import qualified Data.Yaml as Y +text2Scientific :: T.Text -> Maybe Scientific+text2Scientific t = case parseOnly rational t of+ Left _ -> Nothing+ Right s -> Just s+ scientific2text :: Scientific -> T.Text scientific2text n = T.pack $ case n ^? _Integer of Just i -> show i@@ -38,9 +48,6 @@ textElem :: Char -> T.Text -> Bool textElem c = T.any (==c) -nameThread :: String -> IO ()-nameThread n = myThreadId >>= flip labelThread n- getDirectoryContents :: T.Text -> IO [T.Text] getDirectoryContents fpath = do h <- openDirStream (T.encodeUtf8 fpath)@@ -79,7 +86,6 @@ dropFileName :: T.Text -> T.Text dropFileName = fst . splitFileName - -- | Split a filename into directory and file. 'combine' is the inverse. -- -- > Valid x => uncurry (</>) (splitFileName x) == x || fst (splitFileName x) == "./"@@ -104,3 +110,31 @@ loadYamlFile fp = Y.decodeFileEither fp >>= \case Left rr -> error ("Error when parsing " ++ fp ++ ": " ++ show rr) Right x -> return x++-- | helper for hashmap, in case we want another kind of map ..+ifromList :: (Monoid m, At m, F.Foldable f) => f (Index m, IxValue m) -> m+{-# INLINABLE ifromList #-}+ifromList = F.foldl' (\curm (k,v) -> curm & at k ?~ v) mempty++ikeys :: (Eq k, Hashable k) => HM.HashMap k v -> HS.HashSet k+{-# INLINABLE ikeys #-}+ikeys = HS.fromList . HM.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, F.Foldable f) => (IxValue m -> IxValue m -> IxValue m) -> f (Index m, IxValue m) -> m+{-# INLINABLE ifromListWith #-}+ifromListWith f = F.foldl' (\curmap (k,v) -> iinsertWith f k v curmap) mempty++iinsertWith :: At m => (IxValue m -> IxValue m -> IxValue m) -> Index m -> IxValue m -> m -> m+{-# INLINABLE iinsertWith #-}+iinsertWith f k v m = m & at k %~ mightreplace+ where+ mightreplace Nothing = Just v+ mightreplace (Just x) = Just (f v x)++iunionWith :: (Hashable k, Eq k) => (v -> v -> v) -> HM.HashMap k v -> HM.HashMap k v -> HM.HashMap k v+{-# INLINABLE iunionWith #-}+iunionWith = HM.unionWith
PuppetDB/Common.hs view
@@ -47,8 +47,8 @@ -- | Turns a 'FinalCatalog' and 'EdgeMap' into a document that can be -- serialized and fed to @puppet apply@.-generateWireCatalog :: Nodename -> FinalCatalog -> EdgeMap -> WireCatalog-generateWireCatalog ndename finalcat edgemap = WireCatalog ndename "version" edges resources "uiid"+generateWireCatalog :: NodeName -> FinalCatalog -> EdgeMap -> WireCatalog+generateWireCatalog node cat edgemap = WireCatalog node "version" edges resources "uiid" where edges = toVectorOf (folded . to (\li -> PuppetEdge (li ^. linksrc) (li ^. linkdst) (li ^. linkType))) (concatOf folded edgemap)- resources = toVectorOf folded finalcat+ resources = toVectorOf folded cat
PuppetDB/Remote.hs view
@@ -15,9 +15,9 @@ import Data.Aeson import Data.Proxy -type PDBAPIv3 = "nodes" :> QueryParam "query" (Query NodeField) :> Get '[JSON] [PNodeInfo]+type PDBAPIv3 = "nodes" :> QueryParam "query" (Query NodeField) :> Get '[JSON] [NodeInfo] :<|> "nodes" :> Capture "resourcename" Text :> "resources" :> QueryParam "query" (Query ResourceField) :> Get '[JSON] [Resource]- :<|> "facts" :> QueryParam "query" (Query FactField) :> Get '[JSON] [PFactInfo]+ :<|> "facts" :> QueryParam "query" (Query FactField) :> Get '[JSON] [FactInfo] :<|> "resources" :> QueryParam "query" (Query ResourceField) :> Get '[JSON] [Resource] type PDBAPI = "v3" :> PDBAPIv3@@ -39,9 +39,9 @@ (left "operation not supported") (\ndename q -> prettyError $ sgetNodeResources ndename (Just q)) where- sgetNodes :: Maybe (Query NodeField) -> EitherT ServantError IO [PNodeInfo]+ sgetNodes :: Maybe (Query NodeField) -> EitherT ServantError IO [NodeInfo] sgetNodeResources :: Text -> Maybe (Query ResourceField) -> EitherT ServantError IO [Resource]- sgetFacts :: Maybe (Query FactField) -> EitherT ServantError IO [PFactInfo]+ sgetFacts :: Maybe (Query FactField) -> EitherT ServantError IO [FactInfo] sgetResources :: Maybe (Query ResourceField) -> EitherT ServantError IO [Resource] (sgetNodes :<|> sgetNodeResources :<|> sgetFacts :<|> sgetResources) = client api url
PuppetDB/TestDB.hs view
@@ -120,32 +120,32 @@ _ -> False replCat :: DB -> WireCatalog -> EitherT PrettyError IO ()-replCat db wc = liftIO $ atomically $ modifyTVar db (resources . at (wc ^. nodename) ?~ wc)+replCat db wc = liftIO $ atomically $ modifyTVar db (resources . at (wc ^. wireCatalogNodename) ?~ wc) -replFacts :: DB -> [(Nodename, Facts)] -> EitherT PrettyError IO ()+replFacts :: DB -> [(NodeName, Facts)] -> EitherT PrettyError IO () replFacts db lst = liftIO $ atomically $ modifyTVar db $ facts %~ (\r -> foldl' (\curr (n,f) -> curr & at n ?~ f) r lst) -deactivate :: DB -> Nodename -> EitherT PrettyError IO ()+deactivate :: DB -> NodeName -> EitherT PrettyError IO () deactivate db n = liftIO $ atomically $ modifyTVar db $ (resources . at n .~ Nothing) . (facts . at n .~ Nothing) -getFcts :: DB -> Query FactField -> EitherT PrettyError IO [PFactInfo]+getFcts :: DB -> Query FactField -> EitherT PrettyError IO [FactInfo] getFcts db f = fmap (filter (resolveQuery factQuery f) . toFactInfo) (liftIO $ readTVarIO db) where- toFactInfo :: DBContent -> [PFactInfo]+ toFactInfo :: DBContent -> [FactInfo] toFactInfo = concatMap gf . HM.toList . _dbcontentFacts where gf (k,n) = do (fn,fv) <- HM.toList n- return $ PFactInfo k fn fv- factQuery :: FactField -> PFactInfo -> Extracted+ return $ FactInfo k fn fv+ factQuery :: FactField -> FactInfo -> Extracted factQuery t = EText . view l where l = case t of- FName -> factname- FValue -> factval . _PString- FCertname -> nodename+ FName -> factInfoName+ FValue -> factInfoVal . _PString+ FCertname -> factInfoNodename resourceQuery :: ResourceField -> Resource -> Extracted resourceQuery RTag r = r ^. rtags . to ESet@@ -165,13 +165,13 @@ getRes db f = fmap (filter (resolveQuery resourceQuery f) . toResources) (liftIO $ readTVarIO db) where toResources :: DBContent -> [Resource]- toResources = concatMap (V.toList . view wResources) . HM.elems . view resources+ toResources = concatMap (V.toList . view wireCatalogResources) . HM.elems . view resources -getResNode :: DB -> Nodename -> Query ResourceField -> EitherT PrettyError IO [Resource]+getResNode :: DB -> NodeName -> Query ResourceField -> EitherT PrettyError IO [Resource] getResNode db nn f = do c <- liftIO $ readTVarIO db case c ^. resources . at nn of- Just cnt -> return $ filter (resolveQuery resourceQuery f) $ V.toList $ cnt ^. wResources+ Just cnt -> return $ filter (resolveQuery resourceQuery f) $ V.toList $ cnt ^. wireCatalogResources Nothing -> left "Unknown node" commit :: DB -> EitherT PrettyError IO ()@@ -181,13 +181,13 @@ Nothing -> left "No backing file defined" Just bf -> liftIO (encodeFile bf dbc `catches` [ ]) -getNds :: DB -> Query NodeField -> EitherT PrettyError IO [PNodeInfo]+getNds :: DB -> Query NodeField -> EitherT PrettyError IO [NodeInfo] getNds db QEmpty = fmap toNodeInfo (liftIO $ readTVarIO db) where- toNodeInfo :: DBContent -> [PNodeInfo]+ toNodeInfo :: DBContent -> [NodeInfo] toNodeInfo = fmap g . HM.keys . _dbcontentFacts where- g :: Nodename -> PNodeInfo- g = \n -> PNodeInfo n False S.Nothing S.Nothing S.Nothing+ g :: NodeName -> NodeInfo+ g = \n -> NodeInfo n False S.Nothing S.Nothing S.Nothing getNds _ _ = left "getNds with query not implemented"
language-puppet.cabal view
@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: language-puppet-version: 1.1.4.1+version: 1.1.5 synopsis: Tools to parse and evaluate the Puppet DSL. description: This is a set of tools that is supposed to fill all your Puppet needs : syntax checks, catalog compilation, PuppetDB queries, simulationg of complex interactions between nodes, Puppet master replacement, and more ! homepage: http://lpuppet.banquise.net/@@ -61,6 +61,7 @@ other-modules: Erb.Compute , Paths_language_puppet , Puppet.Interpreter.RubyRandom+ , Puppet.Interpreter.Utils , Puppet.Manifests , Puppet.NativeTypes.Concat , Puppet.NativeTypes.Cron@@ -74,56 +75,56 @@ , Puppet.NativeTypes.SshSecure , Puppet.NativeTypes.User , Puppet.NativeTypes.ZoneRecord- , Puppet.Pathes+ , Puppet.Parser.Utils+ , Puppet.Paths , Puppet.Plugins extensions: OverloadedStrings, BangPatterns ghc-options: -Wall -funbox-strict-fields -j1 -- ghc-prof-options: -auto-all -caf-all- build-depends: base >=4.8 && < 4.9- , aeson >= 0.8 && < 0.10- , ansi-wl-pprint == 0.6.*- , attoparsec >= 0.12 && < 0.14- , base16-bytestring == 0.1.*- , bifunctors == 5- , bytestring- , case-insensitive == 1.2.*- , containers == 0.5.*- , cryptonite >= 0.6- , directory == 1.2.*- , either >= 4.3 && < 4.5- , exceptions >= 0.8 && < 0.9- , filecache >= 0.2.9 && < 0.3- , formatting- , hashable == 1.2.*- , hruby >= 0.3.1.6 && <0.4- , hslogger == 1.2.*- , hslua >= 0.4 && < 0.5- , lens >= 4.9 && < 5- , lens-aeson >= 1.0- , memory >= 0.7- , mtl >= 2.2 && < 2.3- , operational >= 0.2.3 && < 0.3- , megaparsec == 4.1.*- , parsec == 3.1.*- , parsers >= 0.11 && < 0.13- , pcre-utils >= 0.1.7 && < 0.2- , process >= 1.1 && < 1.3- , random- , regex-pcre-builtin >= 0.94.4- , scientific >= 0.2 && < 0.4- , servant == 0.4.*- , servant-client == 0.4.*- , semigroups- , split == 0.2.*- , stm == 2.4.*- , strict-base-types == 0.3.*- , text >= 0.11- , time >= 1.5 && < 2- , transformers == 0.4.*- , unix >= 2.6 && < 2.8- , unordered-containers == 0.2.*- , vector == 0.10.*- , yaml >= 0.8.8 && < 0.9+ build-depends: aeson >= 0.8+ , ansi-wl-pprint == 0.6.*+ , attoparsec >= 0.12+ , base >=4.8 && < 4.9+ , base16-bytestring == 0.1.*+ , bytestring+ , case-insensitive == 1.2.*+ , containers == 0.5.*+ , cryptonite >= 0.6+ , directory == 1.2.*+ , either >= 4.3 && < 4.5+ , exceptions >= 0.8 && < 0.9+ , filecache >= 0.2.9 && < 0.3+ , formatting+ , hashable == 1.2.*+ , hruby >= 0.3.2 && < 0.4+ , hslogger == 1.2.*+ , hslua >= 0.4.1 && < 0.5+ , hspec+ , lens >= 4.12 && < 5+ , lens-aeson >= 1.0+ , megaparsec == 4.1.*+ , memory >= 0.7+ , mtl >= 2.2 && < 2.3+ , operational >= 0.2.3 && < 0.3+ , parsec == 3.1.*+ , pcre-utils >= 0.1.7 && < 0.2+ , process >= 1.2+ , random+ , regex-pcre-builtin >= 0.94.4+ , scientific >= 0.2 && < 0.4+ , semigroups+ , servant == 0.4.*+ , servant-client == 0.4.*+ , split == 0.2.*+ , stm == 2.4.*+ , strict-base-types >= 0.3+ , text >= 0.11+ , time >= 1.5 && < 2+ , transformers == 0.4.*+ , unix >= 2.7 && < 2.8+ , unordered-containers == 0.2.*+ , vector >= 0.10+ , yaml >= 0.8.8 && < 0.9 Test-Suite test-evals hs-source-dirs: tests type: exitcode-stdio-1.0@@ -166,13 +167,43 @@ extensions: OverloadedStrings build-depends: language-puppet,base,strict-base-types,lens,text main-is: erb.hs+Test-Suite spec+ hs-source-dirs: tests+ type: exitcode-stdio-1.0+ ghc-options: -Wall -rtsopts -threaded+ extensions: OverloadedStrings+ build-depends: language-puppet,base,strict-base-types,lens,text,hspec,unordered-containers,megaparsec,vector,scientific+ other-modules: Function.ShellquoteSpec+ Function.SizeSpec+ Function.MergeSpec+ Function.EachSpec+ InterpreterSpec+ Helpers+ main-is: Spec.hs executable puppetresources hs-source-dirs: progs extensions: BangPatterns, OverloadedStrings- ghc-options: -Wall -rtsopts -threaded -with-rtsopts "-A2M" -eventlog+ ghc-options: -Wall -rtsopts -funbox-strict-fields -threaded -with-rtsopts "-A2M" -eventlog -- ghc-prof-options: -auto-all -caf-all -fprof-auto- build-depends: language-puppet,base,text,megaparsec,vector,ansi-wl-pprint,bytestring,mtl,hslogger,Diff,unordered-containers,strict-base-types,optparse-applicative >=0.11,regex-pcre-builtin,lens,aeson,yaml,parallel-io,containers,Glob,hspec >= 1.9, either, servant-client+ build-depends: base+ , Glob+ , aeson+ , bytestring+ , containers+ , either+ , hslogger+ , language-puppet+ , lens+ , megaparsec+ , optparse-applicative+ , parallel-io+ , regex-pcre-builtin+ , servant-client+ , strict-base-types+ , text+ , unordered-containers+ , vector main-is: PuppetResources.hs executable pdbquery@@ -180,5 +211,16 @@ extensions: BangPatterns, OverloadedStrings ghc-options: -Wall -rtsopts -threaded -- ghc-prof-options: -auto-all -caf-all -fprof-auto- build-depends: language-puppet,base,optparse-applicative >= 0.11,text,yaml,bytestring,strict-base-types,lens,unordered-containers,vector,either,servant-client+ build-depends: base+ , bytestring+ , either+ , language-puppet+ , lens+ , optparse-applicative+ , servant-client+ , strict-base-types+ , text+ , unordered-containers+ , vector+ , yaml main-is: pdbQuery.hs
progs/PuppetResources.hs view
@@ -31,7 +31,7 @@ import qualified Text.Megaparsec as P import qualified Text.Regex.PCRE.String as REG -import Facter+import qualified Facter import Puppet.Daemon import Puppet.Lens import Puppet.Parser@@ -45,7 +45,7 @@ import PuppetDB.TestDB (loadTestDB) -type QueryFunc = Nodename -> IO (S.Either PrettyError (FinalCatalog, EdgeMap, FinalCatalog, [Resource]))+type QueryFunc = NodeName -> IO (S.Either PrettyError (FinalCatalog, EdgeMap, FinalCatalog, [Resource])) data MultNodes = MultNodes [T.Text] | AllNodes deriving Show @@ -60,7 +60,7 @@ , _optResourceType :: Maybe T.Text , _optResourceName :: Maybe T.Text , _optPuppetdir :: Maybe FilePath- , _optNodename :: Maybe Nodename+ , _optNodename :: Maybe NodeName , _optMultnodes :: Maybe MultNodes , _optDeadcode :: Bool , _optPdburl :: Maybe String@@ -166,15 +166,15 @@ >>= pdbConnect >>= checkError "Error when connecting to the remote PuppetDB" (_, Just file) -> loadTestDB file >>= checkError "Error when initializing the PuppetDB API"- prf <- dfPreferences workingdir <&> prefPDB .~ pdbapi- <&> prefHieraPath .~ _optHieraFile- <&> prefIgnoredmodules %~ (`fromMaybe` _optIgnoredMods)- <&> (if _optStrictMode then prefStrictness .~ Strict else id)- <&> (if _optNoExtraTests then prefExtraTests .~ False else id)- <&> prefLogLevel .~ _optLoglevel- q <- initDaemon prf- let queryfunc = \node -> fmap (unifyFacts (prf ^. prefFactsDefault) (prf ^. prefFactsOverride)) (puppetDBFacts node pdbapi) >>= _dGetCatalog q node- return (queryfunc, pdbapi, _dParserStats q, _dCatalogStats q, _dTemplateStats q)+ pref <- dfPreferences workingdir <&> prefPDB .~ pdbapi+ <&> prefHieraPath .~ _optHieraFile+ <&> prefIgnoredmodules %~ (`fromMaybe` _optIgnoredMods)+ <&> (if _optStrictMode then prefStrictness .~ Strict else id)+ <&> (if _optNoExtraTests then prefExtraTests .~ False else id)+ <&> prefLogLevel .~ _optLoglevel+ d <- initDaemon pref+ let queryfunc = \node -> fmap (unifyFacts (pref ^. prefFactsDefault) (pref ^. prefFactsOverride)) (Facter.puppetDBFacts node pdbapi) >>= getCatalog d node+ return (queryfunc, pdbapi, parserStats d, catalogStats d, templateStats d) where -- merge 3 sets of facts : some defaults, the original set and some override unifyFacts :: Container PValue -> Container PValue -> Container PValue -> Container PValue@@ -193,8 +193,8 @@ Just x -> print x prepareForPuppetApply :: WireCatalog -> WireCatalog-prepareForPuppetApply w =- let res = V.filter (\r -> r ^. rvirtuality == Normal) (w ^. wResources) :: V.Vector Resource+prepareForPuppetApply wcat =+ let res = V.filter (\r -> r ^. rvirtuality == Normal) (wcat ^. wireCatalogResources) :: V.Vector Resource -- step 1 : capitalize resources types (and names in case of -- classes), and filter out exported stuff capi :: RIdentifier -> RIdentifier@@ -205,7 +205,7 @@ aliasMap = HM.fromList $ concatMap genAliasList (res ^.. folded) genAliasList r = map (\n -> (RIdentifier (r ^. rid . itype) n, r ^. rid . iname)) (r ^. rid . iname : r ^.. ralias . folded) nr = V.map (rid %~ capi) res- ne = V.map capEdge (w ^. wEdges)+ ne = V.map capEdge (wcat ^. wireCatalogEdges) capEdge (PuppetEdge a b x) = PuppetEdge (capi a) (capi b) x -- step 2 : replace all references with the resource title in case -- of aliases - yes this sucks@@ -219,9 +219,8 @@ correctEdge (PuppetEdge s d x) = PuppetEdge (correct s) (correct d) x correctResource :: Resource -> Resource correctResource r = r & rrelations %~ HM.fromList . filter (\(x,_) -> aliasMap & has (ix x)) . map (_1 %~ correct) . HM.toList- in (wResources .~ correctResources)- . (wEdges .~ correctEdges)- $ w+ in wcat & (wireCatalogResources .~ correctResources)+ & (wireCatalogEdges .~ correctEdges) -- | Finds the dead code@@ -242,18 +241,18 @@ putDoc ("The following" <+> int (length parseFailed) <+> "files could not be parsed:" </> indent 4 (vcat (map (string . show) parseFailed))) putStrLn "" let getSubStatements s@(ResourceDeclaration{}) = [s]- getSubStatements (ConditionalStatement (CondStatement conds _)) = conds ^.. traverse . _2 . tgt+ getSubStatements (ConditionalDeclaration (ConditionalDecl conds _)) = conds ^.. traverse . _2 . tgt getSubStatements s@(ClassDeclaration{}) = extractPrism s getSubStatements s@(DefineDeclaration{}) = extractPrism s- getSubStatements s@(Node{}) = extractPrism s- getSubStatements s@(SHFunctionCall{}) = extractPrism s+ getSubStatements s@(NodeDeclaration{}) = extractPrism s+ getSubStatements s@(HigherOrderLambdaDeclaration{}) = extractPrism s getSubStatements (TopContainer v s) = getSubStatements s ++ v ^.. tgt getSubStatements _ = [] tgt = folded . to getSubStatements . folded extractPrism = toListOf (_Statements . traverse . to getSubStatements . traverse) allResources = parseSucceeded ^.. folded . folded . to getSubStatements . folded deadResources = filter isDead allResources- isDead (ResourceDeclaration (ResDec _ _ _ _ pp)) = not $ Set.member pp allpositions+ isDead (ResourceDeclaration (ResDecl _ _ _ _ pp)) = not $ Set.member pp allpositions isDead _ = True unless (null deadResources) $ do putDoc ("The following" <+> int (length deadResources) <+> "resource declarations are not used:" </> indent 4 (vcat (map pretty deadResources)))@@ -269,7 +268,7 @@ -- | For each node, queryfunc the catalog and return stats-computeStats :: FilePath -> Options -> QueryFunc -> (MStats, MStats, MStats) -> [Nodename] -> IO ()+computeStats :: FilePath -> Options -> QueryFunc -> (MStats, MStats, MStats) -> [NodeName] -> IO () computeStats workingdir (Options {..}) queryfunc (parsingStats, catalogStats, templateStats) topnodes = do@@ -305,14 +304,14 @@ else do {putDoc (dullgreen "All green." <> line) ; exitSuccess} where- computeCatalog :: QueryFunc -> Nodename -> IO (Maybe (FinalCatalog, [Resource]))+ computeCatalog :: QueryFunc -> NodeName -> IO (Maybe (FinalCatalog, [Resource])) computeCatalog func node = func node >>= \case S.Left err -> putDoc (line <> red "ERROR:" <+> parens (ttext node) <+> ":" <+> getError err) >> return Nothing S.Right (rawcatalog, _ , rawexported, knownRes) -> return (Just (rawcatalog <> rawexported, knownRes)) -- | Queryfunc the catalog for the node and PP the result-computeNodeCatalog :: Options -> QueryFunc -> PuppetDBAPI IO -> Nodename -> IO ()+computeNodeCatalog :: Options -> QueryFunc -> PuppetDBAPI IO -> NodeName -> IO () computeNodeCatalog (Options {..}) queryfunc pdbapi node = queryfunc node >>= \case S.Left rr -> do@@ -325,11 +324,11 @@ else displayIO stdout (renderCompact x) >> putStrLn "" catalog <- filterCatalog _optResourceType _optResourceName rawcatalog exported <- filterCatalog _optResourceType _optResourceName rawexported- let wireCatalog = generateWireCatalog node (catalog <> exported ) edgemap+ let wirecatalog = generateWireCatalog node (catalog <> exported ) edgemap rawWireCatalog = generateWireCatalog node (rawcatalog <> rawexported) edgemap when _optCheckExport $ void $ runEitherT $ replaceCatalog pdbapi rawWireCatalog case (_optShowContent, _optShowjson) of- (_, True) -> BSL.putStrLn (encode (prepareForPuppetApply wireCatalog))+ (_, True) -> BSL.putStrLn (encode (prepareForPuppetApply wirecatalog)) (True, _) -> do unless (_optResourceType == Just "file" || isNothing _optResourceType) $ do putDoc "Show content only works with resource of type file. It is an error to provide another filter type"@@ -382,11 +381,11 @@ (queryfunc, _, mPStats,mCStats,mTStats) <- initializedaemonWithPuppet workingdir cmd computeStats workingdir cmd queryfunc (mPStats, mCStats, mTStats) =<< retrieveNodes nodes where- retrieveNodes :: MultNodes -> IO [Nodename]+ retrieveNodes :: MultNodes -> IO [NodeName] retrieveNodes AllNodes = do allstmts <- parseFile (workingdir <> "/manifests/site.pp") >>= \case Left err -> error (show err) Right x -> return x- let getNodeName (Node (Nd (NodeName n) _ _ _)) = Just n+ let getNodeName (NodeDeclaration (NodeDecl (NodeName n) _ _ _)) = Just n getNodeName _ = Nothing return $ mapMaybe getNodeName (V.toList allstmts) retrieveNodes (MultNodes xs) = return xs
progs/pdbQuery.hs view
@@ -105,7 +105,7 @@ allfacts <- runCheck "get facts" (getFacts pdbapi QEmpty) tmpdb <- loadTestDB "/tmp/allfacts.yaml" >>= checkError "load test db" let groupfacts = foldl' groupfact HM.empty allfacts- groupfact curmap (PFactInfo ndname fctname fctval) =+ 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)@@ -119,10 +119,10 @@ ndb <- loadTestDB destfile >>= checkError "puppetdb load" allnodes <- runCheck "get nodes" (getNodes pdbapi QEmpty) allfacts <- runCheck "get facts" (getFacts pdbapi QEmpty)- let factsGrouped = HM.toList $ HM.fromListWith (<>) $ map (\x -> (x ^. nodename, HM.singleton (x ^. factname) (x ^. factval))) allfacts+ 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- let ndename = pnodename ^. nodename+ let ndename = pnodename ^. nodeInfoName res <- runCheck ("get resources for " ++ show ndename) (getResourcesOfNode pdbapi ndename QEmpty) let wirecatalog = WireCatalog ndename "version" V.empty (V.fromList res) ndename runCheck "replace catalog" (replaceCatalog ndb wirecatalog)
+ tests/Function/EachSpec.hs view
@@ -0,0 +1,52 @@+ {-# LANGUAGE OverloadedLists #-}+module Function.EachSpec (spec, main) where++import Test.Hspec+import Helpers++import Puppet.Interpreter.Types++main :: IO ()+main = hspec spec++spec :: Spec+spec = do+ describe "should be callable as" $ do+ it "each on an array selecting each value" $ do+ c <- getCatalog "$a = [1,2,3]\n $a.each |$v| {\n file { \"/file_$v\": ensure => present } \n } "+ getResource (RIdentifier "file" "/file_1") c >>= getAttribute "ensure" >>= \a -> a `shouldBe` "present"+ getResource (RIdentifier "file" "/file_2") c >>= getAttribute "ensure" >>= \a -> a `shouldBe` "present"+ getResource (RIdentifier "file" "/file_3") c >>= getAttribute "ensure" >>= \a -> a `shouldBe` "present"+ it "each on an array selecting each value - function call style" $ do+ c <- getCatalog "$a = [1,2,3]\n each ($a) |$index, $v| {\n file { \"/file_$v\": ensure => present }\n }"+ getResource (RIdentifier "file" "/file_1") c >>= getAttribute "ensure" >>= \a -> a `shouldBe` "present"+ getResource (RIdentifier "file" "/file_2") c >>= getAttribute "ensure" >>= \a -> a `shouldBe` "present"+ getResource (RIdentifier "file" "/file_3") c >>= getAttribute "ensure" >>= \a -> a `shouldBe` "present"+ it "each on an array with index" $ do+ c <- getCatalog "$a = [present, absent, present]\n $a.each |$k,$v| {\n file { \"/file_$k\": ensure => $v }\n }"+ getResource (RIdentifier "file" "/file_0") c >>= getAttribute "ensure" >>= \a -> a `shouldBe` "present"+ getResource (RIdentifier "file" "/file_1") c >>= getAttribute "ensure" >>= \a -> a `shouldBe` "absent"+ getResource (RIdentifier "file" "/file_2") c >>= getAttribute "ensure" >>= \a -> a `shouldBe` "present"+ it "each on a hash selecting entries" $ do+ c <- getCatalog "$a = {'a'=>'present','b'=>'absent','c'=>'present'}\n $a.each |$e| {\n $num = $e[0]\n file { \"/file_${num}\": ensure => $e[1] }\n }"+ getResource (RIdentifier "file" "/file_a") c >>= getAttribute "ensure" >>= \a -> a `shouldBe` "present"+ getResource (RIdentifier "file" "/file_b") c >>= getAttribute "ensure" >>= \a -> a `shouldBe` "absent"+ getResource (RIdentifier "file" "/file_c") c >>= getAttribute "ensure" >>= \a -> a `shouldBe` "present"+ it "each on a hash selecting key and value" $ do+ c <- getCatalog "$a = {'a'=>present,'b'=>absent,'c'=>present}\n $a.each |$k, $v| {\n file { \"/file_$k\": ensure => $v }\n }"+ getResource (RIdentifier "file" "/file_a") c >>= getAttribute "ensure" >>= \a -> a `shouldBe` "present"+ getResource (RIdentifier "file" "/file_b") c >>= getAttribute "ensure" >>= \a -> a `shouldBe` "absent"+ getResource (RIdentifier "file" "/file_c") c >>= getAttribute "ensure" >>= \a -> a `shouldBe` "present"+ it "each on a hash selecting key and value (using captures-last parameter)" $ do+ pending+ c <- getCatalog "$a = {'a'=>present,'b'=>absent,'c'=>present}\n $a.each |*$kv| {\n file { \"/file_${kv[0]}\": ensure => $kv[1] }\n }"+ getResource (RIdentifier "file" "/file_a") c >>= getAttribute "ensure" >>= \a -> a `shouldBe` "present"+ getResource (RIdentifier "file" "/file_b") c >>= getAttribute "ensure" >>= \a -> a `shouldBe` "absent"+ getResource (RIdentifier "file" "/file_c") c >>= getAttribute "ensure" >>= \a -> a `shouldBe` "present"+ describe "should produce receiver" $+ it "each checking produced value using single expression" $ do+ pending+ c <- getCatalog "$a = [1, 3, 2]\n $b = $a.each |$x| { \"unwanted\" }\n $u = $b[1]\n file { \"/file_${u}\":\n ensure => present\n }"+ getResource (RIdentifier "file" "/file_3") c >>= getAttribute "ensure" >>= \a -> a `shouldBe` "present"++
+ tests/Function/MergeSpec.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE OverloadedLists #-}+module Function.MergeSpec (spec, main) where++import Test.Hspec++import Control.Monad+import qualified Data.HashMap.Strict as HM+import Data.Monoid+import Data.Text (Text)++import Puppet.Interpreter.Pure+import Puppet.Interpreter.Types+import Puppet.PP+import Puppet.Stdlib++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 = do+ mergeFunc <- case HM.lookup "merge" stdlibFunctions of+ Just f -> return f+ Nothing -> fail "Don't know the size function"+ 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")]
+ tests/Function/ShellquoteSpec.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE OverloadedLists #-}+module Function.ShellquoteSpec (spec, main) where++import Test.Hspec++import Data.Text (Text)+import qualified Data.Vector as V+import Control.Monad+import Data.Monoid++import Puppet.Interpreter.Resolve+import Puppet.Interpreter.Pure+import Puppet.Interpreter.Types+import Puppet.Parser.Types+import Puppet.PP++main :: IO ()+main = hspec spec++evalArgs :: [Expression] -> Either PrettyError Text+evalArgs = dummyEval . resolveValue . UFunctionCall "shellquote" . V.fromList+ >=> \pv -> case pv of+ PString s -> return s+ _ -> Left ("Expected a string, not " <> PrettyError (pretty pv))++spec :: Spec+spec = do+ let check args res = case evalArgs args of+ Left rr -> expectationFailure (show rr)+ Right res' -> res' `shouldBe` res+ 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\""
+ tests/Function/SizeSpec.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE OverloadedLists #-}+module Function.SizeSpec (spec, main) where++import Test.Hspec++import Control.Monad+import qualified Data.HashMap.Strict as HM+import Data.Monoid+import Data.Scientific++import Puppet.Interpreter.Pure+import Puppet.Interpreter.Types+import Puppet.PP+import Puppet.Stdlib++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 = do+ sizeFunc <- case HM.lookup "size" stdlibFunctions of+ Just f -> return f+ Nothing -> fail "Don't know the size function"+ 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+
+ tests/Helpers.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE OverloadedLists #-}+module Helpers ( compileCatalog+ , getCatalog+ , getResource+ , getAttribute+ , spretty+ ) where++import Puppet.Interpreter (computeCatalog)+import Puppet.Interpreter.Pure+import Puppet.Interpreter.Types+import Puppet.Parser+import Puppet.Parser.Types+import Puppet.PP++import Control.Lens+import qualified Data.HashMap.Strict as HM+import qualified Data.Maybe.Strict as S+import Data.Text (Text, unpack)++compileCatalog :: Monad m => Text -> m (FinalCatalog, EdgeMap, FinalCatalog, [Resource], InterpreterState)+compileCatalog input = do+ statements <- either (fail . show) return (runPParser "dummy" input)+ let nodename = "node.fqdn"+ sttmap = [( (TopNode, nodename), NodeDeclaration (NodeDecl (NodeName nodename) statements S.Nothing (initialPPos "dummy")) ) ]+ (res, finalState, _) = pureEval dummyFacts sttmap (computeCatalog nodename)+ (catalog,em,exported,defResources) <- either (fail . show) return res+ return (catalog,em,exported,defResources,finalState)++getCatalog :: Monad m => Text -> m FinalCatalog+getCatalog = fmap (view _1) . compileCatalog++spretty :: Pretty a => a -> String+spretty = flip displayS "" . renderCompact . pretty++getResource :: Monad m => RIdentifier -> FinalCatalog -> m Resource+getResource resid catalog = maybe (fail ("Unknown resource " ++ spretty resid)) return (HM.lookup resid catalog)++getAttribute :: Monad m => Text -> Resource -> m PValue+getAttribute att res = case res ^? rattributes . ix att of+ Nothing -> fail ("Unknown attribute: " ++ unpack att)+ Just x -> return x+
+ tests/InterpreterSpec.hs view
@@ -0,0 +1,79 @@+module InterpreterSpec (collectorSpec, main) where++import Control.Lens+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HM+import Data.Monoid+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Vector as V+import Test.Hspec+import Text.Megaparsec (eof, parse)++import Puppet.Interpreter+import Puppet.Interpreter.Pure+import Puppet.Interpreter.Types+-- import Puppet.Lens+import Puppet.Parser+import Puppet.Parser.Types+import Puppet.PP++appendArrowNode :: Text+appendArrowNode = "appendArrow"++arrowOperationInput :: ArrowOp -> Text+arrowOperationInput arr = T.unlines [ "node " <> appendArrowNode <> " {"+ , "user { 'jenkins':"+ , " groups => 'ci'"+ , "}"+ , "User <| title == 'jenkins' |> {"+ , "groups " <> (prettyToText . pretty) 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 AssignArrow) ^. at "uid" `shouldBe` Just (PNumber 1000)+ describe "AppendArrow in AttributeDecl" $+ it "should add 'docker' to the 'groups' attribute of the user resource" $+ getResAttr (computeWith AppendArrow) ^. 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 AssignArrow) ^. at "groups" `shouldBe` Just (PArray $ V.fromList ["docker"])++main :: IO ()+main = hspec collectorSpec++-- | 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 (error . show) id++ getStatement :: NodeName -> Text -> HashMap (TopLevelType, NodeName) Statement+ getStatement n i = HM.singleton (TopNode, n) (nodeStatement i)++ nodeStatement :: Text -> Statement+ nodeStatement i = V.head $ hush $ parse (puppetParser <* eof) "test" i++ in pureEval dummyFacts (getStatement node input) (computeCatalog node)
+ tests/Spec.hs view
@@ -0,0 +1,19 @@+import Test.Hspec++import qualified InterpreterSpec+import qualified Function.ShellquoteSpec+import qualified Function.SizeSpec+import qualified Function.MergeSpec+import qualified Function.EachSpec++main :: IO ()+main = hspec spec++spec :: Spec+spec = do+ describe "Interpreter" InterpreterSpec.collectorSpec+ describe "The shellquote function" Function.ShellquoteSpec.spec+ describe "stdlib functions" $ do+ describe "The size function" Function.SizeSpec.spec+ describe "The merge function" Function.MergeSpec.spec+ describe "The each function" Function.EachSpec.spec
tests/hiera.hs view
@@ -34,6 +34,10 @@ hspec $ do describe "lookup data without a key" $ do it "returns an error when called with an empty string" $ q mempty "" Priority >>= checkOutput Nothing+ describe "lookup data without a valid key" $ do+ it "returns an error when called with a non existent key [Priority]" $ q mempty "foo" Priority >>= checkOutput Nothing+ it "returns an error when called with a non existent key [ArrayMerge]" $ q mempty "foo" ArrayMerge >>= checkOutput Nothing+ it "returns an error when called with a non existent key [HashMerge]" $ q mempty "foo" HashMerge >>= checkOutput Nothing describe "lookup data with no options" $ do it "can get string data" $ q mempty "http_port" Priority >>= checkOutput (Just (PNumber 8080)) it "can get arrays" $ q mempty "ntp_servers" Priority >>= checkOutput (Just (PArray (V.fromList ["0.ntp.puppetlabs.com","1.ntp.puppetlabs.com"])))