language-puppet 1.0.1 → 1.1.0
raw patch · 24 files changed
+1291/−1130 lines, 24 filesdep +transformers-compatdep −stateWriterdep −transformersdep ~hspecdep ~lensdep ~strict-base-types
Dependencies added: transformers-compat
Dependencies removed: stateWriter, transformers
Dependency ranges changed: hspec, lens, strict-base-types
Files
- CHANGELOG.markdown +24/−0
- Erb/Compute.hs +30/−31
- Hiera/Server.hs +73/−77
- Puppet/Daemon.hs +48/−45
- Puppet/Interpreter.hs +174/−145
- Puppet/Interpreter/IO.hs +49/−47
- Puppet/Interpreter/PrettyPrinter.hs +17/−16
- Puppet/Interpreter/Pure.hs +16/−18
- Puppet/Interpreter/Resolve.hs +56/−48
- Puppet/Interpreter/Types.hs +226/−116
- Puppet/NativeTypes/File.hs +50/−8
- Puppet/OptionalTests.hs +69/−0
- Puppet/Parser.hs +37/−30
- Puppet/Parser/Types.hs +15/−27
- Puppet/Plugins.hs +0/−1
- Puppet/Preferences.hs +40/−27
- Puppet/Stdlib.hs +7/−2
- Puppet/Testing.hs +0/−213
- PuppetDB/TestDB.hs +28/−23
- README.adoc +45/−22
- language-puppet.cabal +34/−39
- progs/PuppetResources.hs +222/−168
- tests/expr.hs +17/−10
- tests/hiera.hs +14/−17
CHANGELOG.markdown view
@@ -1,3 +1,27 @@+# v1.1.0 (2015/03/11)++Critical bugs have been fixed, upgrade recommended.++## New features+* New `dumpinfos` debug function.+* The interpreter can now run in a strict or permissive mode.+* The new `-a` option accepts a comma separated list of nodes for gathering stats.+* The new `--noextratests` option disable optional tests from `Puppet.OptionalTests`.+* Implementation of `member()` from stdlib (see issue #100 for details)++## Bugs fixed+* Exported/virtual custom types are not expanded. This is a huge bug.+* Class/define parameters that are explicitely set as undefined are now overriden by+ default values.+* Empty resource groups are now rejected.+* An existing resource can now be realized.++## Various+* Hiera config interpolation logs decrease from WARN to NOTICE+* Remove option `--nousergrouptest`+* Ease the use of the puppetresources command options. See the README file for changes.++ # v1.0.1 (2014/11/13) ## New features * Support for the `join` function.
Erb/Compute.hs view
@@ -1,36 +1,36 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE ForeignFunctionInterface #-}-{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-} module Erb.Compute(computeTemplate, initTemplateDaemon) where -import Text.PrettyPrint.ANSI.Leijen hiding ((<>))-import Puppet.Interpreter.Types-import Puppet.Preferences-import Puppet.Stats-import Puppet.PP-import Puppet.Utils+import Puppet.Interpreter.Types+import Puppet.PP+import Puppet.Preferences+import Puppet.Stats+import Puppet.Utils -import qualified Data.Either.Strict as S-import Control.Monad.Error-import Control.Concurrent-import System.Posix.Files-import Paths_language_puppet (getDataFileName)-import Erb.Parser-import Erb.Evaluate-import Erb.Ruby-import Debug.Trace-import qualified System.Log.Logger as LOG-import qualified Data.Text as T-import Text.Parsec hiding (string)-import Text.Parsec.Error-import Text.Parsec.Pos-import System.Environment-import Data.FileCache+import Control.Concurrent+import Control.Monad.Error+import qualified Data.Either.Strict as S+import Data.FileCache+import qualified Data.Text as T+import Debug.Trace+import Erb.Evaluate+import Erb.Parser+import Erb.Ruby+import Paths_language_puppet (getDataFileName)+import System.Environment+import qualified System.Log.Logger as LOG+import System.Posix.Files+import Text.Parsec hiding (string)+import Text.Parsec.Error+import Text.Parsec.Pos -import Control.Lens-import Data.Tuple.Strict-import qualified Foreign.Ruby as FR-import Foreign.Ruby.Safe+import Control.Lens+import Data.Tuple.Strict+import qualified Foreign.Ruby as FR+import Foreign.Ruby.Safe newtype TemplateParseError = TemplateParseError { tgetError :: ParseError }@@ -47,7 +47,7 @@ showRubyError (WithOutput str _) = PrettyError $ dullred (string str) initTemplateDaemon :: RubyInterpreter -> (Preferences IO) -> MStats -> IO (Either T.Text T.Text -> T.Text -> Container ScopeInformation -> IO (S.Either PrettyError T.Text))-initTemplateDaemon intr (Preferences _ modpath templatepath _ _ _ _ _) mvstats = do+initTemplateDaemon intr prefs mvstats = do controlchan <- newChan templatecache <- newFileCache let returnError rs = return $ \_ _ _ -> return (S.Left (showRubyError rs))@@ -55,7 +55,7 @@ Left rs -> returnError rs Right () -> registerGlobalFunction4 intr "varlookup" hrresolveVariable >>= \case Right () -> do- void $ forkIO $ templateDaemon intr (T.pack modpath) (T.pack templatepath) controlchan mvstats templatecache+ void $ forkIO $ templateDaemon intr (T.pack (prefs^.puppetPaths.modulesPath)) (T.pack (prefs^.puppetPaths.templatesPath)) controlchan mvstats templatecache return (templateQuery controlchan) Left rs -> returnError rs @@ -176,4 +176,3 @@ Right r -> FR.fromRuby r >>= \case Just result -> return (S.Right result) Nothing -> return (S.Left "Could not deserialiaze ruby output")-
Hiera/Server.hs view
@@ -1,4 +1,9 @@-{-# LANGUAGE LambdaCase, TemplateHaskell, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, NamedFieldPuns #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE TemplateHaskell #-} {- | This module runs a Hiera server that caches Hiera data. There is a huge caveat : only the data files are watched for changes, not the main configuration file.@@ -8,7 +13,7 @@ module Hiera.Server ( startHiera , dummyHiera- -- re-export from Puppet.Interpreter.Types+ -- * Re-export (query API) , HieraQueryFunc ) where @@ -16,28 +21,31 @@ import Control.Exception import Control.Lens import Control.Monad.Writer.Strict-import Data.Aeson (FromJSON,Value(..),(.:?),(.!=))-import qualified Data.Aeson as A+import Data.Aeson (FromJSON, Value (..), (.!=), (.:?))+import qualified Data.Aeson as A import Data.Aeson.Lens-import qualified Data.Attoparsec.Text as AT-import qualified Data.ByteString.Lazy as BS-import qualified Data.Either.Strict as S-import qualified Data.FileCache as F-import qualified Data.HashMap.Strict as HM-import qualified Data.List as L-import qualified Data.Maybe.Strict as S-import qualified Data.Text as T-import Data.Tuple.Strict-import qualified Data.Vector as V-import qualified Data.Yaml as Y-import System.FilePath.Lens (directory)+import qualified Data.Attoparsec.Text as AT+import qualified Data.ByteString.Lazy as BS+import qualified Data.Either.Strict as S+import qualified Data.FileCache as F+import qualified Data.HashMap.Strict as HM+import qualified Data.List as L+import Data.Maybe (fromMaybe)+import qualified Data.Text as T+import qualified Data.Vector as V+import qualified Data.Yaml as Y+import System.FilePath.Lens (directory)+import qualified System.Log.Logger as LOG -import Puppet.PP hiding ((<$>)) import Puppet.Interpreter.Types-import Puppet.Utils (strictifyEither)+import Puppet.PP hiding ((<$>))+import Puppet.Utils (strictifyEither) -data ConfigFile = ConfigFile- { _backends :: [Backend]+loggerName :: String+loggerName = "Hiera.Server"++data HieraConfigFile = HieraConfigFile+ { _backends :: [Backend] , _hierarchy :: [InterpolableHieraString] } deriving (Show) @@ -59,7 +67,7 @@ type Cache = F.FileCacheR String Y.Value -makeClassy ''ConfigFile+makeClassy ''HieraConfigFile instance FromJSON InterpolableHieraString where parseJSON (String s) = case parseInterpolableString s of@@ -67,7 +75,7 @@ Left rr -> fail rr parseJSON _ = fail "Invalid value type" -instance FromJSON ConfigFile where+instance FromJSON HieraConfigFile where parseJSON (Object v) = do let genBackend :: T.Text -> Y.Parser Backend genBackend name = do@@ -75,12 +83,12 @@ "yaml" -> return (YamlBackend, ":yaml") "json" -> return (JsonBackend, ":json") _ -> fail ("Unknown backend " ++ T.unpack name)- datadir <- case (Object v) ^? key skey . key ":datadir" of+ datadir <- case Object v ^? key skey . key ":datadir" of Just (String dir) -> return dir Just _ -> fail ":datadir should be a string" Nothing -> return "/etc/puppet/hieradata" return (backendConstructor (T.unpack datadir))- ConfigFile+ HieraConfigFile <$> (v .:? ":backends" .!= ["yaml"] >>= mapM genBackend) <*> (v .:? ":hierarchy" .!= [InterpolableHieraString [HString "common"]]) parseJSON _ = fail "Not a valid Hiera configuration"@@ -93,13 +101,14 @@ interpPart = AT.string "%{" *> AT.takeWhile1 (/= '}') <* AT.char '}' parseInterpolableString :: T.Text -> Either String [HieraStringPart]-parseInterpolableString t = AT.parseOnly interpolableString t+parseInterpolableString = AT.parseOnly interpolableString -- | The only method you'll ever need. It runs a Hiera server and gives you -- a querying function. The 'Nil' output is explicitely given as a Maybe -- type. startHiera :: FilePath -> IO (Either String (HieraQueryFunc IO)) startHiera fp = Y.decodeFileEither fp >>= \case+ Left (Y.InvalidYaml (Just (Y.YamlException "Yaml file not found: hiera.yaml"))) -> return (Right dummyHiera) Left ex -> return (Left (show ex)) Right cfg -> do cache <- F.newFileCache@@ -107,43 +116,32 @@ -- | A dummy hiera function that will be used when hiera is not detected dummyHiera :: Monad m => HieraQueryFunc m-dummyHiera _ _ _ = return $ S.Right ([] :!: S.Nothing)+dummyHiera _ _ _ = return $ S.Right Nothing -- | The combinator for "normal" queries-queryCombinator :: [LogWriter (S.Maybe PValue)] -> LogWriter (S.Maybe PValue)-queryCombinator [] = return S.Nothing-queryCombinator (x:xs) = x >>= \case- v@(S.Just _) -> return v- S.Nothing -> queryCombinator xs---- | The combinator for hiera_array-queryCombinatorArray :: [LogWriter (S.Maybe PValue)] -> LogWriter (S.Maybe PValue)-queryCombinatorArray = fmap rejoin . sequence+queryCombinator :: HieraQueryType -> [IO (Maybe PValue)] -> IO (Maybe PValue)+queryCombinator Priority = foldr (liftA2 mplus) (pure mzero)+queryCombinator ArrayMerge = fmap rejoin . sequence where- rejoin = S.Just . PArray . V.concat . map toA- toA S.Nothing = V.empty- toA (S.Just (PArray r)) = r- toA (S.Just a) = V.singleton a---- | The combinator for hiera_hash-queryCombinatorHash :: [LogWriter (S.Maybe PValue)] -> LogWriter (S.Maybe PValue)-queryCombinatorHash = fmap (S.Just . PHash . mconcat . map toH) . sequence+ 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 where- toH S.Nothing = mempty- toH (S.Just (PHash h)) = h- toH _ = throw (ErrorCall "The hiera value was not a hash")+ toH Nothing = mempty+ toH (Just (PHash h)) = h+ toH _ = error "The hiera value was not a hash" interpolateText :: Container T.Text -> T.Text -> T.Text-interpolateText vars t = case (parseInterpolableString t ^? _Right) >>= resolveInterpolable vars of- Just x -> x- Nothing -> t+interpolateText vars t = fromMaybe t ((parseInterpolableString t ^? _Right) >>= resolveInterpolable vars) resolveInterpolable :: Container T.Text -> [HieraStringPart] -> Maybe T.Text-resolveInterpolable vars = fmap T.concat . mapM (resolveInterpolablePart vars)--resolveInterpolablePart :: Container T.Text -> HieraStringPart -> Maybe T.Text-resolveInterpolablePart _ (HString x) = Just x-resolveInterpolablePart vars (HVariable v) = vars ^. at v+resolveInterpolable vars = fmap T.concat . mapM resolvePart+ 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@@ -151,44 +149,42 @@ interpolatePValue v (PString t) = PString (interpolateText v t) interpolatePValue _ x = x -type LogWriter = WriterT InterpreterWriter IO--query :: ConfigFile -> FilePath -> Cache -> HieraQueryFunc IO-query (ConfigFile {_backends, _hierarchy}) fp cache vars hquery qtype = do- fmap (S.Right . prepout) (runWriterT (sequencerFunction (map query' _hierarchy))) `catch` (\e -> return . S.Left . PrettyError . string . show $ (e :: SomeException))+query :: HieraConfigFile -> FilePath -> Cache -> HieraQueryFunc IO+query (HieraConfigFile {_backends, _hierarchy}) fp cache vars hquery qtype =+ fmap S.Right (queryCombinator qtype (map query' _hierarchy)) `catch` (\e -> return . S.Left . PrettyError . string . show $ (e :: SomeException)) where- prepout (a,s) = s :!: a varlist = hcat (L.intersperse comma (map (dullblue . ttext) (L.sort (HM.keys vars))))- sequencerFunction = case qtype of- Priority -> queryCombinator- ArrayMerge -> queryCombinatorArray- HashMerge -> queryCombinatorHash- query' :: InterpolableHieraString -> LogWriter (S.Maybe PValue)+ query' :: InterpolableHieraString -> IO (Maybe PValue) query' (InterpolableHieraString strs) = case resolveInterpolable vars strs of- Just s -> sequencerFunction (map (query'' s) _backends)- Nothing -> warn ("Hiera: could not interpolate " <> pretty strs <> ", known variables are:" <+> varlist) >> return S.Nothing- query'' :: T.Text -> Backend -> LogWriter (S.Maybe PValue)- query'' hieraname backend = do+ Just s -> queryCombinator qtype (map (query'' s) _backends)+ Nothing -> do+ LOG.noticeM loggerName (show $ "Hiera lookup: skipping using hierarchy level" <+> pretty strs+ <$$> "It couldn't be interpolated with known variables:" <+> varlist)+ return Nothing+ query'' :: T.Text -> Backend -> IO (Maybe PValue)+ query'' hierastring backend = do let (decodefunction, datadir, extension) = case backend of (JsonBackend d) -> (fmap (strictifyEither . A.eitherDecode') . BS.readFile , d, ".json") (YamlBackend d) -> (fmap (strictifyEither . (_Left %~ show)) . Y.decodeFileEither, d, ".yaml")- filename = basedir <> datadir <> "/" <> T.unpack hieraname <> extension+ filename = basedir <> datadir <> "/" <> T.unpack hierastring <> extension where basedir = case datadir of '/' : _ -> mempty _ -> fp^.directory <> "/"- mfromJSON :: Maybe Value -> LogWriter (S.Maybe PValue)- mfromJSON Nothing = return S.Nothing+ mfromJSON :: Maybe Value -> IO (Maybe PValue)+ mfromJSON Nothing = return Nothing mfromJSON (Just v) = case A.fromJSON v of- A.Success a -> return (S.Just (interpolatePValue vars a))- _ -> warn ("Hiera:" <+> dullred "could not convert this Value to a Puppet type" <> ":" <+> string (show v)) >> return S.Nothing+ A.Success a -> return (Just (interpolatePValue vars a))+ _ -> do+ LOG.warningM loggerName (show $ "Hiera:" <+> dullred "could not convert this Value to a Puppet type" <> ":" <+> string (show v))+ return Nothing v <- liftIO (F.query cache filename (decodefunction filename)) case v of S.Left r -> do let errs = "Hiera: error when reading file " <> string filename <+> string r if "Yaml file not found: " `L.isInfixOf` r- then debug errs- else warn errs- return S.Nothing+ then LOG.debugM loggerName (show errs)+ else LOG.warningM loggerName (show errs)+ return Nothing S.Right x -> mfromJSON (x ^? key hquery)
Puppet/Daemon.hs view
@@ -1,51 +1,40 @@-{-# LANGUAGE LambdaCase, CPP #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-} module Puppet.Daemon (initDaemon) where import Control.Exception import Control.Lens-import qualified Data.Either.Strict as S+import Control.Monad (when)+import qualified Data.Either.Strict as S import Data.FileCache-import qualified Data.HashMap.Strict as HM-import qualified Data.Text as T-import qualified Data.Text.IO as T+import qualified Data.HashMap.Strict as HM+import qualified Data.Text as T+import qualified Data.Text.IO as T import Data.Tuple.Strict-import qualified Data.Vector as V+import qualified Data.Vector as V import Debug.Trace import Erb.Compute import Foreign.Ruby.Safe import Hiera.Server-import qualified System.Log.Logger as LOG- import Puppet.Interpreter import Puppet.Interpreter.IO import Puppet.Interpreter.Types import Puppet.Manifests-import Puppet.PP+import Puppet.OptionalTests import Puppet.Parser import Puppet.Parser.Types import Puppet.Plugins+import Puppet.PP import Puppet.Preferences import Puppet.Stats import Puppet.Utils--loggerName :: String-loggerName = "Puppet.Daemon"--logDebug :: T.Text -> IO ()-logDebug = LOG.debugM loggerName . T.unpack--- logInfo :: T.Text -> IO ()--- logInfo = LOG.infoM loggerName . T.unpack--- logWarning :: T.Text -> IO ()--- logWarning = LOG.warningM loggerName . T.unpack--- logError :: T.Text -> IO ()--- logError = LOG.errorM loggerName . T.unpack+import qualified System.Log.Logger as LOG {-| This is a high level function, that will initialize the parsing and-interpretation infrastructure from the 'Prefs' structure, and will return a-function that will take a node name, 'Facts' and return either an error or the-'FinalCatalog', along with the dependency graph and catalog of exported resources. It also return a few IO-functions that can be used in order to query the daemon for statistics,-following the format in "Puppet.Stats".+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"). It will internaly initialize 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@@ -53,9 +42,8 @@ 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 in the 'Prefs' data-structure. The recommended way to set it to http://localhost:8080 and set a SSH-tunnel :+It can optionnaly 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 @@ -82,7 +70,7 @@ hquery <- case prefs ^. hieraPath of Just p -> fmap (either error id) $ startHiera p Nothing -> return dummyHiera- luacontainer <- initLuaMaster (T.pack (prefs ^. modulesPath))+ luacontainer <- initLuaMaster (T.pack (prefs ^. puppetPaths.modulesPath)) let myprefs = prefs & prefExtFuncs %~ HM.union luacontainer return (DaemonMethods (gCatalog myprefs getStatements getTemplate catalogStats hquery) parserStats catalogStats templateStats) @@ -91,27 +79,34 @@ -> (Either T.Text T.Text -> T.Text -> Container ScopeInformation -> IO (S.Either PrettyError T.Text)) -> MStats -> HieraQueryFunc IO- -> T.Text+ -> Nodename -> Facts -> IO (S.Either PrettyError (FinalCatalog, EdgeMap, FinalCatalog, [Resource])) gCatalog prefs getStatements getTemplate stats hquery ndename facts = do logDebug ("Received query for node " <> ndename) traceEventIO ("START gCatalog " <> T.unpack ndename)- (stmts :!: warnings) <- measure stats ndename $- getCatalog interpretMonad- getStatements- getTemplate- (prefs ^. prefPDB)- ndename- facts- (prefs ^. natTypes)- (prefs ^. prefExtFuncs)- hquery- defaultImpureMethods- (prefs ^. ignoredmodules)+ let catalogComputation = getCatalog (InterpreterReader+ (prefs ^. natTypes)+ getStatements+ getTemplate+ (prefs ^. prefPDB)+ (prefs ^. prefExtFuncs)+ ndename+ hquery+ defaultImpureMethods+ (prefs ^. ignoredmodules)+ (prefs ^. strictness == Strict))+ ndename+ facts+ (stmts :!: warnings) <- measure stats ndename catalogComputation mapM_ (\(p :!: m) -> LOG.logM loggerName p (displayS (renderCompact (ttext ndename <> ":" <+> m)) "")) warnings traceEventIO ("STOP gCatalog " <> T.unpack ndename)+ when (prefs ^. extraTests) $ runOptionalTests stmts return stmts+ where+ runOptionalTests r = case r^?S._Right._1 of+ Nothing -> return ()+ Just c -> testCatalog (prefs^.puppetPaths.baseDir) c parseFunction :: Preferences IO -> FileCache (V.Vector Statement) -> MStats -> TopLevelType -> T.Text -> IO (S.Either PrettyError Statement) parseFunction prefs filecache stats topleveltype toplevelname =@@ -129,13 +124,13 @@ -- 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 ^. manifestPath) <> "/site.pp")+compileFileList prefs TopNode _ = S.Right (T.pack (prefs ^. puppetPaths.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 ^. modulesPath)+ mpath = T.pack (prefs ^. puppetPaths.modulesPath) nameparts = T.splitOn "::" name parseFile :: FilePath -> IO (S.Either String (V.Vector Statement))@@ -147,3 +142,11 @@ Left rr -> traceEventIO ("Stopped parsing " ++ fname ++ " (failure: " ++ show rr ++ ")") >> return (S.Left (show rr)) traceEventIO ("STOP parsing " ++ fname) return o+++-- Some utils func internal to this module+loggerName :: String+loggerName = "Puppet.Daemon"++logDebug :: T.Text -> IO ()+logDebug = LOG.debugM loggerName . T.unpack
Puppet/Interpreter.hs view
@@ -1,35 +1,42 @@-{-# LANGUAGE LambdaCase, RankNTypes #-}-module Puppet.Interpreter where+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RankNTypes #-}+module Puppet.Interpreter+ ( getCatalog+ ) where -import Puppet.Interpreter.Types-import Puppet.Interpreter.PrettyPrinter(containerComma)-import Puppet.Interpreter.Resolve-import Puppet.Parser.Types-import Puppet.Lens-import Puppet.Parser.PrettyPrinter-import Puppet.PP hiding ((<$>))-import Puppet.NativeTypes+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 hiding ((<$>)) -import Prelude hiding (mapM)-import Puppet.Utils-import System.Log.Logger-import Data.Maybe-import Data.List (nubBy)-import qualified Data.Text as T-import Data.Tuple.Strict (Pair(..))-import qualified Data.Tuple.Strict as S-import qualified Data.Either.Strict as S-import qualified Data.HashSet as HS-import qualified Data.HashMap.Strict as HM-import Control.Monad.Error hiding (mapM,forM)-import Control.Lens-import qualified Data.Maybe.Strict as S-import qualified Data.Graph as G-import qualified Data.Tree as T-import Data.Foldable (toList,foldl',Foldable,foldlM)-import Data.Traversable (mapM)-import Control.Monad.Operational hiding (view)-import Control.Applicative+import Control.Applicative+import Control.Lens+import Control.Monad.Error hiding (forM, mapM)+import Control.Monad.Operational hiding (view)+import qualified Data.Either.Strict as S+import Data.Foldable (Foldable, foldl', foldlM,+ toList)+import qualified Data.Graph as G+import qualified Data.HashMap.Strict as HM+import qualified Data.HashSet as HS+import Data.HashSet.Lens+import Data.List (nubBy, sortBy)+import Data.Maybe+import qualified Data.Maybe.Strict as S+import Data.Ord (comparing)+import qualified Data.Text as T+import Data.Traversable (mapM)+import qualified Data.Tree as T+import Data.Tuple.Strict (Pair (..))+import qualified Data.Tuple.Strict as S+import Prelude hiding (mapM)+import Puppet.Utils+import System.Log.Logger -- helpers vmapM :: (Monad m, Foldable t) => (a -> m b) -> t a -> m [b]@@ -41,39 +48,32 @@ [] -> x (y:_) -> y in case t of- "class" -> gm n- _ -> gm t+ "class" -> gm n+ _ -> gm t --- | This is the main function for computing catalogs. It returns the--- result of the compulation (either an error, or a tuple containing all--- the resources, dependency map, exported resources, and defined resources--- (this last one might not be up to date and is only useful for code--- coverage tests)) along with all messages that have been generated by the--- compilation process.-getCatalog :: Monad m- => (forall a. InterpreterReader m -> InterpreterState -> InterpreterMonad a -> m (Either PrettyError a, InterpreterState, InterpreterWriter)) -- ^ A function that will interpret the InterpreterMonad and will convert it to something else (for example, 'interpretIO')- -> ( TopLevelType -> T.Text -> m (S.Either PrettyError Statement) ) -- ^ get statements function- -> (Either T.Text T.Text -> T.Text -> Container ScopeInformation -> m (S.Either PrettyError T.Text)) -- ^ compute template function- -> PuppetDBAPI m- -> T.Text -- ^ Node name- -> Facts -- ^ Facts ...- -> Container NativeTypeMethods -- ^ List of native types- -> Container ( [PValue] -> InterpreterMonad PValue )- -> HieraQueryFunc m -- ^ Hiera query function- -> ImpureMethods m- -> HS.HashSet T.Text -- ^ The set of ignored modules++{-| Call the operational 'interpretMonad' function to compute the catalog.+ Returns either an error, or a tuple containing all the resources,+ dependency map, exported resources, and defined resources alongside with+ all messages that have been generated by the compilation process.++ The later 'definedResources' (eg. all class declarations) are pulled out of the+ 'InterpreterState' and might not be up to date.+ There are only useful for coverage testing (checking dependencies for instance).+-}+getCatalog :: (Functor m, Monad m)+ => InterpreterReader m -- ^ The whole environment required for computing catalog.+ -> Nodename+ -> Facts -> m (Pair (S.Either PrettyError (FinalCatalog, EdgeMap, FinalCatalog, [Resource])) [Pair Priority Doc])-getCatalog convertMonad gtStatement gtTemplate pdbQuery ndename facts nTypes extfuncs hquery im ignord = do- -- nameThread ("Catalog " <> T.unpack ndename)- let rdr = InterpreterReader nTypes gtStatement gtTemplate pdbQuery extfuncs ndename hquery im ignord- stt = initialState facts- (output, _, warnings) <- convertMonad rdr stt (computeCatalog ndename)+getCatalog interpretReader node facts = do+ (output, _, warnings) <- interpretMonad interpretReader (initialState facts) (computeCatalog node) return (strictifyEither output :!: warnings) isParent :: T.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+ Nothing -> throwPosError ("Internal error: could not find scope" <+> ttext cur <+> "possible parent" <+> ttext possibleparent)+ Just S.Nothing -> return False Just (S.Just p) -> if p == possibleparent then return True else isParent p (ContClass possibleparent)@@ -118,10 +118,12 @@ void $ getOver >>= mapM keepforlater let expandableDefine r = do n <- isNativeType (r ^. rid . itype)- if n+ -- if we have a native type, or a virtual/exported resource it+ -- should not be expanded !+ if (n || r ^. rvirtuality /= Normal) then return [r] else expandDefine r- join <$> mapM expandableDefine withDefaults+ concat <$> mapM expandableDefine withDefaults popScope :: InterpreterMonad () popScope = curScope %= tail@@ -151,7 +153,7 @@ Just b -> return b Nothing -> throwPosError ("Could not extract prism in " <> t) -computeCatalog :: T.Text -> InterpreterMonad (FinalCatalog, EdgeMap, FinalCatalog, [Resource])+computeCatalog :: Nodename -> InterpreterMonad (FinalCatalog, EdgeMap, FinalCatalog, [Resource]) computeCatalog ndename = do (restop, node') <- getstt TopNode ndename node <- extractPrism _Node' "computeCatalog" node'@@ -160,7 +162,7 @@ -- collect stuff and apply thingies (realized :!: modified) <- realize allres -- we need to run it again against collected stuff, especially- -- for defines that have been realized+ -- for custom types (defines) that have been realized refinalized <- finalize (toList modified) >>= finalStep -- replace the modified stuff let res = foldl' (\curm e -> curm & at (e ^. rid) ?~ e) realized refinalized@@ -168,6 +170,9 @@ 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+ -- 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. classify :: Pair (HM.HashMap RIdentifier Resource) (HM.HashMap RIdentifier Resource) -> Resource -> Pair (HM.HashMap RIdentifier Resource) (HM.HashMap RIdentifier Resource)@@ -186,10 +191,10 @@ makeEdgeMap :: FinalCatalog -> InterpreterMonad EdgeMap makeEdgeMap ct = do -- merge the looaded classes and resources- defs' <- HM.map _rpos <$> use definedResources+ defs' <- HM.map (view rpos) <$> use definedResources clss' <- use loadedClasses let defs = defs' <> classes' <> aliases' <> names'- names' = HM.map _rpos ct+ names' = HM.map (view rpos) ct -- generate fake resources for all extra aliases aliases' = ifromList $ do r <- ct ^.. traversed :: [Resource]@@ -259,12 +264,22 @@ -- throwPosError (vcat (map (\(RIdentifier st sn, RIdentifier dt dn) -> "\"" <> ttext st <> ttext sn <> "\" -> \"" <> ttext dt <> ttext dn <> "\"") edgePairs)) return step2 +-- | This functions performs all the actions triggered by calls to the+-- realize function or other collectors. It returns a pair of+-- "finalcatalogs", where the first part is the new catalog, and the second+-- part the map of all modified resources. The second part is needed so+-- that we know for example which resources we should test for expansion+-- (custom types). realize :: [Resource] -> InterpreterMonad (Pair FinalCatalog FinalCatalog) realize rs = do- let rma = ifromList (map (\r -> (r ^. rid, r)) rs)+ let -- rma is the initial map of resources, indexed by resource identifier+ rma = ifromList (map (\r -> (r ^. rid, r)) rs)+ -- mutate runs all the resource modifiers (ie. realize, overrides+ -- and other collectors). It stores the modified resources on the+ -- "right" of the resulting pair. mutate :: Pair FinalCatalog FinalCatalog -> ResourceModifier -> InterpreterMonad (Pair FinalCatalog FinalCatalog) mutate (curmap :!: modified) rmod = do- let filtrd = curmap ^.. folded . filtered fmod+ 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))@@ -272,15 +287,15 @@ 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 (Pair FinalCatalog FinalCatalog) Bool -> Resource -> InterpreterMonad (Pair (Pair FinalCatalog FinalCatalog) Bool)- applyModification (cma :!: cmo :!: matched) r = do+ applyModification :: Pair FinalCatalog FinalCatalog -> Resource -> InterpreterMonad (Pair FinalCatalog FinalCatalog)+ applyModification (cma :!: cmo) r = do nr <- mutation r let i m = m & at (nr ^. rid) ?~ nr return $ if nr /= r- then i cma :!: i cmo :!: True- else cma :!: cmo :!: matched- (result :!: mtch) <- foldM applyModification (curmap :!: modified :!: False) filtrd- when (rmod ^. rmModifierType == ModifierMustMatch && not mtch) (throwError (PrettyError ("Could not apply this resource override :" <+> pretty rmod)))+ then i cma :!: i cmo+ else cma :!: cmo+ result <- foldM applyModification (curmap :!: modified) filtrd -- apply the modifiation to all the matching resources+ when (rmod ^. rmModifierType == ModifierMustMatch && null filtrd) (throwError (PrettyError ("Could not apply this resource override :" <+> pretty rmod <> ",no matching resource was found."))) return result equalModifier (ResourceModifier a1 b1 c1 d1 _ e1) (ResourceModifier a2 b2 c2 d2 _ e2) = a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2 && e1 == e2 result <- use resMod >>= foldM mutate (rma :!: mempty) . nubBy equalModifier@@ -294,8 +309,8 @@ unless (S.isNothing inheritance) $ throwPosError "Node inheritance is not handled yet, and will probably never be" vmapM evaluateStatement stmts >>= finalize . concat -evaluateStatementsVector :: Foldable f => f Statement -> InterpreterMonad [Resource]-evaluateStatementsVector = fmap concat . vmapM evaluateStatement+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@@ -341,9 +356,10 @@ fqdn <- singleton GetNodeName -- we must filter the resources that originated from this host -- here ! They are also turned into "normal" resources- res <- ( map (rvirtuality .~ Normal)- . filter ((/= fqdn) . _rnode)- ) <$> singleton (PDBGetResources q)+ res <- toListOf (folded+ . filtered ( hasn't (rnode . only fqdn) )+ . to (rvirtuality .~ Normal)+ ) <$> singleton (PDBGetResources q) scpdesc <- ContImported <$> getScope void $ enterScope SENormal scpdesc "importing" p pushScope scpdesc@@ -376,7 +392,7 @@ checkCond ((e :!: stmts) : xs) = do result <- pValue2Bool <$> resolveExpression e if result- then evaluateStatementsVector stmts+ then evaluateStatementsFoldable stmts else checkCond xs checkCond (toList conds) evaluateStatement (DefaultDeclaration (DefaultDec resType decls p)) = do@@ -461,23 +477,29 @@ loadHieraParam curprms paramname = do v <- runHiera (classname <> "::" <> paramname) Priority case v of- S.Nothing -> return curprms- S.Just vl -> return (curprms & at paramname ?~ vl)+ Nothing -> return curprms+ Just vl -> return (curprms & at paramname ?~ vl) foldM loadHieraParam params (toList unsetParams) S.Nothing -> return params -- pass 2 : we check that everything is right- let !classParamSet = HS.fromList (map S.fst (toList classParams))- !mandatoryParamSet = HS.fromList (map S.fst (classParams ^.. folded . filtered (S.isNothing . S.snd)))- !definedParamSet = ikeys params'- !unsetParams = mandatoryParamSet `HS.difference` definedParamSet- !spuriousParams = definedParamSet `HS.difference` classParamSet+ let classParamSet = HS.fromList (map S.fst (toList classParams))+ mandatoryParamSet = HS.fromList (map S.fst (classParams ^.. folded . filtered (S.isNothing . S.snd)))+ definedParamSet = ikeys params'+ unsetParams = mandatoryParamSet `HS.difference` definedParamSet+ defaultParams = setOf (folded . _1) classParams+ undefParamsWdefs = ikeys (HM.filter (== PUndef) params') `HS.intersection` defaultParams+ spuriousParams = definedParamSet `HS.difference` classParamSet mclassdesc = S.maybe mempty ((\x -> mempty <+> "when including class" <+> x) . ttext) wHiera unless (fnull unsetParams) $ throwPosError ("The following mandatory parameters were not set:" <+> tupled (map ttext $ toList unsetParams) <> mclassdesc) unless (fnull spuriousParams) $ throwPosError ("The following parameters are unknown:" <+> tupled (map (dullyellow . ttext) $ toList spuriousParams) <> mclassdesc)- let isDefault = not . flip HS.member definedParamSet . S.fst- mapM_ (uncurry loadVariable) (itoList params')+ -- a default can override an undefined value+ let isDefault (k :!: _) = not (k `HS.member` definedParamSet) || k `HS.member` undefParamsWdefs+ defaultPairs = filter isDefault (toList classParams)+ -- we load all parameters that are set, except thos that are set as+ -- undefined and have a default value+ itraverse_ loadVariable (HM.filterWithKey (\k _ -> not (k `HS.member` undefParamsWdefs)) params' ) curPos .= defaultPos- forM_ (filter isDefault (toList classParams)) $ \(k :!: v) -> do+ forM_ defaultPairs $ \(k :!: v) -> do rv <- case v of S.Nothing -> throwPosError "Internal error: invalid invariant at loadParameters" S.Just e -> resolveExpression e@@ -550,31 +572,29 @@ extraRelations <>= extr void $ enterScope SENormal curContType modulename p (spurious, dls') <- getstt TopDefine deftype- dls <- extractPrism _DefineDeclaration' "expandDefine" dls'+ DefineDec _ defineParams stmts cp <- extractPrism _DefineDeclaration' "expandDefine" dls' let isImported (ContImported _) = True isImported _ = False isImportedDefine <- isImported <$> getScope- case dls of- (DefineDec _ defineParams stmts cp) -> do- 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 <- evaluateStatementsVector stmts- finalize (spurious ++ res)- when isImportedDefine popScope- popScope- return out+ 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@@ -602,40 +622,38 @@ -- load the actual class, note we are not changing the current position -- right now (spurious, cls') <- getstt TopClass classname- cls <- extractPrism _ClassDeclaration' "loadClass" cls'- case cls of- (ClassDecl _ classParams inh stmts cp) -> do- -- 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)- 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- then do- scp <- use curScope- fqdn <- singleton GetNodeName- return [Resource (RIdentifier "class" classname) (HS.singleton classname) mempty mempty scp Normal mempty p fqdn]- else return []- pushScope scopedesc- imods <- singleton (IsIgnoredModule modulename)- out <- if imods- then return mempty- else do- loadVariable "title" (PString classname)- loadVariable "name" (PString classname)- loadParameters params classParams cp (S.Just classname)- curPos .= cp- res <- evaluateStatementsVector stmts- finalize (classresource ++ spurious ++ inhstmts ++ res)- popScope- return out+ ClassDecl _ classParams inh stmts cp <- extractPrism _ClassDeclaration' "loadClass" cls'+ -- 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)+ 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+ then do+ scp <- use curScope+ fqdn <- singleton GetNodeName+ return [Resource (RIdentifier "class" classname) (HS.singleton classname) mempty mempty scp Normal mempty p fqdn]+ else return []+ pushScope scopedesc+ imods <- singleton (IsIgnoredModule modulename)+ out <- if imods+ then return mempty+ else do+ loadVariable "title" (PString classname)+ loadVariable "name" (PString classname)+ loadParameters params classParams cp (S.Just classname)+ curPos .= cp+ res <- evaluateStatementsFoldable stmts+ finalize (classresource ++ spurious ++ inhstmts ++ res)+ popScope+ return out ----------------------------------------------------------- -- Resource stuff -----------------------------------------------------------@@ -772,21 +790,32 @@ curPos .= p return o mainFunctionCall "hiera_include" _ = throwPosError "hiera_include(): This function takes a single argument"+mainFunctionCall "dumpinfos" _ = do+ let prntline = logWriter ALERT+ indentln = (<>) " "+ prntline "Scope stack :"+ scps <- use curScope+ mapM_ (prntline . indentln . pretty) scps+ prntline "Variables in local scope :"+ scp <- getScopeName+ vars <- use (scopes . ix scp . scopeVariables)+ forM_ (sortBy (comparing fst) (itoList vars)) $ \(idx, pv :!: _ :!: _) -> prntline $ indentln $ ttext idx <> " -> " <> pretty pv+ return [] mainFunctionCall fname args = do p <- use curPos let representation = MainFunctionCall (MFC 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 []--- Method stuff +-- 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 <- evaluateStatementsVector (hf ^. hfstatements)+ res <- evaluateStatementsFoldable (hf ^. hfstatements) hfRestorevars saved return res results <- mapM runblock varassocs
Puppet/Interpreter/IO.hs view
@@ -3,34 +3,29 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -- | This is an internal module.-module Puppet.Interpreter.IO where+module Puppet.Interpreter.IO (defaultImpureMethods, interpretMonad) where -import Puppet.PP+import Puppet.PP hiding ((<$>)) import Puppet.Interpreter.Types import Puppet.Interpreter.PrettyPrinter() import Puppet.Plugins() import Control.Monad.Operational-import Control.Monad.RSS.Strict import Control.Monad.State.Strict import Control.Lens+import Control.Applicative -import qualified Data.ByteString as BS import qualified Data.Either.Strict as S +import Data.Monoid import GHC.Stack import Debug.Trace (traceEventIO) import qualified Data.Text as T import qualified Data.Text.IO as T-import Control.Exception import qualified Scripting.Lua as Lua+import Control.Exception import Control.Concurrent.MVar-import Data.Tuple.Strict (Pair(..))-import System.Log.Logger (Priority(..)) -bs :: BS.ByteString -> PrettyError-bs = PrettyError . string . show- defaultImpureMethods :: (Functor m, MonadIO m) => ImpureMethods m defaultImpureMethods = ImpureMethods (liftIO currentCallStack) (liftIO . file)@@ -38,39 +33,55 @@ (\c fname args -> liftIO (runlua c fname args)) where file [] = return $ Left ""- file (x:xs) = fmap Right (T.readFile (T.unpack x)) `catch` (\SomeException{} -> file xs)+ file (x:xs) = (Right <$> T.readFile (T.unpack x)) `catch` (\SomeException{} -> file xs) runlua c fname args = liftIO $ withMVar c $ \lstt ->- catch (fmap Right (Lua.callfunc lstt (T.unpack fname) args)) (\e -> return $ Left $ show (e :: SomeException))+ catch (Right <$> Lua.callfunc lstt (T.unpack fname) args) (\e -> return $ Left $ show (e :: SomeException)) -evalInstrGen :: (Functor m, Monad m) => InterpreterReader m -> InterpreterState -> ProgramViewT InterpreterInstr (State InterpreterState) a -> m (Either PrettyError a, InterpreterState, InterpreterWriter)-evalInstrGen _ stt (Return x) = return (Right x, stt, mempty)-evalInstrGen rdr stt (a :>>= f) =- let runC a' = interpretMonad rdr stt (f a')- thpe = interpretMonad rdr stt . throwPosError . getError- pdb = _pdbAPI rdr++-- | The operational interpreter function+interpretMonad :: (Functor m, Monad m)+ => InterpreterReader m+ -> InterpreterState+ -> InterpreterMonad a+ -> m (Either PrettyError a, InterpreterState, InterpreterWriter)+interpretMonad r s0 instr = let (!p, !s1) = runState (viewT instr) s0+ in eval r s1 p++-- The internal (not exposed) eval function+eval :: (Functor m, Monad m)+ => InterpreterReader m+ -> InterpreterState+ -> ProgramViewT InterpreterInstr (State InterpreterState) a+ -> m (Either PrettyError a, InterpreterState, InterpreterWriter)+eval _ s (Return x) = return (Right x, s, mempty)+eval r s (a :>>= k) =+ let runInstr = interpretMonad r s . k -- run one instruction+ thpe = interpretMonad r s . throwPosError . getError+ pdb = r^.pdbAPI strFail iof errf = iof >>= \case Left rr -> thpe (errf (string rr))- Right x -> runC x+ Right x -> runInstr x canFail iof = iof >>= \case- S.Left rr -> thpe rr- S.Right x -> runC x- logStuff x c = (_3 %~ (x <>)) `fmap` c+ S.Left err -> thpe err+ S.Right x -> runInstr x+ logStuff x c = (_3 %~ (x <>)) <$> c in case a of- ExternalFunction fname args -> case rdr ^. externalFunctions . at fname of- Just fn -> interpretMonad rdr stt ( fn args >>= f)+ IsStrict -> runInstr (r ^. isStrict)+ ExternalFunction fname args -> case r ^. externalFunctions . at fname of+ Just fn -> interpretMonad r s ( fn args >>= k) Nothing -> thpe (PrettyError ("Unknown function: " <> ttext fname)) GetStatement topleveltype toplevelname- -> canFail ((rdr ^. getStatement) topleveltype toplevelname)- ComputeTemplate fn scp cscps -> canFail ((rdr ^. computeTemplateFunction) fn scp cscps)- WriterTell t -> logStuff t (runC ())+ -> canFail ((r ^. getStatement) topleveltype toplevelname)+ ComputeTemplate fn scp cscps -> canFail ((r ^. computeTemplateFunction) fn scp cscps)+ WriterTell t -> logStuff t (runInstr ()) WriterPass _ -> thpe "WriterPass" WriterListen _ -> thpe "WriterListen"- GetNativeTypes -> runC (rdr ^. nativeTypes)- ErrorThrow d -> return (Left d, stt, mempty)+ GetNativeTypes -> runInstr (r ^. nativeTypes)+ ErrorThrow d -> return (Left d, s, mempty) ErrorCatch _ _ -> thpe "ErrorCatch"- GetNodeName -> runC (rdr ^. thisNodename)- hq@(HieraQuery scps q t) -> logStuff [DEBUG :!: pretty hq] (canFail ((rdr ^. hieraQuery) scps q t))- PDBInformation -> pdbInformation pdb >>= runC+ GetNodeName -> runInstr (r ^. thisNodename)+ HieraQuery scps q t -> canFail ((r ^. hieraQuery) scps q t)+ PDBInformation -> pdbInformation pdb >>= runInstr PDBReplaceCatalog w -> canFail (replaceCatalog pdb w) PDBReplaceFacts fcts -> canFail (replaceFacts pdb fcts) PDBDeactivateNode nn -> canFail (deactivateNode pdb nn)@@ -79,19 +90,10 @@ PDBGetNodes q -> canFail (getNodes pdb q) PDBCommitDB -> canFail (commitDB pdb) PDBGetResourcesOfNode nn q -> canFail (getResourcesOfNode pdb nn q)- GetCurrentCallStack -> (rdr ^. ioMethods . imGetCurrentCallStack) >>= runC- ReadFile fls -> strFail ((rdr ^. ioMethods . imReadFile) fls) (const $ PrettyError ("No file found in " <> list (map ttext fls)))- TraceEvent e -> (rdr ^. ioMethods . imTraceEvent) e >>= runC- IsIgnoredModule m -> runC (rdr ^. ignoredModules . contains m)- CallLua c fname args -> (rdr ^. ioMethods . imCallLua) c fname args >>= \case- Right x -> runC x+ 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)+ CallLua c fname args -> (r ^. ioMethods . imCallLua) c fname args >>= \case+ Right x -> runInstr x Left rr -> thpe (PrettyError (string rr))---interpretMonad :: (Functor m, Monad m)- => InterpreterReader m- -> InterpreterState- -> InterpreterMonad a- -> m (Either PrettyError a, InterpreterState, InterpreterWriter)-interpretMonad rd_ prmstate instr = case runState (viewT instr) prmstate of- (!a,!nextstate) -> evalInstrGen rd_ nextstate a
Puppet/Interpreter/PrettyPrinter.hs view
@@ -2,23 +2,23 @@ {-# LANGUAGE GADTs #-} module Puppet.Interpreter.PrettyPrinter(containerComma) where -import Puppet.PP-import Puppet.Parser.Types-import Puppet.Interpreter.Types-import Puppet.Parser.PrettyPrinter-import Puppet.Utils+import Puppet.Interpreter.Types+import Puppet.Parser.PrettyPrinter+import Puppet.Parser.Types+import Puppet.PP+import Puppet.Utils -import qualified Data.Vector as V-import qualified Data.Text as T-import qualified Data.HashMap.Strict as HM-import qualified Data.HashSet as HS-import Control.Arrow (first,second)-import Control.Lens-import Data.List-import GHC.Exts-import qualified Data.ByteString.Lazy.Char8 as BSL+import Control.Arrow (first, second)+import Control.Lens+import qualified Data.ByteString.Lazy.Char8 as BSL+import qualified Data.HashMap.Strict as HM+import qualified Data.HashSet as HS+import Data.List+import qualified Data.Text as T+import qualified Data.Vector as V+import GHC.Exts -import Data.Aeson (ToJSON, encode)+import Data.Aeson (ToJSON, encode) containerComma'' :: Pretty a => [(Doc, a)] -> Doc containerComma'' x = indent 2 ins@@ -84,7 +84,7 @@ instance Pretty Resource where prettyList lst = let grouped = HM.toList $ HM.fromListWith (++) [ (r ^. rid . itype, [r]) | r <- lst ] :: [ (T.Text, [Resource]) ]- sorted = sortWith fst (map (second (sortWith (_iname . _rid) )) grouped)+ sorted = sortWith fst (map (second (sortWith (view (rid.iname)))) grouped) showGroup :: (T.Text, [Resource]) -> Doc showGroup (rt, res) = dullyellow (ttext rt) <+> lbrace <$> indent 2 (vcat (map resourceBody res)) <$> rbrace in vcat (map showGroup sorted)@@ -118,6 +118,7 @@ showQuery = string . BSL.unpack . encode instance Pretty (InterpreterInstr a) where+ pretty IsStrict = pf "IsStrict" [] pretty GetNativeTypes = pf "GetNativeTypes" [] pretty (GetStatement tlt nm) = pf "GetStatement" [pretty tlt,ttext nm] pretty (ComputeTemplate fn scp _) = pf "ComputeTemplate" [fn', ttext scp]
Puppet/Interpreter/Pure.hs view
@@ -7,23 +7,20 @@ -- > Right (PString "3") module Puppet.Interpreter.Pure where -import Puppet.PP-import Puppet.Parser.Types-import Puppet.Interpreter.Types-import Puppet.Interpreter.IO-import Puppet.NativeTypes-import Erb.Parser-import Erb.Evaluate-import PuppetDB.Dummy+import Erb.Evaluate+import Erb.Parser+import Puppet.Interpreter.IO+import Puppet.Interpreter.Types+import Puppet.NativeTypes+import Puppet.Parser.Types+import Puppet.PP+import PuppetDB.Dummy -import qualified Data.HashMap.Strict as HM-import Control.Monad.Identity-import qualified Data.Either.Strict as S-import qualified Data.Maybe.Strict as S-import Data.Tuple.Strict-import Data.Monoid-import qualified Data.Text as T-import Control.Lens+import Control.Lens+import qualified Data.Either.Strict as S+import qualified Data.HashMap.Strict as HM+import Data.Monoid+import qualified Data.Text as T -- | Worst name ever, this is a set of pure stub for the 'ImpureMethods' -- type.@@ -34,7 +31,7 @@ -- 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+pureReader sttmap = InterpreterReader baseNativeTypes getstatementdummy templatedummy dummyPuppetDB mempty "dummy" hieradummy impurePure mempty True where templatedummy (Right _) _ _ = return (S.Left "Can't interpret files") templatedummy (Left cnt) ctx scope =@@ -43,7 +40,7 @@ Right stmts -> case rubyEvaluate scope ctx stmts of Right x -> S.Right x Left rr -> S.Left (PrettyError rr)- hieradummy _ _ _ = return (S.Right (mempty :!: S.Nothing))+ hieradummy _ _ _ = return (S.Right Nothing) getstatementdummy tlt n = return $ case HM.lookup (tlt,n) sttmap of Just x -> S.Right x Nothing -> S.Left "Can't get statement"@@ -56,6 +53,7 @@ pureEval facts sttmap action = runIdentity (interpretMonad (pureReader sttmap) startingState action) where startingState = initialState facts+ -- | A bunch of facts that can be used for pure evaluation. dummyFacts :: Facts
Puppet/Interpreter/Resolve.hs view
@@ -28,40 +28,38 @@ fixResourceName ) where -import Puppet.PP-import Puppet.Interpreter.Types-import Puppet.Parser.Types-import Puppet.Interpreter.PrettyPrinter()-import Puppet.Parser.PrettyPrinter(showPos)-import Puppet.Interpreter.RubyRandom-import Puppet.Utils+import Puppet.Interpreter.PrettyPrinter ()+import Puppet.Interpreter.RubyRandom+import Puppet.Interpreter.Types+import Puppet.Parser.Types+import Puppet.PP+import Puppet.Utils -import Data.Version (parseVersion)-import Text.ParserCombinators.ReadP (readP_to_S)+import Data.Version (parseVersion)+import Text.ParserCombinators.ReadP (readP_to_S) -import Data.Maybe (fromMaybe, mapMaybe)-import Data.Aeson hiding ((.=))-import Data.CaseInsensitive ( mk )-import qualified Data.Vector as V-import qualified Data.HashMap.Strict as HM-import qualified Data.HashSet as HS-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import Control.Applicative hiding ((<$>))-import Control.Monad-import Data.Tuple.Strict as S-import Control.Lens-import Data.Aeson.Lens hiding (key)-import qualified Data.Maybe.Strict as S-import qualified Data.ByteString as BS-import qualified Crypto.Hash.MD5 as MD5-import qualified Crypto.Hash.SHA1 as SHA1-import qualified Data.ByteString.Base16 as B16-import Data.Bits-import Control.Monad.Writer (tell)-import Control.Monad.Operational (singleton)-import Text.Regex.PCRE.ByteString.Utils-import Data.Scientific+import Control.Applicative hiding ((<$>))+import Control.Lens+import Control.Monad+import Control.Monad.Operational (singleton)+import qualified Crypto.Hash.MD5 as MD5+import qualified Crypto.Hash.SHA1 as SHA1+import Data.Aeson hiding ((.=))+import Data.Aeson.Lens hiding (key)+import Data.Bits+import qualified Data.ByteString as BS+import qualified Data.ByteString.Base16 as B16+import Data.CaseInsensitive (mk)+import qualified Data.HashMap.Strict as HM+import qualified Data.HashSet as HS+import Data.Maybe (fromMaybe, mapMaybe)+import qualified Data.Maybe.Strict as S+import Data.Scientific+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Data.Tuple.Strict as S+import qualified Data.Vector as V+import Text.Regex.PCRE.ByteString.Utils -- | A useful type that is used when trying to perform arithmetic on Puppet -- numbers.@@ -77,7 +75,7 @@ -- | A hiera helper function, that will throw all Hiera errors and log -- messages to the main monad.-runHiera :: T.Text -> HieraQueryType -> InterpreterMonad (S.Maybe PValue)+runHiera :: T.Text -> HieraQueryType -> InterpreterMonad (Maybe PValue) runHiera q t = do -- We need to merge the current scope with the top level scope scps <- use scopes@@ -90,9 +88,7 @@ toplevels = map (_1 %~ ("::" <>)) $ getV "::" locals = getV ctx vars = HM.fromList (toplevels <> locals)- (w :!: o) <- singleton (HieraQuery vars q t)- tell w- return o+ singleton (HieraQuery vars q t) -- | The implementation of all hiera_* functions hieraCall :: HieraQueryType -> PValue -> Maybe PValue -> Maybe PValue -> InterpreterMonad PValue@@ -101,8 +97,8 @@ qs <- resolvePValueString q o <- runHiera qs qt case o of- S.Just p -> return p- S.Nothing -> case df of+ Just p -> return p+ Nothing -> case df of Just d -> return d Nothing -> throwPosError ("Lookup for " <> ttext qs <> " failed") @@ -141,7 +137,9 @@ scps <- use scopes scp <- getScopeName case getVariable scps scp fullvar of- Left rr -> throwPosError rr+ Left rr -> ifStrict+ (throwPosError rr)+ (warn ("The variable" <+> pretty (UVariableReference fullvar) <+> "was not resolved" <+> pretty PUndef <+> "returned") >> return PUndef) Right x -> return x -- | A simple helper that checks if a given type is native or a define.@@ -242,7 +240,11 @@ ridx <- resolveExpressionString idx case h ^. at ridx of Just v -> return v- Nothing -> throwPosError ("Can't find index '" <> ttext ridx <> "' in" <+> pretty (PHash h))+ Nothing -> do+ checkStrict+ ("Look up for an hash with the unknown key '" <> ttext ridx <> "' for" <+> pretty (PHash h))+ ("Can't find index '" <> ttext ridx <> "' in" <+> pretty (PHash h))+ return "undef" PArray ar -> do ridx <- resolveExpression idx i <- case ridx ^? _Integer of@@ -328,6 +330,11 @@ resolvePValueString (PBoolean True) = return "true" resolvePValueString (PBoolean False) = return "false" resolvePValueString (PNumber x) = return (scientific2text x)+resolvePValueString PUndef = do+ checkStrict+ "Resolving the keyword `undef` to the string \"undef\""+ "Strict mode won't convert the keyword `undef` to the string \"undef\""+ return "undef" resolvePValueString x = throwPosError ("Don't know how to convert this to a string:" <$> pretty x) -- | Turns everything it can into a number, or throws an error@@ -336,10 +343,6 @@ Just n -> return n Nothing -> throwPosError ("Don't know how to convert this to a number:" <$> pretty x) --- | > resolveValueString = resolveValue >=> resolvePValueString-resolveValueString :: UValue -> InterpreterMonad T.Text-resolveValueString = resolveValue >=> resolvePValueString- -- | > resolveExpressionString = resolveExpression >=> resolvePValueString resolveExpressionString :: Expression -> InterpreterMonad T.Text resolveExpressionString = resolveExpression >=> resolvePValueString@@ -391,9 +394,14 @@ undefEmptyString x = x resolveFunction' :: T.Text -> [PValue] -> InterpreterMonad PValue-resolveFunction' "defined" [PResourceReference "class" cn] = fmap (PBoolean . has (ix cn)) (use loadedClasses)-resolveFunction' "defined" [PResourceReference rt rn] = fmap (PBoolean . has (ix (RIdentifier rt rn))) (use definedResources)+resolveFunction' "defined" [PResourceReference "class" cn] = do+ checkStrict "The 'defined' function should not be used." "The 'defined' function is not allowed in strict mode."+ fmap (PBoolean . has (ix cn)) (use loadedClasses)+resolveFunction' "defined" [PResourceReference rt rn] = do+ checkStrict "The 'defined' function should not be used." "The 'defined' function is not allowed in strict mode."+ fmap (PBoolean . has (ix (RIdentifier rt rn))) (use definedResources) resolveFunction' "defined" [ut] = do+ checkStrict "The 'defined' function should not be used." "The 'defined' function is not allowed in strict mode." t <- resolvePValueString ut -- case 1, netsted thingie nestedStuff <- use nestedDeclarations@@ -454,9 +462,9 @@ GT -> "1" resolveFunction' "versioncmp" _ = throwPosError "versioncmp(): Expects two arguments" -- some custom functions-resolveFunction' "pdbresourcequery" [q] = pdbresourcequery q Nothing+resolveFunction' "pdbresourcequery" [q] = pdbresourcequery q Nothing resolveFunction' "pdbresourcequery" [q,k] = fmap Just (resolvePValueString k) >>= pdbresourcequery q-resolveFunction' "pdbresourcequery" _ = throwPosError "pdbresourcequery(): Expects one or two arguments"+resolveFunction' "pdbresourcequery" _ = throwPosError "pdbresourcequery(): Expects one or two arguments" resolveFunction' "hiera" [q] = hieraCall Priority q Nothing Nothing resolveFunction' "hiera" [q,d] = hieraCall Priority q (Just d) Nothing resolveFunction' "hiera" [q,d,o] = hieraCall Priority q (Just d) (Just o)
Puppet/Interpreter/Types.hs view
@@ -1,46 +1,148 @@-{-# LANGUAGE DeriveGeneric, TemplateHaskell, CPP, ScopedTypeVariables, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, LambdaCase, FlexibleContexts #-}-{-# LANGUAGE GADTs #-}-module Puppet.Interpreter.Types where+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+module Puppet.Interpreter.Types (+ -- * Record & lenses+ HasResource(..)+ , Resource(Resource)+ , HasResDefaults(..)+ , ResDefaults(ResDefaults)+ , HasLinkInformation(..)+ , LinkInformation(LinkInformation)+ , HasRIdentifier(..)+ , RIdentifier(RIdentifier)+ , HasScopeInformation(..)+ , ScopeInformation(ScopeInformation)+ , HasResourceModifier(..)+ , ResourceModifier(ResourceModifier)+ , HasImpureMethods(..)+ , ImpureMethods(ImpureMethods)+ , HasCurContainer(..)+ , CurContainer(CurContainer)+ , HasNativeTypeMethods(..)+ , NativeTypeMethods(NativeTypeMethods)+ -- ** Operational instructions+ , InterpreterInstr(..)+ , HasInterpreterReader(..)+ , InterpreterReader(InterpreterReader)+ , HasInterpreterState(..)+ , InterpreterState+ -- * Record & field lenses+ , PNodeInfo(PNodeInfo)+ , nodename+ , PFactInfo(PFactInfo)+ , factname+ , wResources+ , wEdges+ , factval+ -- * Sum types+ , PValue(..)+ , CurContainerDesc(..)+ , ResourceCollectorType(..)+ , RSearchExpression(..)+ , Query(..)+ , ModifierType(..)+ , NodeField+ , Strictness(..)+ , HieraQueryType(..)+ , WireCatalog(..)+ , TopLevelType(..)+ , FactField(..)+ , ResRefOverride(..)+ , ResourceField(..)+ , OverrideType(..)+ , DaemonMethods(..)+ , ClassIncludeType(..)+ -- ** PuppetDB+ , PuppetEdge(PuppetEdge)+ , PuppetDBAPI(..)+ -- * newtype & synonym+ , PrettyError(..)+ , InterpreterMonad+ , InterpreterWriter+ , FinalCatalog+ , NativeTypeValidate+ , Nodename+ , Container+ , HieraQueryFunc+ , Scope+ , Facts+ , EdgeMap+ -- * Classes+ , MonadThrowPos(..)+ -- * Utils+ , metaparameters+ , initialState+ , getCurContainer+ , text2Scientific+ , safeDecodeUtf8+ , ifStrict+ , getScope+ , getScopeName+ , scopeName+ , resourceRelations+ , checkStrict+ , dummypos+ , iinsertWith+ , ikeys+ , isingleton+ , ifromListWith+ , ifromList+ , iunionWith+ , showPos+ , fnull+ , rcurcontainer+ , logWriter+ , warn+ , debug+ , eitherDocIO+) where +import Puppet.Parser.PrettyPrinter import Puppet.Parser.Types import Puppet.Stats-import Puppet.Parser.PrettyPrinter -import Control.Applicative hiding (empty)-import Control.Concurrent.MVar (MVar)+import Control.Applicative hiding (empty)+import Control.Concurrent.MVar (MVar) import Control.Exception import Control.Lens import Control.Monad.Error import Control.Monad.Operational import Control.Monad.State.Strict import Control.Monad.Writer.Class-import Data.Aeson as A+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 qualified Data.HashMap.Strict as HM-import qualified Data.HashSet as HS+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 Data.Maybe (fromMaybe)-import qualified Data.Maybe.Strict as S-import Data.Monoid hiding ((<>))+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 hiding ((<>)) import Data.Scientific-import Data.String (IsString(..))-import qualified Data.Text as T-import qualified Data.Text.Encoding as T+import Data.String (IsString (..))+import qualified Data.Text as T+import qualified Data.Text.Encoding as T import Data.Time.Clock-import qualified Data.Traversable as TR+import qualified Data.Traversable as TR import Data.Tuple.Strict-import qualified Data.Vector as V+import qualified Data.Vector as V import Foreign.Ruby-import GHC.Generics hiding (to)+import GHC.Generics hiding (to) import GHC.Stack-import qualified Scripting.Lua as Lua+import qualified Scripting.Lua as Lua import System.Log.Logger import Text.Parsec.Pos-import Text.PrettyPrint.ANSI.Leijen hiding ((<$>), rational)+import Text.PrettyPrint.ANSI.Leijen hiding (rational, (<$>)) metaparameters :: HS.HashSet T.Text metaparameters = HS.fromList ["tag","stage","name","title","alias","audit","check","loglevel","noop","schedule", "EXPORTEDSOURCE", "require", "before", "register", "notify"]@@ -54,9 +156,20 @@ instance Show PrettyError where show = show . getError +instance Monoid PrettyError where+ mempty = PrettyError mempty+ mappend a b = PrettyError $ getError a <+> getError b+ instance IsString PrettyError where fromString = PrettyError . string +-- | 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)++ data PValue = PBoolean !Bool | PUndef | PString !T.Text -- integers and doubles are internally serialized as strings by puppet@@ -75,7 +188,7 @@ type HieraQueryFunc m = Container T.Text -- ^ All the variables that Hiera can interpolate, the top level ones being prefixed with :: -> T.Text -- ^ The query -> HieraQueryType- -> m (S.Either PrettyError (Pair InterpreterWriter (S.Maybe PValue)))+ -> m (S.Either PrettyError (Maybe PValue)) data RSearchExpression = REqualitySearch !T.Text !PValue | RNonEqualitySearch !T.Text !PValue@@ -113,10 +226,10 @@ instance Hashable TopLevelType data ResDefaults = ResDefaults- { _defType :: !T.Text+ { _defType :: !T.Text , _defSrcScope :: !T.Text- , _defValues :: !(Container PValue)- , _defPos :: !PPosition+ , _defValues :: !(Container PValue)+ , _defPos :: !PPosition } data CurContainerDesc = ContRoot -- ^ Contained at node or root level@@ -132,48 +245,49 @@ } deriving (Eq) data ResRefOverride = ResRefOverride- { _rrid :: !RIdentifier+ { _rrid :: !RIdentifier , _rrparams :: !(Container PValue)- , _rrpos :: !PPosition+ , _rrpos :: !PPosition } deriving (Eq) data ScopeInformation = ScopeInformation { _scopeVariables :: !(Container (Pair (Pair PValue PPosition) CurContainerDesc))- , _scopeDefaults :: !(Container ResDefaults)+ , _scopeDefaults :: !(Container ResDefaults) , _scopeExtraTags :: !(HS.HashSet T.Text) , _scopeContainer :: !CurContainer , _scopeOverrides :: !(HM.HashMap RIdentifier ResRefOverride)- , _scopeParent :: !(S.Maybe T.Text)+ , _scopeParent :: !(S.Maybe T.Text) } data InterpreterState = InterpreterState- { _scopes :: !(Container ScopeInformation)- , _loadedClasses :: !(Container (Pair ClassIncludeType PPosition))- , _definedResources :: !(HM.HashMap RIdentifier Resource)- , _curScope :: ![CurContainerDesc]- , _curPos :: !PPosition+ { _scopes :: !(Container ScopeInformation)+ , _loadedClasses :: !(Container (Pair ClassIncludeType PPosition))+ , _definedResources :: !(HM.HashMap RIdentifier Resource)+ , _curScope :: ![CurContainerDesc]+ , _curPos :: !PPosition , _nestedDeclarations :: !(HM.HashMap (TopLevelType,T.Text) Statement)- , _extraRelations :: ![LinkInformation]- , _resMod :: ![ResourceModifier]+ , _extraRelations :: ![LinkInformation]+ , _resMod :: ![ResourceModifier] } data InterpreterReader m = InterpreterReader- { _nativeTypes :: !(Container NativeTypeMethods)- , _getStatement :: TopLevelType -> T.Text -> m (S.Either PrettyError Statement)+ { _nativeTypes :: !(Container NativeTypeMethods)+ , _getStatement :: TopLevelType -> T.Text -> m (S.Either PrettyError Statement) , _computeTemplateFunction :: Either T.Text T.Text -> T.Text -> Container ScopeInformation -> 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 -- ^ The set of modules we will not include or whatsoever.+ , _pdbAPI :: PuppetDBAPI m+ , _externalFunctions :: Container ([PValue] -> InterpreterMonad PValue)+ , _thisNodename :: T.Text+ , _hieraQuery :: HieraQueryFunc m+ , _ioMethods :: ImpureMethods m+ , _ignoredModules :: HS.HashSet T.Text+ , _isStrict :: Bool } 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)+ , _imReadFile :: [T.Text] -> m (Either String T.Text)+ , _imTraceEvent :: String -> m ()+ , _imCallLua :: MVar Lua.LuaState -> T.Text -> [PValue] -> m (Either String PValue) } data InterpreterInstr a where@@ -183,9 +297,10 @@ ComputeTemplate :: Either T.Text T.Text -> T.Text -> Container ScopeInformation -> InterpreterInstr T.Text ExternalFunction :: T.Text -> [PValue] -> InterpreterInstr PValue GetNodeName :: InterpreterInstr T.Text- HieraQuery :: Container T.Text -> T.Text -> HieraQueryType -> InterpreterInstr (Pair InterpreterWriter (S.Maybe PValue))+ HieraQuery :: Container T.Text -> T.Text -> HieraQueryType -> InterpreterInstr (Maybe PValue) GetCurrentCallStack :: InterpreterInstr [String] IsIgnoredModule :: T.Text -> InterpreterInstr Bool+ IsStrict :: InterpreterInstr Bool -- error ErrorThrow :: PrettyError -> InterpreterInstr a ErrorCatch :: InterpreterMonad a -> (PrettyError -> InterpreterMonad a) -> InterpreterInstr a@@ -210,7 +325,6 @@ -- Calling Lua CallLua :: MVar Lua.LuaState -> T.Text -> [PValue] -> InterpreterInstr PValue -newtype Warning = Warning Doc type InterpreterLog = Pair Priority Doc type InterpreterWriter = [InterpreterLog]@@ -262,26 +376,24 @@ data ResourceModifier = ResourceModifier- { _rmResType :: !T.Text+ { _rmResType :: !T.Text , _rmModifierType :: !ModifierType- , _rmType :: !ResourceCollectorType- , _rmSearch :: !RSearchExpression- , _rmMutation :: !(Resource -> InterpreterMonad Resource)- , _rmDeclaration :: !PPosition+ , _rmType :: !ResourceCollectorType+ , _rmSearch :: !RSearchExpression+ , _rmMutation :: !(Resource -> InterpreterMonad Resource)+ , _rmDeclaration :: !PPosition } data LinkInformation = LinkInformation- { _linksrc :: !RIdentifier- , _linkdst :: !RIdentifier+ { _linksrc :: !RIdentifier+ , _linkdst :: !RIdentifier , _linkType :: !LinkType- , _linkPos :: !PPosition+ , _linkPos :: !PPosition } type EdgeMap = HM.HashMap RIdentifier [LinkInformation] -{-| This is a fully resolved resource that will be used in the- 'FinalCatalog'.--}+{-| 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@@ -308,7 +420,7 @@ 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 :: T.Text -> Facts -> IO (S.Either PrettyError (FinalCatalog, EdgeMap, FinalCatalog, [Resource]))+ _dGetCatalog :: Nodename -> Facts -> IO (S.Either PrettyError (FinalCatalog, EdgeMap, FinalCatalog, [Resource])) , _dParserStats :: MStats , _dCatalogStats :: MStats , _dTemplateStats :: MStats@@ -318,36 +430,36 @@ -- | 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+ , _wireCatalogWVersion :: !T.Text+ , _wireCatalogWEdges :: !(V.Vector PuppetEdge)+ , _wireCatalogWResources :: !(V.Vector Resource)+ , _wireCatalogTransactionUUID :: !T.Text } data PFactInfo = PFactInfo- { _pfactinfoNodename :: !T.Text- , _pfactinfoFactname :: !T.Text- , _pfactinfoFactval :: !PValue+ { _pFactInfoNodename :: !T.Text+ , _pFactInfoFactname :: !T.Text+ , _pFactInfoFactval :: !PValue } data PNodeInfo = PNodeInfo- { _pnodeinfoNodename :: !Nodename- , _pnodeinfoDeactivated :: !Bool- , _pnodeinfoCatalogT :: !(S.Maybe UTCTime)- , _pnodeinfoFactsT :: !(S.Maybe UTCTime)- , _pnodeinfoReportT :: !(S.Maybe UTCTime)+ { _pNodeInfoNodename :: !Nodename+ , _pNodeInfoDeactivated :: !Bool+ , _pNodeInfoCatalogT :: !(S.Maybe UTCTime)+ , _pNodeInfoFactsT :: !(S.Maybe UTCTime)+ , _pNodeInfoReportT :: !(S.Maybe UTCTime) } data PuppetDBAPI m = PuppetDBAPI- { pdbInformation :: m Doc- , replaceCatalog :: WireCatalog -> m (S.Either PrettyError ()) -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/commands.html#replace-catalog-version-3>- , replaceFacts :: [(Nodename, Facts)] -> m (S.Either PrettyError ()) -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/commands.html#replace-facts-version-1>- , deactivateNode :: Nodename -> m (S.Either PrettyError ()) -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/commands.html#deactivate-node-version-1>- , getFacts :: Query FactField -> m (S.Either PrettyError [PFactInfo]) -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/query/v3/facts.html#get-v3facts>- , getResources :: Query ResourceField -> m (S.Either PrettyError [Resource]) -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/query/v3/resources.html#get-v3resources>- , getNodes :: Query NodeField -> m (S.Either PrettyError [PNodeInfo])- , commitDB :: m (S.Either PrettyError ()) -- ^ This is only here to tell the test PuppetDB to save its content to disk.+ { pdbInformation :: m Doc+ , replaceCatalog :: WireCatalog -> m (S.Either PrettyError ()) -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/commands.html#replace-catalog-version-3>+ , replaceFacts :: [(Nodename, Facts)] -> m (S.Either PrettyError ()) -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/commands.html#replace-facts-version-1>+ , deactivateNode :: Nodename -> m (S.Either PrettyError ()) -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/commands.html#deactivate-node-version-1>+ , getFacts :: Query FactField -> m (S.Either PrettyError [PFactInfo]) -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/query/v3/facts.html#get-v3facts>+ , getResources :: Query ResourceField -> m (S.Either PrettyError [Resource]) -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/query/v3/resources.html#get-v3resources>+ , getNodes :: Query NodeField -> m (S.Either PrettyError [PNodeInfo])+ , commitDB :: m (S.Either PrettyError ()) -- ^ This is only here to tell the test PuppetDB to save its content to disk. , getResourcesOfNode :: Nodename -> Query ResourceField -> m (S.Either PrettyError [Resource]) } @@ -420,7 +532,7 @@ throwError (PrettyError (s <+> "at" <+> showPos p <> dstack)) getCurContainer :: InterpreterMonad CurContainer-{-# INLINE getCurContainer #-}+{-# INLINABLE getCurContainer #-} getCurContainer = do scp <- getScopeName preuse (scopes . ix scp . scopeContainer) >>= \case@@ -438,13 +550,11 @@ getScopeName = fmap scopeName getScope getScope :: InterpreterMonad CurContainerDesc-{-# INLINE getScope #-}+{-# INLINABLE getScope #-} getScope = use curScope >>= \s -> if null s then throwPosError "Internal error: empty scope!" else return (head s) --- instance- instance FromJSON PValue where parseJSON Null = return PUndef parseJSON (Number n) = return $ PNumber n@@ -477,28 +587,10 @@ check (S.Left r) = return (S.Left r) check (S.Right x) = return (S.Right x) -interpreterIO :: (MonadThrowPos m, MonadIO m) => IO (S.Either PrettyError a) -> m a-{-# INLINE interpreterIO #-}-interpreterIO f = do- liftIO (eitherDocIO f) >>= \case- S.Right x -> return x- S.Left rr -> throwPosError (getError rr)--mightFail :: (MonadError PrettyError m, MonadThrowPos m) => m (S.Either PrettyError a) -> m a-mightFail a = a >>= \case- S.Right x -> return x- S.Left rr -> throwPosError (getError rr)- safeDecodeUtf8 :: BS.ByteString -> InterpreterMonad T.Text-{-# INLINE safeDecodeUtf8 #-}+{-# INLINABLE safeDecodeUtf8 #-} safeDecodeUtf8 i = return (T.decodeUtf8 i) -interpreterError :: InterpreterMonad (S.Either PrettyError a) -> InterpreterMonad a-{-# INLINE interpreterError #-}-interpreterError f = f >>= \case- S.Right r -> return r- S.Left rr -> throwPosError (getError rr)- resourceRelations :: Resource -> [(RIdentifier, LinkType)] resourceRelations = concatMap expandSet . HM.toList . _rrelations where@@ -506,34 +598,34 @@ -- | 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-{-# INLINE ifromList #-}+{-# 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-{-# INLINE ikeys #-}+{-# INLINABLE ikeys #-} ikeys = HS.fromList . HM.keys isingleton :: (Monoid b, At b) => Index b -> IxValue b -> b-{-# INLINE isingleton #-}+{-# 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-{-# INLINE ifromListWith #-}+{-# 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-{-# INLINE iinsertWith #-}+{-# 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-{-# INLINE iunionWith #-}+{-# INLINABLE iunionWith #-} iunionWith = HM.unionWith fnull :: (Eq x, Monoid x) => x -> Bool-{-# INLINE fnull #-}+{-# INLINABLE fnull #-} fnull = (== mempty) rid2text :: RIdentifier -> T.Text@@ -560,7 +652,7 @@ changeRelations :: (RIdentifier, HS.HashSet LinkType) -> [(T.Text, V.Vector Value)] changeRelations (k,v) = do c <- HS.toList v- return (rel2text c,V.singleton (String (rid2text k)))+ return (rel2text c, V.singleton (String (rid2text k))) instance FromJSON Resource where parseJSON (Object v) = do@@ -755,3 +847,21 @@ dummypos :: PPosition dummypos = initialPPos "dummy"++-- | Throws an error if we are in strict mode+checkStrict :: Doc -- ^ The warning message.+ -> Doc -- ^ The error message.+ -> InterpreterMonad ()+checkStrict wrn err = do+ str <- singleton IsStrict+ if str+ then throwPosError err+ else warn wrn++-- | Runs operations depending on the strict flag.+ifStrict :: InterpreterMonad a -- ^ This operation will be run in strict mode.+ -> InterpreterMonad a -- ^ This operation will be run in permissive mode.+ -> InterpreterMonad a+ifStrict yes no = do+ str <- singleton IsStrict+ if str then yes else no
Puppet/NativeTypes/File.hs view
@@ -1,11 +1,16 @@ module Puppet.NativeTypes.File (nativeFile) where -import Puppet.NativeTypes.Helpers+import Puppet.NativeTypes.Helpers hiding ((<$>)) import Control.Monad.Error import Puppet.Interpreter.Types import Data.Char (isDigit) import qualified Data.Text as T import Control.Lens+import Control.Applicative+import qualified Data.Map.Strict as M+import qualified Data.Set as S+import Data.Monoid+import qualified Data.Attoparsec.Text as AT nativeFile :: (NativeTypeName, NativeTypeMethods) nativeFile = ("file", nativetypemethods parameterfunctions (validateSourceOrContent >=> validateMode))@@ -43,15 +48,52 @@ Just (PString s) -> return s Just x -> throwError $ PrettyError ("Invalide mode type, should be a string " <+> pretty x) Nothing -> throwError "Could not find mode!"+ (numeric modestr <|> ugo modestr) & _Right %~ ($ res)++numeric :: T.Text -> Either PrettyError (Resource -> Resource)+numeric modestr = do when ((T.length modestr /= 3) && (T.length modestr /= 4)) (throwError "Invalid mode size") unless (T.all isDigit modestr) (throwError "The mode should only be made of digits")- if T.length modestr == 3- then return $ res & rattributes . at "mode" ?~ PString (T.cons '0' modestr)- else return res-+ return $ if T.length modestr == 3+ then rattributes . at "mode" ?~ PString (T.cons '0' modestr)+ else id checkSource :: T.Text -> PValue -> NativeTypeValidate-checkSource _ (PString x) res | "puppet://" `T.isPrefixOf` x = Right res- | "file://" `T.isPrefixOf` x = Right res- | otherwise = throwError "A source should start with either puppet:// or file://"+checkSource _ (PString x) res | any (`T.isPrefixOf` x) ["puppet://", "file://", "/"] = Right res+ | otherwise = throwError "A source should start with either puppet:// or file:// or an absolute path" checkSource _ x _ = throwError $ PrettyError ("Expected a string, not" <+> pretty x)++data PermParts = Special | User | Group | Other+ deriving (Eq, Ord)++data PermSet = R | W | X+ deriving (Ord, Eq)++ugo :: T.Text -> Either PrettyError (Resource -> Resource)+ugo t = AT.parseOnly (modestring <* AT.endOfInput) t+ & _Left %~ (\rr -> PrettyError $ "Could not parse the mode string: " <> text rr)+ & _Right %~ (\s -> rattributes . at "mode" ?~ PString (mkmode Special s <> mkmode User s <> mkmode Group s <> mkmode Other s))++mkmode :: PermParts -> M.Map PermParts (S.Set PermSet) -> T.Text+mkmode p m = let s = m ^. at p . non mempty+ in T.pack $ show $ fromEnum (S.member R s) * 4+ + fromEnum (S.member W s) * 2+ + fromEnum (S.member X s)++modestring :: AT.Parser (M.Map PermParts (S.Set PermSet))+modestring = M.fromList . mconcat <$> (modepart `AT.sepBy` AT.char ',')++-- TODO suid, sticky and other funky things are not yet supported+modepart :: AT.Parser [(PermParts, S.Set PermSet)]+modepart = do+ let permpart = (AT.char 'u' *> pure [User])+ <|> (AT.char 'g' *> pure [Group])+ <|> (AT.char 'o' *> pure [Other])+ <|> (AT.char 'a' *> pure [User,Group,Other])+ permission = (AT.char 'r' *> pure R)+ <|> (AT.char 'w' *> pure W)+ <|> (AT.char 'x' *> pure X)+ pp <- mconcat <$> some permpart+ void $ AT.char '='+ pr <- S.fromList <$> some permission+ return (map (\p -> (p, pr)) pp)
+ Puppet/OptionalTests.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE LambdaCase #-}+-- | The module works in IO and exits on failure.+-- It is meant to be use by a `Daemon`.+-- PS: if more flexibility is needed, we can `throwM`+-- on failure and let the caller choose what to do.+module Puppet.OptionalTests (testCatalog) where++import Control.Applicative+import Control.Lens+import Control.Monad (unless)+import Control.Monad.Trans (liftIO)+import Control.Monad.Trans.Except+import Data.Foldable (asum, toList, elem, traverse_)+import Data.Maybe (mapMaybe)+import Data.Monoid ((<>))+import qualified Data.Text as T+import Prelude hiding (all, elem)+import Puppet.Interpreter.PrettyPrinter ()+import Puppet.Interpreter.Types+import Puppet.PP hiding ((<$>))+import System.Exit (exitFailure)+import System.Posix.Files++-- | Entry point for all optional tests+testCatalog :: FilePath -> FinalCatalog -> IO ()+testCatalog = testFileSources++-- | Test source for every file resources in the catalog.+testFileSources :: FilePath -> FinalCatalog -> IO ()+testFileSources basedir c = do+ let getFiles = filter presentFile . toList+ presentFile r = r ^. rid . itype == "file"+ && (r ^. rattributes . at "ensure") `elem` [Nothing, Just "present"]+ && r ^. rattributes . at "source" /= Just PUndef+ getSource = mapMaybe (\r -> (,) <$> pure r <*> r ^. rattributes . at "source")+ checkAllSources basedir $ (getSource . getFiles) c++-- | Check source for all file resources and append failures along.+checkAllSources :: FilePath -> [(Resource, PValue)] -> IO ()+checkAllSources fp fs = go fs []+ where+ go ((res, filesource):xs) es =+ runExceptT (checkFile fp filesource) >>= \case+ Right () -> go xs es+ Left err -> go xs ((PrettyError $ "Could not find " <+> pretty filesource <> semi+ <+> align (vsep [getError err, showPos (res^.rpos^._1)])):es)+ go [] [] = pure ()+ go [] es = do+ traverse_ (\e -> putDoc $ getError e <> line) es+ exitFailure++testFile :: FilePath -> ExceptT PrettyError IO ()+testFile fp = do+ p <- liftIO (fileExist fp)+ unless p (throwE $ PrettyError $ "searched in" <+> squotes (string fp))++-- | Only test the `puppet:///` protocol (files managed by the puppet server)+-- we don't test absolute path (puppet client files)+checkFile :: FilePath -> PValue -> ExceptT PrettyError IO ()+checkFile basedir (PString f) = case T.stripPrefix "puppet:///" f of+ Just stringdir -> case T.splitOn "/" stringdir of+ ("modules":modname:rest) -> testFile (basedir <> "/modules/" <> T.unpack modname <> "/files/" <> T.unpack (T.intercalate "/" rest))+ ("files":rest) -> testFile (basedir <> "/files/" <> T.unpack (T.intercalate "/" rest))+ ("private":_) -> return ()+ _ -> throwE (PrettyError $ "Invalid file source:" <+> ttext f)+ Nothing -> return ()+-- source is always an array of possible paths. We only fails if none of them check.+checkFile basedir (PArray xs) = asum [checkFile basedir x | x <- toList xs]+checkFile _ x = throwE (PrettyError $ "Source was not a string, but" <+> pretty x)
Puppet/Parser.hs view
@@ -2,10 +2,13 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TupleSections #-}+{-| Parse puppet source code from text. -} module Puppet.Parser (- expression+ -- * Runner+ runPParser+ -- * Parsers , puppetParser- , runPParser+ , expression ) where import qualified Data.Text as T@@ -37,6 +40,35 @@ import Text.Parser.Token hiding (stringLiteral') import Text.Parser.Token.Highlight +-- | Run a puppet parser against some 'T.Text' input.+runPParser :: Parser a -> SourceName -> T.Text -> Either ParseError a+runPParser (ParserT p) = PP.parse p++-- | Parse a collection of puppet 'Statement'.+puppetParser :: Parser (V.Vector Statement)+puppetParser = someSpace >> statementList++-- | Parse a puppet 'Expression'.+expression :: Parser Expression+expression = condExpression+ <|> ParserT (buildExpressionParser expressionTable (unParser (token terminal)))+ <?> "expression"+ where+ condExpression = do+ selectedExpression <- try (token terminal <* symbolic '?')+ let cas = do+ c <- (symbol "default" *> return SelectorDefault) -- default case+ <|> fmap SelectorValue (fmap UVariableReference variableReference+ <|> fmap UBoolean puppetBool+ <|> literalValue+ <|> fmap UInterpolable interpolableString+ <|> (URegexp <$> termRegexp))+ void $ symbol "=>"+ e <- expression+ return (c :!: e)+ cases <- braces (cas `sepEndBy1` comma)+ return (ConditionalValue selectedExpression (V.fromList cases))+ newtype Parser a = ParserT { unParser :: PP.ParsecT T.Text () Identity a} deriving (Functor, Applicative, Alternative) @@ -48,9 +80,6 @@ getPosition :: Parser SourcePos getPosition = ParserT PP.getPosition -runPParser :: Parser a -> SourceName -> T.Text -> Either ParseError a-runPParser (ParserT p) = PP.parse p- type OP = PP.ParsecT T.Text () Identity instance TokenParsing Parser where@@ -204,7 +233,7 @@ (restype, resnames) <- resourceReferenceRaw return $ UResourceReference restype $ case resnames of [x] -> x- _ -> Terminal (array resnames)+ _ -> Terminal $ UArray (V.fromList resnames) bareword :: Parser T.Text bareword = identl (satisfy isAsciiLower) (satisfy acceptable) <?> "Bare word"@@ -265,26 +294,8 @@ terminal :: Parser Expression terminal = terminalG (fmap Terminal (fmap UHFunctionCall (try hfunctionCall) <|> try functionCall)) -expression :: Parser Expression-expression = condExpression- <|> ParserT (buildExpressionParser expressionTable (unParser (token terminal)))- <?> "expression"- where- condExpression = do- selectedExpression <- try (token terminal <* symbolic '?')- let cas = do- c <- (symbol "default" *> return SelectorDefault) -- default case- <|> fmap SelectorValue (fmap UVariableReference variableReference- <|> fmap UBoolean puppetBool- <|> literalValue- <|> fmap UInterpolable interpolableString- <|> (URegexp <$> termRegexp))- void $ symbol "=>"- e <- expression- return (c :!: e)- cases <- braces (cas `sepEndBy1` comma)- return (ConditionalValue selectedExpression (V.fromList cases)) + expressionTable :: [[Operator T.Text () Identity Expression]] expressionTable = [ [ Postfix (chainl1 checkLookup (return (flip (.)))) ] -- http://stackoverflow.com/questions/10475337/parsec-expr-repeated-prefix-postfix-operator-not-supported , [ Prefix ( operator' "-" >> return Negate ) ]@@ -464,7 +475,7 @@ 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- x <- resourceDeclaration `sepEndBy` (symbolic ';' <|> comma)+ x <- resourceDeclaration `sepEndBy1` (symbolic ';' <|> comma) void $ symbolic '}' virtuality <- case virts of "" -> return Normal@@ -622,12 +633,8 @@ <|> (pure . MainFunctionCall <$> mainFunctionCall) <?> "Statement" - statementList :: Parser (V.Vector Statement) statementList = fmap (V.fromList . concat) (many statement)--puppetParser :: Parser (V.Vector Statement)-puppetParser = someSpace >> statementList {- - Stuff related to the new functions with "lambdas"
Puppet/Parser/Types.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE DeriveGeneric, TemplateHaskell #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TemplateHaskell #-} -- | All the types used for parsing, and helpers working on these types. module Puppet.Parser.Types ( -- * Position management@@ -11,10 +12,7 @@ lSourceLine, lSourceColumn, -- * Helpers- capitalize', capitalizeRT,- array,- toBool, rel2text, -- * Types -- ** Expressions@@ -52,27 +50,27 @@ import Control.Lens import Data.Aeson-import Data.Char (toUpper)+import Data.Char (toUpper) import Data.Hashable-import qualified Data.Maybe.Strict as S+import qualified Data.Maybe.Strict as S import Data.Scientific import Data.String-import qualified Data.Text as T+import qualified Data.Text as T import Data.Tuple.Strict-import qualified Data.Vector as V+import qualified Data.Vector as V import GHC.Generics -import Text.Regex.PCRE.String import Text.Parsec.Pos+import Text.Regex.PCRE.String -- | Properly capitalizes resource types capitalizeRT :: T.Text -> T.Text capitalizeRT = T.intercalate "::" . map capitalize' . T.splitOn "::"--capitalize' :: T.Text -> T.Text-capitalize' t | T.null t = T.empty- | otherwise = T.cons (toUpper (T.head t)) (T.tail t)+ where+ capitalize' :: T.Text -> T.Text+ capitalize' t | T.null t = T.empty+ | otherwise = T.cons (toUpper (T.head t)) (T.tail t) -- | A pair containing the start and end of a given token. type PPosition = Pair Position Position@@ -117,9 +115,9 @@ -- The description of the /higher level function/ call. data HFunctionCall = HFunctionCall- { _hftype :: !HigherFuncType- , _hfexpr :: !(S.Maybe Expression)- , _hfparams :: !BlockParameters+ { _hftype :: !HigherFuncType+ , _hfexpr :: !(S.Maybe Expression)+ , _hfparams :: !BlockParameters , _hfstatements :: !(V.Vector Statement) , _hfexpression :: !(S.Maybe Expression) } deriving (Eq,Show)@@ -150,10 +148,8 @@ instance IsString UValue where fromString = UString . T.pack --- | A helper function for writing 'array's.-array :: [Expression] -> UValue-array = UArray . V.fromList + data SelectorCase = SelectorValue UValue | SelectorDefault deriving (Eq, Show)@@ -214,14 +210,6 @@ data CollectorType = Collector | ExportedCollector deriving (Eq, Show)---- | Tries to turn an unresolved value into a 'Bool' without any context.-toBool :: UValue -> Bool-toBool (UString "") = False-toBool (UInterpolable v) = not (V.null v)-toBool UUndef = False-toBool (UBoolean x) = x-toBool _ = True data Virtuality = Normal -- ^ Normal resource, that will be included in the catalog | Virtual -- ^ Type for virtual resources
Puppet/Plugins.hs view
@@ -37,7 +37,6 @@ import qualified Data.Text as T import qualified Data.Text.IO as T import qualified Data.Vector as V-import Control.Monad.IO.Class import Control.Concurrent import Control.Monad.Error import Control.Monad.Operational (singleton)
Puppet/Preferences.hs view
@@ -1,35 +1,45 @@-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskell #-} module Puppet.Preferences ( setupPreferences , HasPreferences(..) , Preferences(Preferences)+ , HasPuppetDirPaths(..) ) where -import Puppet.Utils-import Puppet.Interpreter.Types-import Puppet.Plugins-import Puppet.NativeTypes-import Puppet.NativeTypes.Helpers-import Puppet.Stdlib-import PuppetDB.Dummy+import Puppet.Interpreter.Types+import Puppet.NativeTypes+import Puppet.NativeTypes.Helpers+import Puppet.Plugins+import Puppet.Stdlib+import Puppet.Utils+import PuppetDB.Dummy -import qualified Data.Text as T-import qualified Data.HashMap.Strict as HM-import qualified Data.HashSet as HS-import Control.Lens+import Control.Lens+import qualified Data.HashMap.Strict as HM+import qualified Data.HashSet as HS+import qualified Data.Text as T +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.+ }++makeClassy ''PuppetDirPaths+ data Preferences m = Preferences- { _manifestPath :: FilePath -- ^ The path to the manifests.- , _modulesPath :: FilePath -- ^ The path to the modules.- , _templatesPath :: FilePath -- ^ The path to the template.- , _prefPDB :: PuppetDBAPI m- , _natTypes :: Container NativeTypeMethods -- ^ The list of native types.- , _prefExtFuncs :: Container ( [PValue] -> InterpreterMonad PValue )- , _hieraPath :: Maybe FilePath- , _ignoredmodules :: HS.HashSet T.Text -- ^ The set of ignored modules+ { _puppetPaths :: PuppetDirPaths+ , _prefPDB :: PuppetDBAPI m+ , _natTypes :: Container NativeTypeMethods -- ^ The list of native types.+ , _prefExtFuncs :: Container ( [PValue] -> InterpreterMonad PValue )+ , _hieraPath :: Maybe FilePath+ , _ignoredmodules :: HS.HashSet T.Text -- ^ The set of ignored modules+ , _strictness :: Strictness+ , _extraTests :: Bool } makeClassy ''Preferences@@ -42,11 +52,14 @@ templatedir = basedir <> "/templates" typenames <- fmap (map takeBaseName) (getFiles (T.pack modulesdir) "lib/puppet/type" ".rb") let loadedTypes = HM.fromList (map defaulttype typenames)- return $ Preferences manifestdir modulesdir templatedir dummyPuppetDB (baseNativeTypes `HM.union` loadedTypes) (stdlibFunctions) (Just (basedir <> "/hiera.yaml")) mempty+ return $ Preferences (PuppetDirPaths basedir manifestdir modulesdir templatedir) dummyPuppetDB (baseNativeTypes `HM.union` loadedTypes) (stdlibFunctions) (Just (basedir <> "/hiera.yaml")) mempty Strict True --- | Setup preferences from external/custom params--- k is set through lenses (ie: hieraPath.~mypath)-setupPreferences :: FilePath -> (Preferences IO -> Preferences IO) -> IO (Preferences IO)+{-| Use lens with the set operator and composition to set external/custom params.++Ex.: @ setupPreferences workingDir ((hieraPath.~mypath) . (prefPDB.~pdbapi)) @+-}+setupPreferences :: FilePath -- ^ The base working directory+ -> (Preferences IO -> Preferences IO) -- ^ Preference setting+ -> IO (Preferences IO) setupPreferences basedir k =- -- use lens composition fmap k (genPreferences basedir)
Puppet/Stdlib.hs view
@@ -11,7 +11,7 @@ import Data.Char import Data.Monoid import Control.Monad-import Data.Vector.Lens+import Data.Vector.Lens (toVectorOf) import Text.Regex.PCRE.ByteString.Utils import Data.Traversable (for) import qualified Data.Vector as V@@ -52,6 +52,7 @@ , ("has_key", hasKey) , ("lstrip", stringArrayFunction T.stripStart) , ("merge", merge)+ , ("member", member) , ("pick", pick) , ("rstrip", stringArrayFunction T.stripEnd) , singleArgument "size" size@@ -201,7 +202,7 @@ r <- resolvePValueString v ismatched <- matchRE regexp r return (r, ismatched)- return $ PArray $ (V.map (PString . fst) (V.filter snd rvls))+ return $ PArray $ V.map (PString . fst) (V.filter snd rvls) _grep [x,_] = throwPosError ("grep(): The first argument must be an Array, not" <+> pretty x) _grep _ = throwPosError "grep(): Expected two arguments." @@ -247,6 +248,10 @@ keys :: PValue -> InterpreterMonad PValue keys (PHash h) = return (PArray $ V.fromList $ map PString $ HM.keys h) keys x = throwPosError ("keys(): Expects a Hash, not" <+> pretty x)++member :: [PValue] -> InterpreterMonad PValue+member [PArray v, x] = return $ PBoolean (x `V.elem` v)+member _ = throwPosError "member() expects 2 arguments" hasKey :: [PValue] -> InterpreterMonad PValue hasKey [PHash h, k] = do
− Puppet/Testing.hs
@@ -1,213 +0,0 @@-{-# LANGUAGE TemplateHaskell, LambdaCase #-}-module Puppet.Testing- ( module Control.Lens- , module Data.Monoid- , module Puppet.PP- , module Puppet.Interpreter.Types- , module Puppet.Lens- , H.hspec- , basicTest- , usersGroupsDefined- , testingDaemon- , defaultDaemon- , testCatalog- , describeCatalog- , it- , shouldBe- , PSpec- , PSpecM- , lCatalog- , lModuledir- , lPuppetdir- , withResource- , withParameter- , withParameters- , withFileContent- ) where--import Prelude hiding (notElem,all)-import Control.Lens-import Data.Foldable hiding (forM_,mapM_)-import Data.Maybe-import Data.Monoid-import Control.Monad.Error-import Control.Monad.Reader-import Control.Applicative-import System.Posix.Files-import qualified Data.HashSet as HS-import qualified Data.Either.Strict as S-import qualified Data.Text as T-import qualified System.Log.Logger as LOG-import qualified Test.Hspec as H-import qualified Test.Hspec.Formatters as H-import qualified Test.Hspec.Runner as H-import qualified Test.Hspec.Core as HC-import Facter-import PuppetDB.Common--import Puppet.Preferences-import Puppet.PP hiding ((<$>))-import Puppet.Daemon-import Puppet.Lens-import Puppet.Interpreter.Types-import Puppet.Interpreter.PrettyPrinter ()---- | The state of the reader monad the tests run in-data TestEnv = TestEnv { _lCatalog :: FinalCatalog- , _lModuledir :: FilePath- , _lPuppetdir :: FilePath- }-makeClassy ''TestEnv--type PSpecM = ReaderT TestEnv HC.SpecM-type PSpec = PSpecM ()--testCatalog :: Nodename -> FilePath -> FinalCatalog -> PSpec -> IO H.Summary-testCatalog nd pdir catlg test = H.hspecWith (H.defaultConfig { H.configFormatter = H.silent { H.failedFormatter = fform } })- (describeCatalog nd pdir catlg test)- where- fform = do- failures <- H.getFailMessages- forM_ failures $ \(H.FailureRecord path reason) -> do- H.write ("[" ++ T.unpack nd ++ "] ")- H.writeLine (snd path)- let err = either (("uncaught exception: " ++) . H.formatException) id reason- H.withFailColor $ unless (null err) $ H.writeLine err- unless (null failures) H.newParagraph--describeCatalog :: Nodename -> FilePath -> FinalCatalog -> PSpec -> H.Spec-describeCatalog nd pdir catlg test = H.describe (T.unpack nd) $ runReaderT test (TestEnv catlg (pdir <> "/modules") pdir)---- | This tests that file sources are valid.-basicTest :: PSpec-basicTest = hTestFileSources---- | This tests that all users and groups used as resource parameters are--- defined-usersGroupsDefined :: PSpec-usersGroupsDefined = do- c <- view lCatalog- let getResourceType t = c ^.. traverse . filtered (\r -> r ^. rid . itype == t && r ^. rattributes . at "ensure" /= Just "absent")- users = getResourceType "user"- groups = getResourceType "group"- knownUsers = HS.fromList $ map (view (rid . iname)) users ++ ["root","","syslog","mysql","puppet","vagrant","nginx","www-data","nagios", "postgres"]- knownGroups = HS.fromList $ map (view (rid . iname)) groups ++ ["root", "adm", "syslog", "mysql", "nagios","puppet","","www-data", "postgres"]- checkResource lensU lensG = mapM_ (checkResource' lensU lensG)- checkResource' lensU lensG res = do- let d = "Resource " <> show (pretty res) <> " should have a valid "- case lensU of- Just lensU' -> do- let u = res ^. rattributes . lensU' . _PString- H.it (d <> "username (" ++ T.unpack u ++ ")") (HS.member u knownUsers)- Nothing -> return ()- case lensG of- Just lensG' -> do- let g = res ^. rattributes . lensG' . _PString- H.it (d <> "group (" ++ T.unpack g ++ ")") (HS.member g knownGroups)- Nothing -> return ()- lift $ do- checkResource (Just $ ix "owner") (Just $ ix "group") (getResourceType "file")- checkResource (Just $ ix "user") (Just $ ix "group") (getResourceType "exec")- checkResource (Just $ ix "user") Nothing (getResourceType "cron")- checkResource (Just $ ix "user") Nothing (getResourceType "ssh_authorized_key")- checkResource (Just $ ix "user") Nothing (getResourceType "ssh_authorized_key_secure")- checkResource (Nothing) (Just $ ix "gid") users--it :: HC.Example a => String -> PSpecM a -> PSpec-it n tst = tst >>= lift . H.it n--shouldBe :: (Show a, Eq a) => a -> a -> PSpecM H.Expectation-shouldBe a b = return (a `H.shouldBe` b)---- | Run tests on a specific resource-withResource :: String -- ^ The test description (the thing that goes after should)- -> T.Text -- ^ Resource type- -> T.Text -- ^ Resource name- -> (Resource -> H.Expectation) -- ^ Testing function- -> PSpec-withResource desc t n o = do- let ridentifier = RIdentifier t n- mr <- view (lCatalog . at ridentifier)- lift $ case mr of- Nothing -> H.it ("Should have resource " ++ show (pretty ridentifier)) (H.expectationFailure "Resource not found")- Just v -> H.it ("Resource " ++ show (pretty ridentifier) ++ " should " ++ desc) (o v)---- | Tests a specific parameter-withParameter :: T.Text -- ^ The parameter name- -> Resource -- ^ The resource to test- -> (PValue -> H.Expectation) -- ^ Testing function- -> H.Expectation-withParameter prm r o = do- case r ^. rattributes . at prm of- Nothing -> H.expectationFailure ("Parameter " ++ T.unpack prm ++ " not found")- Just v -> o v---- | Test a serie of parameters-withParameters :: [(T.Text, PValue)] -- ^ The parameter names and values- -> Resource -- ^ The resource to test- -> H.Expectation-withParameters prmlist r = forM_ prmlist $ \(nm, vl) -> withParameter nm r (`H.shouldBe` vl)---- | Retrieves a given file content, and runs a test on it. It works on the--- explicit "content" parameter, or can resolve the "source" parameter to--- open the file.-withFileContent :: String -- ^ Test description (the thing that goes after should)- -> T.Text -- ^ The file path- -> (T.Text -> H.Expectation) -- ^ Testing function- -> PSpec-withFileContent desc fn action = withResource desc "file" fn $ \r ->- case r ^? rattributes . ix "content" . _PString of- Just v -> action v- Nothing -> H.expectationFailure "Content not found"--hTestFileSources :: PSpec-hTestFileSources = do- let getFiles = filter presentFile . toList- presentFile r | r ^. rid . itype /= "file" = False- | (r ^. rattributes . at "ensure") `notElem` [Nothing, Just "present"] = False- | r ^. rattributes . at "source" == Just PUndef = False- | otherwise = True- getSource = mapMaybe (\r -> (,) `fmap` pure r <*> r ^. rattributes . at "source")- files <- fmap (getSource . getFiles) $ view lCatalog- pdir <- view lPuppetdir- forM_ files $ \(r,filesource) -> it ("should have a source for " ++ r ^. rid . iname . to T.unpack) $ do- let- testFile :: FilePath -> ErrorT PrettyError IO ()- testFile fp = liftIO (fileExist fp) >>= (`unless` (throwError $ PrettyError $ "Searched in" <+> string fp))- checkFile :: PValue -> ErrorT PrettyError IO ()- checkFile res@(PArray ar) = asum [checkFile x | x <- toList ar] <|> throwError (PrettyError $ "Could not find the file in" <+> pretty res)- checkFile (PString f) =- case (T.stripPrefix "puppet:///" f, T.stripPrefix "file:///" f) of- (Just stringdir, _) -> case T.splitOn "/" stringdir of- ("modules":modulename:rest) -> testFile (pdir <> "/modules/" <> T.unpack modulename <> "/files/" <> T.unpack (T.intercalate "/" rest))- ("files":rest) -> testFile (pdir <> "/files/" <> T.unpack (T.intercalate "/" rest))- ("private":_) -> return ()- _ -> throwError (PrettyError $ "Invalid file source:" <+> ttext f)- (Nothing, Just _) -> return ()- _ -> throwError (PrettyError $ "The source does not start with puppet:///, but is" <+> ttext f)- checkFile x = throwError (PrettyError $ "Source was not a string, but" <+> pretty x)- return $ do- rs <- runErrorT (checkFile filesource)- case rs of- Right () -> return ()- Left rr -> fail (show (getError rr))---- | Initializes a daemon made for running tests, using the specific test--- puppetDB-testingDaemon :: PuppetDBAPI IO -- ^ Contains the puppetdb API functions- -> FilePath -- ^ Path to the manifests- -> (T.Text -> IO Facts) -- ^ The facter function- -> IO (T.Text -> IO (S.Either PrettyError (FinalCatalog, EdgeMap, FinalCatalog, [Resource])))-testingDaemon pdb pdir allFacts = do- LOG.updateGlobalLogger "Puppet.Daemon" (LOG.setLevel LOG.WARNING)- prefs <- setupPreferences pdir (prefPDB.~pdb)- q <- initDaemon prefs- return (\nodname -> allFacts nodname >>= _dGetCatalog q nodname)---- | A default testing daemon.-defaultDaemon :: FilePath -> IO (T.Text -> IO (S.Either PrettyError (FinalCatalog, EdgeMap, FinalCatalog, [Resource])))-defaultDaemon pdir = do- pdb <- getDefaultDB PDBTest >>= \case- S.Left x -> error (show (getError x))- S.Right y -> return y- testingDaemon pdb pdir (flip puppetDBFacts pdb)
PuppetDB/TestDB.hs view
@@ -1,34 +1,39 @@-{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, LambdaCase #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskell #-} -- | A stub implementation of PuppetDB, backed by a YAML file. module PuppetDB.TestDB (loadTestDB,initTestDB) where -import Data.Yaml-import qualified Data.Text as T-import qualified Data.Either.Strict as S-import qualified Data.Vector as V-import Control.Lens-import Data.Aeson.Lens-import Control.Exception-import Control.Concurrent.STM-import Data.Monoid-import Control.Applicative-import Data.List (foldl')-import Text.Parsec.Pos-import Data.CaseInsensitive-import qualified Data.HashMap.Strict as HM-import qualified Data.HashSet as HS+import Control.Applicative+import Control.Concurrent.STM+import Control.Exception+import Control.Lens+import Data.Aeson.Lens+import Data.CaseInsensitive+import qualified Data.Either.Strict as S+import qualified Data.HashMap.Strict as HM+import qualified Data.HashSet as HS+import Data.List (foldl')+import Data.Monoid+import qualified Data.Text as T+import qualified Data.Vector as V+import Data.Yaml+import Text.Parsec.Pos -import Puppet.Parser.Types-import Puppet.Interpreter.Types-import Puppet.PP hiding ((<$>))-import Puppet.Lens+import Puppet.Interpreter.Types+import Puppet.Lens+import Puppet.Parser.Types+import Puppet.PP hiding ((<$>)) data DBContent = DBContent- { _dbcontentResources :: Container WireCatalog- , _dbcontentFacts :: Container Facts+ { _dbcontentResources :: Container WireCatalog+ , _dbcontentFacts :: Container Facts , _dbcontentBackingFile :: Maybe FilePath }-makeFields ''DBContent++makeLensesWith abbreviatedFields ''DBContent type DB = TVar DBContent
README.adoc view
@@ -15,46 +15,56 @@ cabal install -j -p ``` -There are also http://lpuppet.banquise.net/download/[binary packages available] .+There are also http://lpuppet.banquise.net/download/[binary packages available] and https://registry.hub.docker.com/u/pierrer/puppetresources[a 400M docker images]. == Puppetresources -The `puppetresources` command is a command line utility that let you interactively compute catalogs on your local computer. It will then display them on screen, in a nice,-user-friendly colored fashion. It is much faster than its ruby counterpart, and has been designed for giving assistance to the Puppet catalog writer. Here is a list of command line-arguments :+The `puppetresources` command is a command line utility that let you interactively compute catalogs on your local computer.+It is much faster than its ruby counterpart, and has been designed for giving assistance to the Puppet catalog writer.+There are 4 different modes: +* `--node` will display all resources on screen in a nice user-friendly colored fashion.+* `--all` displays statitics and optionally shows dead code.+* `--parse` only goes as far as parsing. No interpretation.+* `--showcontent` to display file content.++Catalog can be verified using strict or more permissive rules.++=== Command line arguments+ `-p` or `--puppetdir`:: -This is the only mandatory argument. It accepts a directory or file path as the argument. In the absence of `-o`, it will parse and display the puppet file given as a parameter.-With `-o` it must point to the base of the puppet directory (the directory that contains the `modules` and `manifests` directories).+This argument is mandatory except in `parse` mode. It must point to the base of the puppet directory (the directory that contains the `modules` and `manifests` directories). `-o` or `--node`:: -This let you specify the name of the node you wish to compute the catalog for.-+-If you use `allnodes` as the node name, it will compute the catalogs for all nodes that are specified in `site.pp` (this will not work for regexp-specified or the default nodes). This is useful-for writing automated tests, to check a change didn't break something.+Enable the `node mode`. This let you specify the name of the node you wish to compute the catalog for.++`-a` or `-all`::++Enable the `stats mode`. If you specify `allnodes` it will compute the catalogs for all nodes that are specified in `site.pp` (this will not work for regexp-specified or the default nodes). You can also specify a list of nodes separated by a comma. +-If you use `deadcode` as the node name, it will also compute the catalogs for all nodes, but will display the list of puppet files that have not been used, and that might be-deprecated.+Combined with `--deadcode`, it will display the list of puppet files that have not been used. +-You might want to run the program with `+RTS -N` with those two modes.+This is useful as automated tests, to check a change didn't break something. You might want to run this option with `+RTS -N`. `-t` or `--type`:: -Filters the resources of the resulting catalog by type, but specifying a regular expression. Only the resources whose types match the submitted regexp will be displayed.+Filters the resources of the resulting catalog by type. Using PCRE regex is supported. `-n` or `--name`:: -Filters the resources of the resulting catalog by name, but specifying a regular expression. Only the resources whose names match the submitted regexp will be displayed.+Filters the resources of the resulting catalog by name. Using PCRE regex is supported. `-c` or `--showcontent`:: -If `-n` is the exact name of a file defined in the catalog, this will display its content. This is mainly useful for debugging templates.+If `-n` is the exact name of a file type resource defined in the catalog, this will display the file content nicely. Useful for debugging templates.+++Example: `puppetresources -p . -o mynodename -n '/etc/motd' --showcontent` `--loglevel` or `-v`:: -Expects a log level. Possible values are : DEBUG, INFO, NOTICE, WARNING, ERROR, CRITICAL, ALERT, EMERGENCY.+Possible values are : DEBUG, INFO, NOTICE, WARNING, ERROR, CRITICAL, ALERT, EMERGENCY. `--pdburl`:: @@ -73,11 +83,6 @@ Expects a list of comma-separated modules. The interpreter will not try to evaluate the defined types and classes from this module. This is useful for using modules that use bad practices forbidden by `puppetresources`. -`--nousergrouptest`::--By default, `puppetresources` will check that all users and groups referenced by `cron`, `file`, etc. types are defined somewhere in the catalog (except for a list of widely-available users, such as `root`). This flag disables these tests.- `--commitdb`:: When this flag is set, exported resources, catalogs and facts are saved in the PuppetDB. This is useful in conjunction with `--pdbfile`.@@ -95,6 +100,23 @@ Both options expect a path to a YAML file defining facts. The first option will override the facts that are collected locally, while the second will merely provide default values for them. +`--strict`::++Enable strict check.+Strict is less permissive than vanilla Puppet.+It is meant to prevent some pitfalls by enforcing good practices.+For instance it refuses to+ - silently ignore/convert `undef` variables+ - lookup an hash with an unknown key and return `undef`.++`--noextratests`::++Disable the extra tests from `Puppet.OptionalTests`.++`--parse`::++Enable `parse mode`. Specify the puppet file to be parsed. Variables are not resolved. No interpretation.+ == pdbQuery The `pdbQuery` command is used to work with different implementations of PuppetDB (the official one with its HTTP API, the file-based backend and dummy ones). Its main use is to@@ -133,6 +155,7 @@ puppet functions:: * the `require` function is not supported (see https://github.com/bartavelle/language-puppet/issues/17[issue #17])+ * the deprecated `import` function is not supported (see https://github.com/bartavelle/language-puppet/issues/82[issue #82]) custom ruby functions:: Currently the only way to support your custom ruby functions is to rewrite them in Lua.
language-puppet.cabal view
@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: language-puppet-version: 1.0.1+version: 1.1.0 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/@@ -26,58 +26,55 @@ type: git location: git://github.com/bartavelle/language-puppet.git - library- exposed-modules: Puppet.Parser.Types- , Puppet.Parser- , Puppet.Interpreter.Types- , Puppet.Parser.PrettyPrinter- , Puppet.Interpreter.PrettyPrinter- , Puppet.Preferences- , Puppet.Daemon+ exposed-modules: Erb.Evaluate+ , Erb.Parser+ , Erb.Ruby , Facter- , Puppet.PP- , Puppet.Stats- , Puppet.NativeTypes- , Puppet.NativeTypes.Helpers- , Puppet.Interpreter- , Puppet.Interpreter.Resolve- , SafeProcess- , Puppet.Stdlib- , Puppet.Testing+ , Hiera.Server+ , Puppet.Daemon+ , PuppetDB.Common+ , PuppetDB.Dummy , PuppetDB.Remote , PuppetDB.TestDB- , PuppetDB.Dummy- , PuppetDB.Common- , Hiera.Server- , Erb.Parser- , Erb.Ruby- , Erb.Evaluate- , Puppet.Lens+ , Puppet.Interpreter , Puppet.Interpreter.IO+ , Puppet.Interpreter.PrettyPrinter , Puppet.Interpreter.Pure- other-modules: Puppet.Utils- , Puppet.NativeTypes.File- , Erb.Compute+ , Puppet.Interpreter.Resolve+ , Puppet.Interpreter.Types+ , Puppet.Lens+ , Puppet.NativeTypes+ , Puppet.NativeTypes.Helpers+ , Puppet.Parser+ , Puppet.Parser.PrettyPrinter+ , Puppet.Parser.Types+ , Puppet.PP+ , Puppet.Preferences+ , Puppet.Stats+ , Puppet.Stdlib+ , Puppet.OptionalTests+ , SafeProcess+ other-modules: Erb.Compute , Paths_language_puppet+ , Puppet.Interpreter.RubyRandom , Puppet.Manifests- , Puppet.NativeTypes.ZoneRecord , Puppet.NativeTypes.Concat , Puppet.NativeTypes.Cron , Puppet.NativeTypes.Exec+ , Puppet.NativeTypes.File , Puppet.NativeTypes.Group , Puppet.NativeTypes.Host- , Puppet.NativeTypes.User , Puppet.NativeTypes.Mount- , Puppet.Utils , Puppet.NativeTypes.Package , Puppet.NativeTypes.SshSecure+ , Puppet.NativeTypes.User+ , Puppet.NativeTypes.ZoneRecord , Puppet.Plugins- , Puppet.Interpreter.RubyRandom+ , Puppet.Utils extensions: OverloadedStrings, BangPatterns ghc-options: -Wall -funbox-strict-fields ghc-prof-options: -auto-all -caf-all- -- other-modules: build-depends: base >=4.6 && < 4.8 , aeson >= 0.7 && < 0.9 , ansi-wl-pprint == 0.6.*@@ -90,14 +87,13 @@ , directory == 1.2.* , filecache >= 0.2.5 && < 0.3 , hashable == 1.2.*- , hruby >= 0.2.5 && <0.3+ , hruby >= 0.2.5 && <0.3 , hslogger == 1.2.* , hslua >= 0.3.10 && < 0.4- , hspec >= 1.9 && < 1.12 , http-conduit >= 2.1 && < 2.2 , http-types == 0.8.* , iconv == 0.4.*- , lens >= 4.4 && < 4.5+ , lens >= 4.6 && < 4.9 , lens-aeson >= 1.0 , luautils >= 0.1.3 && < 0.1.4 , mtl == 2.1.*@@ -109,12 +105,11 @@ , regex-pcre-builtin >= 0.94.4 , scientific >= 0.2 && < 0.4 , split == 0.2.*- , stateWriter >= 0.2.1 && < 0.3 , stm == 2.4.* , strict-base-types >= 0.2.2 , text >= 0.11 , time == 1.4.*- , transformers == 0.3.*+ , transformers-compat == 0.4.* , unix >= 2.6 && < 2.8 , unordered-containers == 0.2.* , vector == 0.10.*@@ -138,7 +133,7 @@ type: exitcode-stdio-1.0 ghc-options: -Wall -rtsopts -threaded extensions: OverloadedStrings- build-depends: language-puppet,base,text,parsers,vector,ansi-wl-pprint+ build-depends: language-puppet,base,text,parsers,vector,ansi-wl-pprint, strict-base-types main-is: expr.hs Test-Suite test-hiera hs-source-dirs: tests
progs/PuppetResources.hs view
@@ -1,72 +1,82 @@-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-} module Main where -import Control.Concurrent.ParallelIO (parallel)+import Control.Concurrent.ParallelIO (parallel) import Control.Lens import Control.Monad-import Data.Aeson (encode)-import qualified Data.ByteString.Lazy.Char8 as BSL-import Data.Either (partitionEithers)-import qualified Data.Either.Strict as S-import qualified Data.HashMap.Strict as HM-import qualified Data.HashSet as HS-import Data.List (isInfixOf)-import Data.Maybe (mapMaybe)-import Data.Monoid hiding (First)-import qualified Data.Set as Set-import qualified Data.Text as T-import qualified Data.Text.IO as T+import Data.Aeson (encode)+import qualified Data.ByteString.Lazy.Char8 as BSL+import Data.Either (partitionEithers)+import qualified Data.Either.Strict as S+import Data.Foldable (foldMap)+import qualified Data.HashMap.Strict as HM+import qualified Data.HashSet as HS+import Data.List (isInfixOf)+import Data.Maybe (isNothing, mapMaybe)+import Data.Monoid hiding (First)+import qualified Data.Set as Set+import qualified Data.Text as T+import qualified Data.Text.IO as T import Data.Text.Strict.Lens-import Data.Tuple (swap)-import qualified Data.Vector as V-import Data.Yaml (decodeFileEither)+import Data.Tuple (swap)+import qualified Data.Vector as V+import Data.Yaml (decodeFileEither) import Options.Applicative-import System.Exit (exitFailure, exitSuccess)-import qualified System.FilePath.Glob as G+import System.Exit (exitFailure, exitSuccess)+import qualified System.FilePath.Glob as G import System.IO-import qualified System.Log.Logger as LOG-import qualified Test.Hspec.Runner as H-import qualified Text.Parsec as P+import qualified System.Log.Logger as LOG+import qualified Text.Parsec as P import Text.Regex.PCRE.String import Facter -import Puppet.PP hiding ((<$>))-import Puppet.Preferences import Puppet.Daemon+import Puppet.Interpreter.PrettyPrinter () import Puppet.Interpreter.Types-import Puppet.Parser.Types+import Puppet.Lens import Puppet.Parser-import Puppet.Parser.PrettyPrinter(ppStatements)-import Puppet.Interpreter.PrettyPrinter()-import PuppetDB.Remote+import Puppet.Parser.PrettyPrinter (ppStatements)+import Puppet.Parser.Types+import Puppet.PP hiding ((<$>))+import Puppet.Preferences+import Puppet.Stats+import PuppetDB.Common import PuppetDB.Dummy+import PuppetDB.Remote import PuppetDB.TestDB-import PuppetDB.Common-import Puppet.Testing-import Puppet.Stats +type QueryFunc = Nodename -> IO (S.Either PrettyError (FinalCatalog, EdgeMap, FinalCatalog, [Resource])) -type QueryFunc = T.Text -> IO (S.Either PrettyError (FinalCatalog, EdgeMap, FinalCatalog, [Resource]))+data MultNodes = MultNodes [T.Text] | AllNodes deriving Show +instance Read MultNodes where+ readsPrec _ "allnodes" = [(AllNodes, "")]+ readsPrec _ s = let os = (T.splitOn "," . T.pack) s+ in [(MultNodes os, "")]+ data Options = Options- { _pdb :: Maybe String- , _showjson :: Bool- , _showContent :: Bool+ { _pdb :: Maybe String+ , _showjson :: Bool+ , _showContent :: Bool , _resourceType :: Maybe T.Text , _resourceName :: Maybe T.Text- , _puppetdir :: FilePath- , _nodename :: Maybe T.Text- , _pdbfile :: Maybe FilePath- , _loglevel :: LOG.Priority- , _hieraFile :: Maybe FilePath- , _factsOverr :: Maybe FilePath+ , _puppetdir :: Maybe FilePath+ , _nodename :: Maybe Nodename+ , _multnodes :: Maybe MultNodes+ , _deadcode :: Bool+ , _pdbfile :: Maybe FilePath+ , _loglevel :: LOG.Priority+ , _hieraFile :: Maybe FilePath+ , _factsOverr :: Maybe FilePath , _factsDefault :: Maybe FilePath- , _commitDB :: Bool- , _checkExport :: Bool- , _nousergrouptest :: Bool- , _ignoredMods :: HS.HashSet T.Text+ , _commitDB :: Bool+ , _checkExport :: Bool+ , _ignoredMods :: HS.HashSet T.Text+ , _parse :: Maybe FilePath+ , _strictMode :: Strictness+ , _noExtraTests :: Bool } deriving (Show) options :: Parser Options@@ -90,15 +100,21 @@ ( long "name" <> short 'n' <> help "Filter the output by resource name (accepts a regular expression)"))- <*> strOption+ <*> optional (strOption ( long "puppetdir" <> short 'p'- <> help "Puppet directory")+ <> help "Puppet directory")) <*> optional (T.pack <$> strOption- ( long "node"- <> short 'o'- <> help "Node name. Using 'allnodes' enables a special mode where all nodes present in site.pp are tried. \- \ Run with +RTS -N. Using 'deadcode' will do the same, but will print warnings about code that's not being used."))+ ( long "node"+ <> short 'o'+ <> help "The name of the node"))+ <*> optional (option auto+ ( long "all"+ <> short 'a'+ <> help "Values are a list of nodes or \"allnodes\""))+ <*> switch+ ( long "deadcode"+ <> help "Show deadcode when the --all option is used") <*> optional (strOption ( long "pdbfile" <> help "Path to the testing PuppetDB file."))@@ -123,29 +139,55 @@ <*> switch ( long "checkExported" <> help "Save exported resources in the puppetDB")- <*> switch- ( long "nousergrouptest"- <> help "Disable the user and group tests") <*> (HS.fromList . T.splitOn "," . T.pack <$> strOption ( long "ignoremodules" <> help "Specify a comma-separated list of modules to ignore" <> value ""))+ <*> optional (strOption+ ( long "parse"+ <> help "Parse a single file"))+ <*> flag Permissive Strict+ ( long "strict"+ <> help "Strict mode diverges from vanillia Puppet and enforces good practices")+ <*> flag False True+ ( long "noextratests"+ <> help "Disable extra tests (eg.: check that files exist on local disk") checkError :: Doc -> S.Either PrettyError a -> IO a checkError r (S.Left rr) = error (show (red r <> ": " <+> getError rr)) checkError _ (S.Right x) = return x +-- | Like catMaybes, but it counts the Nothing values+catMaybesCount :: [Maybe a] -> ([a], Sum Int)+catMaybesCount = foldMap f where+ f Nothing = ([ ], Sum 1)+ f (Just x) = ([x], Sum 0)+ {-| Does all the work of initializing a daemon for querying.-Returns the final catalog when given a node name. Note that this is pretty-hackish as it will generate facts from the local computer !+Returns a 'QueryFunc' API, together with some stats.+Be aware it uses the locale computer to generate a set of `facts` (this is a bit hackish).+These facts can be overriden at the command line (see 'Options'). -}-initializedaemonWithPuppet :: LOG.Priority -> PuppetDBAPI IO -> FilePath -> Maybe FilePath -> (Facts -> Facts) -> HS.HashSet T.Text -> IO (QueryFunc, MStats, MStats, MStats)-initializedaemonWithPuppet loglevel pdbapi puppetdir hiera overrideFacts ignoremod = do- LOG.updateGlobalLogger "Puppet.Daemon" (LOG.setLevel loglevel)- q <- initDaemon =<< setupPreferences puppetdir ((prefPDB.~ pdbapi) . (hieraPath.~ hiera) . (ignoredmodules.~ ignoremod))- let f node = fmap overrideFacts (puppetDBFacts node pdbapi) >>= _dGetCatalog q node- return (f, _dParserStats q, _dCatalogStats q, _dTemplateStats q)+initializedaemonWithPuppet :: FilePath -> Options+ -> IO (QueryFunc, PuppetDBAPI IO, MStats, MStats, MStats)+initializedaemonWithPuppet workingdir (Options {_pdb, _pdbfile, _loglevel, _hieraFile, _factsOverr, _factsDefault, _ignoredMods, _strictMode, _noExtraTests}) = do+ pdbapi <- case (_pdb, _pdbfile) of+ (Nothing, Nothing) -> return dummyPuppetDB+ (Just _, Just _) -> error "You must choose between a testing PuppetDB and a remote one"+ (Just url, _) -> pdbConnect (T.pack url) >>= checkError "Error when connecting to the remote PuppetDB"+ (_, Just file) -> loadTestDB file >>= checkError "Error when initializing the PuppetDB API"+ !factsOverrides <- case (_factsOverr, _factsDefault) of+ (Just _, Just _) -> error "You can't use --facts-override and --facts-defaults at the same time"+ (Just p, Nothing) -> HM.union `fmap` loadFactsOverrides p+ (Nothing, Just p) -> flip HM.union `fmap` loadFactsOverrides p+ (Nothing, Nothing) -> return id+ LOG.updateGlobalLogger "Puppet.Daemon" (LOG.setLevel _loglevel)+ LOG.updateGlobalLogger "Hiera.Server" (LOG.setLevel _loglevel)+ q <- initDaemon =<< setupPreferences+ workingdir ((prefPDB.~ pdbapi) . (hieraPath.~ _hieraFile) . (ignoredmodules.~ _ignoredMods) . (strictness.~ _strictMode) . (extraTests.~ not _noExtraTests))+ let queryfunc = \node -> fmap factsOverrides (puppetDBFacts node pdbapi) >>= _dGetCatalog q node+ return (queryfunc, pdbapi, _dParserStats q, _dCatalogStats q, _dTemplateStats q) parseFile :: FilePath -> IO (Either P.ParseError (V.Vector Statement)) parseFile = fmap . runPParser puppetParser <*> T.readFile@@ -154,7 +196,7 @@ printContent filename catalog = case HM.lookup (RIdentifier "file" filename) catalog of Nothing -> error "File not found"- Just r -> case HM.lookup "content" (_rattributes r) of+ Just r -> case HM.lookup "content" (r ^. rattributes) of Nothing -> error "This file has no content" Just (PString c) -> T.putStrLn c Just x -> print x@@ -196,7 +238,7 @@ Left rr -> error ("Error when parsing " ++ fp ++ ": " ++ show rr) Right x -> return x --- this finds the dead code+-- | Finds the dead code findDeadCode :: String -> [Resource] -> Set.Set FilePath -> IO () findDeadCode puppetdir catalogs allfiles = do -- first collect all files / positions from all the catalogs@@ -240,120 +282,132 @@ mappend (Maximum (Just a1)) (Maximum (Just a2)) = Maximum (Just (max a1 a2)) -run :: Options -> IO ()-run (Options {_nodename = Nothing, _puppetdir}) = parseFile _puppetdir >>= \case- Left rr -> error ("parse error:" ++ show rr)- Right s -> putDoc $ ppStatements s+-- | For each node, queryfunc the catalog and return stats+computeStats :: FilePath -> Options -> QueryFunc -> (MStats, MStats, MStats) -> [Nodename] -> IO ()+computeStats workingdir (Options {_loglevel, _deadcode})+ queryfunc (parsingStats, catalogStats, templateStats)+ topnodes = do+ -- the parsing statistics, so that we known which files+ (cats, Sum failures) <- catMaybesCount <$> parallel (map (computeCatalog queryfunc) topnodes)+ pStats <- getStats parsingStats+ cStats <- getStats catalogStats+ tStats <- getStats templateStats+ let allres = (cats ^.. folded . _1 . folded) ++ (cats ^.. folded . _2 . folded)+ allfiles = Set.fromList $ map T.unpack $ HM.keys pStats+ when _deadcode $ findDeadCode workingdir allres allfiles+ -- compute statistics+ let (parsing, Just (wPName, wPMean)) = worstAndSum pStats+ (cataloging, Just (wCName, wCMean)) = worstAndSum cStats+ (templating, Just (wTName, wTMean)) = worstAndSum tStats+ parserShare = 100 * parsing / cataloging+ templateShare = 100 * templating / cataloging+ formatDouble = take 5 . show -- yeah, well ...+ nbnodes = length topnodes+ worstAndSum = (_1 %~ getSum)+ . (_2 %~ fmap swap . getMaximum)+ . ifoldMap (\k (StatsPoint cnt total _ _) -> (Sum total, Maximum $ Just (total / fromIntegral cnt, k)))+ putStr ("Tested " ++ show nbnodes ++ " nodes. ")+ unless (nbnodes == 0) $ do+ putStrLn (formatDouble parserShare <> "% of total CPU time spent parsing, " <> formatDouble templateShare <> "% spent computing templates")+ when (_loglevel <= LOG.INFO) $ do+ putStrLn ("Slowest template: " <> T.unpack wTName <> ", taking " <> formatDouble wTMean <> "s on average")+ putStrLn ("Slowest file to parse: " <> T.unpack wPName <> ", taking " <> formatDouble wPMean <> "s on average")+ putStrLn ("Slowest catalog to compute: " <> T.unpack wCName <> ", taking " <> formatDouble wCMean <> "s on average") -run cmd@(Options {_nodename = Just node, _pdb, _puppetdir, _pdbfile, _loglevel, _hieraFile, _factsOverr, _factsDefault, _commitDB, _ignoredMods}) = do- pdbapi <- case (_pdb, _pdbfile) of- (Nothing, Nothing) -> return dummyPuppetDB- (Just _, Just _) -> error "You must choose between a testing PuppetDB and a remote one"- (Just url, _) -> pdbConnect (T.pack url) >>= checkError "Error when connecting to the remote PuppetDB"- (_, Just file) -> loadTestDB file >>= checkError "Error when initializing the PuppetDB API"- !factsOverrides <- case (_factsOverr, _factsDefault) of- (Just _, Just _) -> error "You can't use --facts-override and --facts-defaults at the same time"- (Just p, Nothing) -> HM.union `fmap` loadFactsOverrides p- (Nothing, Just p) -> (flip HM.union) `fmap` loadFactsOverrides p- (Nothing, Nothing) -> return id- (queryfunc,mPStats,mCStats,mTStats) <- initializedaemonWithPuppet _loglevel pdbapi _puppetdir _hieraFile factsOverrides _ignoredMods- printFunc <- hIsTerminalDevice stdout >>= \isterm -> return $ \x ->- if isterm- then putDoc x >> putStrLn ""- else displayIO stdout (renderCompact x) >> putStrLn ""- let allnodes = node == "allnodes" || deadcode- deadcode = node == "deadcode"- exit <- if allnodes- then do- allstmts <- parseFile (_puppetdir <> "/manifests/site.pp") >>= \presult -> case presult of- Left rr -> error (show rr)- Right x -> return x- let topnodes = mapMaybe getNodeName (V.toList allstmts)- getNodeName (Node (Nd (NodeName n) _ _ _)) = Just n- getNodeName _ = Nothing- cats <- parallel (map (computeCatalogs True queryfunc pdbapi printFunc cmd) topnodes)- -- the the parsing statistics, so that we known which files- -- were parsed- pStats <- getStats mPStats- cStats <- getStats mCStats- tStats <- getStats mTStats- -- merge all the resources together- let cc = mapMaybe fst cats- testFailures = getSum (cats ^. traverse . _2 . _Just . to (Sum . H.summaryFailures))- allres = (cc ^.. folded . _1 . folded) ++ (cc ^.. folded . _2 . folded)- allfiles = Set.fromList $ map T.unpack $ HM.keys pStats- when deadcode $ findDeadCode _puppetdir allres allfiles- -- compute statistics- let (parsing, Just (wPName, wPMean)) = worstAndSum pStats- (cataloging, Just (wCName, wCMean)) = worstAndSum cStats- (templating, Just (wTName, wTMean)) = worstAndSum tStats- parserShare = 100 * parsing / cataloging- templateShare = 100 * templating / cataloging- formatDouble = take 5 . show -- yeah, well ...- nbnodes = length topnodes- worstAndSum = (_1 %~ getSum)- . (_2 %~ fmap swap . getMaximum)- . ifoldMap (\k (StatsPoint cnt total _ _) -> (Sum total, Maximum $ Just (total / fromIntegral cnt, k)))- putStr ("Tested " ++ show nbnodes ++ " nodes. ")- unless (nbnodes == 0) $ do- putStrLn (formatDouble parserShare <> "% of total CPU time spent parsing, " <> formatDouble templateShare <> "% spent computing templates")- when (_loglevel <= LOG.INFO) $ do- putStrLn ("Slowest template: " <> T.unpack wTName <> ", taking " <> formatDouble wTMean <> "s on average")- putStrLn ("Slowest file to parse: " <> T.unpack wPName <> ", taking " <> formatDouble wPMean <> "s on average")- putStrLn ("Slowest catalog to compute: " <> T.unpack wCName <> ", taking " <> formatDouble wCMean <> "s on average")- return $ if testFailures > 0- then exitFailure- else exitSuccess- else do- r <- computeCatalogs False queryfunc pdbapi printFunc cmd node- return $ case snd r of- Just s -> if (H.summaryFailures s > 0)- then exitFailure- else exitSuccess- Nothing -> exitSuccess- when _commitDB $ void $ commitDB pdbapi- exit+ if failures > 0+ then do {putDoc ("Found" <+> red (int failures) <+> "failure(s)." <> line) ; exitFailure}+ else do {putDoc (dullgreen "All green." <> line) ; exitSuccess} -computeCatalogs :: Bool -> QueryFunc -> PuppetDBAPI IO -> (Doc -> IO ()) -> Options -> T.Text -> IO (Maybe (FinalCatalog, [Resource]), Maybe H.Summary)-computeCatalogs testOnly queryfunc pdbapi printFunc (Options {_showjson, _showContent, _resourceType, _resourceName, _puppetdir, _checkExport, _nousergrouptest}) node =+ where+ computeCatalog :: QueryFunc -> Nodename -> IO (Maybe (FinalCatalog, [Resource]))+ computeCatalog func node =+ func node >>= \case+ S.Left err -> putDoc ("Problem with" <+> ttext node <+> ":" <+> getError err </> mempty) >> 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 {_showjson, _showContent, _resourceType, _resourceName, _checkExport })+ queryfunc pdbapi node = queryfunc node >>= \case S.Left rr -> do- if testOnly- then putDoc ("Problem with" <+> ttext node <+> ":" <+> getError rr </> mempty)- else putDoc (getError rr) >> putStrLn "" >> error "error!"- return (Nothing, Just (H.Summary 1 1))- S.Right (rawcatalog, m, rawexported, knownRes) -> do- let cmpMatch Nothing _ curcat = return curcat- cmpMatch (Just rg) lns curcat = compile compBlank execBlank (T.unpack rg) >>= \case- Left rr -> error ("Error compiling regexp 're': " ++ show rr)- Right rec -> fmap HM.fromList $ filterM (filterResource lns rec) (HM.toList curcat)- filterResource lns rec v = execute rec (v ^. lns) >>= \case- Left rr -> error ("Error when applying regexp: " ++ show rr)- Right Nothing -> return False- _ -> return True- filterCatalog = cmpMatch _resourceType (_1 . itype . unpacked) >=> cmpMatch _resourceName (_1 . iname . unpacked)- catalog <- filterCatalog rawcatalog- exported <- filterCatalog rawexported- let wireCatalog = generateWireCatalog node (catalog <> exported ) m- rawWireCatalog = generateWireCatalog node (rawcatalog <> rawexported) m+ putDoc ("Problem with" <+> ttext node <+> ":" <+> getError rr </> mempty)+ exitFailure+ S.Right (rawcatalog, edgemap, rawexported, _) -> do+ printFunc <- hIsTerminalDevice stdout >>= \isterm -> return $ \x ->+ if isterm+ then putDoc x >> putStrLn ""+ else displayIO stdout (renderCompact x) >> putStrLn ""+ catalog <- filterCatalog _resourceType _resourceName rawcatalog+ exported <- filterCatalog _resourceType _resourceName rawexported+ let wireCatalog = generateWireCatalog node (catalog <> exported ) edgemap+ rawWireCatalog = generateWireCatalog node (rawcatalog <> rawexported) edgemap when _checkExport $ void $ replaceCatalog pdbapi rawWireCatalog- testResult <- case (testOnly, _showContent, _showjson) of- (True, _, _) -> Just `fmap` testCatalog node _puppetdir rawcatalog basicTest- (_, _, True) -> BSL.putStrLn (encode (prepareForPuppetApply wireCatalog)) >> return Nothing- (_, True, _) -> do- unless (_resourceType == Just "file" || _resourceType == Nothing) (error $ "Show content only works for file, not for " ++ show _resourceType)+ case (_showContent, _showjson) of+ (_, True) -> BSL.putStrLn (encode (prepareForPuppetApply wireCatalog))+ (True, _) -> do+ unless (_resourceType == Just "file" || isNothing _resourceType) $ do+ putDoc "Show content only works with resource of type file. It is an error to provide another filter type"+ exitFailure case _resourceName of Just f -> printContent f catalog- Nothing -> error "You should supply a resource name when using showcontent"- return Nothing- _ -> do- r <- testCatalog node _puppetdir rawcatalog (basicTest >> unless _nousergrouptest usersGroupsDefined)+ Nothing -> putDoc "You should supply a resource name when using showcontent" >> exitFailure+ _ -> do printFunc (pretty (HM.elems catalog)) unless (HM.null exported) $ do printFunc (mempty <+> dullyellow "Exported:" <+> mempty) printFunc (pretty (HM.elems exported))- return (Just r)- return (Just (rawcatalog <> rawexported, knownRes), testResult)+++-- | Filter according to the type and name regex from the command line option+filterCatalog :: Maybe T.Text -> Maybe T.Text -> FinalCatalog -> IO FinalCatalog+filterCatalog typeFilter nameFilter = filterC typeFilter (_1 . itype . unpacked) >=> filterC nameFilter (_1 . iname . unpacked)+ where+ -- filter catalog using the adhoc lens+ filterC Nothing _ c = return c+ filterC (Just regexp) l c = compile compBlank execBlank (T.unpack regexp) >>= \case+ Left rr -> error ("Error compiling regexp 're': " ++ show rr)+ Right reg -> HM.fromList <$> filterM (filterResource reg l) (HM.toList c)+ filterResource reg l v = execute reg (v ^. l) >>= \case+ Left rr -> error ("Error when applying regexp: " ++ show rr)+ Right Nothing -> return False+ _ -> return True+++run :: Options -> IO ()+-- | Parse mode+run (Options {_parse = Just fp}) = parseFile fp >>= \case+ Left rr -> error ("parse error:" ++ show rr)+ Right s -> putDoc $ ppStatements s++run (Options {_puppetdir = Nothing, _parse = Nothing }) =+ error "Without a puppet dir, only the `--parse` option can be supported"+run (Options {_puppetdir = Just _, _nodename = Nothing, _multnodes = Nothing}) =+ error "You need to choose between single or multiple node"++-- | Single node mode (`--node` option)+run cmd@(Options {_nodename = Just node, _commitDB, _puppetdir = Just workingdir}) = do+ (queryfunc, pdbapi, _, _, _ ) <- initializedaemonWithPuppet workingdir cmd+ computeNodeCatalog cmd queryfunc pdbapi node+ when _commitDB $ void $ commitDB pdbapi++-- | Multiple nodes mode (`--all`) option+run cmd@(Options {_nodename = Nothing , _multnodes = Just nodes, _puppetdir = Just workingdir}) = do+ -- it would be really noisy to run this mode with loglevel < LOG.ERROR;+ -- even the default LOG.WARNING would clutter the output.+ -- That's why we force LOG.ERROR for the puppet daemon.+ (queryfunc, _, mPStats,mCStats,mTStats) <- initializedaemonWithPuppet workingdir (cmd {_loglevel = LOG.ERROR})+ computeStats workingdir cmd queryfunc (mPStats, mCStats, mTStats) =<< retrieveNodes nodes++ where+ 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+ getNodeName _ = Nothing+ return $ mapMaybe getNodeName (V.toList allstmts)+ retrieveNodes (MultNodes xs) = return xs main :: IO () main = execParser opts >>= run
tests/expr.hs view
@@ -1,21 +1,28 @@ module Main where -import Puppet.Parser-import Puppet.Parser.PrettyPrinter()-import Puppet.Parser.Types-import Text.Parser.Combinators-import Control.Monad-import Data.Maybe-import qualified Data.Text as T-import Control.Applicative-import qualified Data.Vector as V-import Control.Arrow (first)+import Control.Applicative+import Control.Arrow (first)+import Control.Monad+import Data.Maybe+import qualified Data.Text as T+import Data.Tuple.Strict+import qualified Data.Vector as V+import Puppet.Parser+import Puppet.Parser.PrettyPrinter ()+import Puppet.Parser.Types+import Text.Parser.Combinators testcases :: [(T.Text, Expression)] testcases = [ ("5 + 3 * 2", 5 + 3 * 2) , ("5+2 == 7", Equal (5 + 2) 7) , ("include(foo::bar)", Terminal (UFunctionCall "include" (V.singleton "foo::bar") ))+ , ("$y ? {\+ \ undef => 'undef',\+ \ default => 'default',\+ \ }", ConditionalValue (Terminal (UVariableReference "y"))+ (V.fromList [SelectorValue (UString "undef") :!: Terminal (UString "undef")+ ,SelectorDefault :!: Terminal (UString "default")])) , ("$x", Terminal (UVariableReference "x")) , ("\"${x}\"", Terminal (UInterpolable (V.fromList [Terminal (UVariableReference "x")]))) , ("\"${x[3]}\"", Terminal (UInterpolable (V.fromList [Lookup (Terminal (UVariableReference "x")) 3])))
tests/hiera.hs view
@@ -5,8 +5,6 @@ import Hiera.Server import Data.Monoid import qualified Data.Either.Strict as S-import qualified Data.Maybe.Strict as S-import Data.Tuple.Strict import Test.HUnit import qualified Data.Vector as V import qualified Data.HashMap.Strict as HM@@ -31,26 +29,25 @@ , ("tom" , PHash (HM.singleton "uid" (PNumber 12))) ] Right q <- startHiera (tmpfp ++ "/hiera.yaml")- let checkOutput v (S.Right (_ :!: x)) = x @?= v+ let checkOutput v (S.Right x) = x @?= v checkOutput _ (S.Left rr) = assertFailure (show rr) hspec $ do describe "lookup data without a key" $ do- it "returns an error when called with an empty string" $ q mempty "" Priority >>= checkOutput S.Nothing+ it "returns an error when called with an empty string" $ q mempty "" Priority >>= checkOutput Nothing describe "lookup data with no options" $ do- it "can get string data" $ q mempty "http_port" Priority >>= checkOutput (S.Just (PNumber 8080))- it "can get arrays" $ q mempty "ntp_servers" Priority >>= checkOutput (S.Just (PArray (V.fromList ["0.ntp.puppetlabs.com","1.ntp.puppetlabs.com"])))- it "can get hashes" $ q mempty "users" Priority >>= checkOutput (S.Just (PHash users))+ it "can get string data" $ q mempty "http_port" Priority >>= checkOutput (Just (PNumber 8080))+ it "can get arrays" $ q mempty "ntp_servers" Priority >>= checkOutput (Just (PArray (V.fromList ["0.ntp.puppetlabs.com","1.ntp.puppetlabs.com"])))+ it "can get hashes" $ q mempty "users" Priority >>= checkOutput (Just (PHash users)) describe "lookup data with a scope" $ do- it "overrides some values" $ q vars "http_port" Priority >>= checkOutput (S.Just (PNumber 9090))- it "doesn't fail on others" $ q vars "global" Priority >>= checkOutput (S.Just "glob")+ it "overrides some values" $ q vars "http_port" Priority >>= checkOutput (Just (PNumber 9090))+ it "doesn't fail on others" $ q vars "global" Priority >>= checkOutput (Just "glob") describe "json backend" $ do- it "resolves in json" $ q vars "testjson" Priority >>= checkOutput (S.Just "ok")+ it "resolves in json" $ q vars "testjson" Priority >>= checkOutput (Just "ok") describe "deep interpolation" $ do- it "resolves in strings" $ q vars "interp1" Priority >>= checkOutput (S.Just (PString ("**" <> ndname <> "**")))- it "resolves in objects" $ q vars "testnode" Priority >>= checkOutput (S.Just (PHash (HM.fromList [("1",PString ("**" <> ndname <> "**")),("2",PString "nothing special")])))- it "resolves in arrays" $ q vars "arraytest" Priority >>= checkOutput (S.Just (PArray (V.fromList [PString "a", PString ndname, PString "c"])))+ it "resolves in strings" $ q vars "interp1" Priority >>= checkOutput (Just (PString ("**" <> ndname <> "**")))+ it "resolves in objects" $ q vars "testnode" Priority >>= checkOutput (Just (PHash (HM.fromList [("1",PString ("**" <> ndname <> "**")),("2",PString "nothing special")])))+ it "resolves in arrays" $ q vars "arraytest" Priority >>= checkOutput (Just (PArray (V.fromList [PString "a", PString ndname, PString "c"]))) describe "other merge modes" $ do- it "catenates arrays" $ q vars "ntp_servers" ArrayMerge >>= checkOutput (S.Just (PArray (V.fromList ["2.ntp.puppetlabs.com","3.ntp.puppetlabs.com","0.ntp.puppetlabs.com","1.ntp.puppetlabs.com"])))- it "puts single values in arrays" $ q vars "http_port" ArrayMerge >>= checkOutput (S.Just (PArray (V.fromList [PNumber 9090, PNumber 8080])))- it "merges hashes" $ q vars "users" HashMerge >>= checkOutput (S.Just (PHash (pusers <> users)))-+ it "catenates arrays" $ q vars "ntp_servers" ArrayMerge >>= checkOutput (Just (PArray (V.fromList ["2.ntp.puppetlabs.com","3.ntp.puppetlabs.com","0.ntp.puppetlabs.com","1.ntp.puppetlabs.com"])))+ it "puts single values in arrays" $ q vars "http_port" ArrayMerge >>= checkOutput (Just (PArray (V.fromList [PNumber 9090, PNumber 8080])))+ it "merges hashes" $ q vars "users" HashMerge >>= checkOutput (Just (PHash (pusers <> users)))