language-puppet 1.1.4 → 1.1.4.1
raw patch · 29 files changed
+452/−443 lines, 29 filesdep +bifunctorsdep +megaparsecdep +semigroupsdep ~basedep ~filecachedep ~parsec
Dependencies added: bifunctors, megaparsec, semigroups
Dependency ranges changed: base, filecache, parsec, parsers, pcre-utils, strict-base-types, time
Files
- CHANGELOG.markdown +21/−0
- Erb/Compute.hs +3/−3
- Facter.hs +6/−7
- Hiera/Server.hs +7/−6
- Puppet/Daemon.hs +63/−44
- Puppet/Interpreter.hs +62/−53
- Puppet/Interpreter/IO.hs +0/−2
- Puppet/Interpreter/Pure.hs +0/−2
- Puppet/Interpreter/Resolve.hs +6/−8
- Puppet/Interpreter/Types.hs +23/−25
- Puppet/Lens.hs +0/−15
- Puppet/NativeTypes/File.hs +23/−21
- Puppet/NativeTypes/Package.hs +2/−2
- Puppet/OptionalTests.hs +2/−5
- Puppet/Parser.hs +110/−105
- Puppet/Parser/Types.hs +6/−5
- Puppet/Plugins.hs +0/−2
- Puppet/Preferences.hs +19/−17
- Puppet/Puppetlabs.hs +6/−0
- Puppet/Stats.hs +2/−8
- PuppetDB/TestDB.hs +1/−3
- README.adoc +7/−4
- SafeProcess.hs +8/−16
- language-puppet.cabal +16/−13
- progs/PuppetResources.hs +46/−58
- ruby/hrubyerb.rb +1/−1
- tests/evals.hs +4/−7
- tests/expr.hs +2/−4
- tests/lexer.hs +6/−7
CHANGELOG.markdown view
@@ -1,3 +1,24 @@+# v1.1.4.1 (2015/11/15)++## New features+* Support for the new puppet `contain` function++## Bugs fixed+* Fix parser for search expression (see #132)+* Fix logger set up (see #136)+* Fix some regsubst (see #119)+* Fix the `template` and `inline_template` functions (see #142)+* Support lookups for expressions used in selector (TODO: arbitrary expression)+* Fix a ruby 1.8 syntax error+* Fix a case where resource overrides were not applied to the correct resource+* Fix a bug where a class value would be incorrectly inferred as having a default value whereas it doesn't++## Changes+* Replace `parsec` `megaparsec` (see #138)+* All resource names are normalized. The leading `::` is ignored (see #140)+* Add CI using travis+* Drop support for ghc < 7.10 explicitly+ # v1.1.4 (2015/09/07) ## New features
Erb/Compute.hs view
@@ -60,8 +60,8 @@ ExceptT (registerGlobalFunction4 intr "varlookup" hrresolveVariable) ExceptT (registerGlobalFunction5 intr "callextfunc" hrcallfunction) liftIO $ void $ forkIO $ templateDaemon intr- (T.pack (prefs^.puppetPaths.modulesPath))- (T.pack (prefs^.puppetPaths.templatesPath))+ (T.pack (prefs ^. prefPuppetPaths.modulesPath))+ (T.pack (prefs ^. prefPuppetPaths.templatesPath)) controlchan mvstats templatecache@@ -192,7 +192,7 @@ Right fname -> FR.toRuby fname Left _ -> FR.toRuby ("-" :: T.Text) let withBinding f = do- erbBinding <- FR.safeMethodCall "ErbBinding" "new" [rscp,rvariables,contentinfo,rstt, rrdr]+ erbBinding <- FR.safeMethodCall "ErbBinding" "new" [rscp,rvariables,rstt,rrdr,contentinfo] case erbBinding of Left x -> return (Left x) Right v -> do
Facter.hs view
@@ -167,29 +167,28 @@ modelnames = mapMaybe (fmap (dropWhile (`elem` ("\t :" :: String))) . stripPrefix "model name") (lines cpuinfo) return $ ("processorcount", show (length cpuinfos)) : cpuinfos -puppetDBFacts :: T.Text -> PuppetDBAPI IO -> IO (Container PValue)-puppetDBFacts ndename pdbapi =- runEitherT (getFacts pdbapi (QEqual FCertname ndename)) >>= \case+puppetDBFacts :: Nodename -> PuppetDBAPI IO -> IO (Container PValue)+puppetDBFacts node pdbapi =+ runEitherT (getFacts pdbapi (QEqual FCertname node)) >>= \case Right facts@(_:_) -> return (HM.fromList (map (\f -> (f ^. factname, f ^. factval)) facts)) _ -> do rawFacts <- fmap concat (sequence [factNET, factRAM, factOS, fversion, factMountPoints, factOS, factUser, factUName, fenv, factProcessor]) let ofacts = genFacts $ map (T.pack *** T.pack) rawFacts- (hostname, ddomainname) = T.break (== '.') ndename+ (hostname, ddomainname) = T.break (== '.') node domainname = if T.null ddomainname then "" else T.tail ddomainname- nfacts = genFacts [ ("fqdn", ndename)+ nfacts = genFacts [ ("fqdn", node) , ("hostname", hostname) , ("domain", domainname) , ("rootrsa", "xxx") , ("operatingsystem", "Ubuntu") , ("puppetversion", "language-puppet") , ("virtual", "xenu")- , ("clientcert", ndename)+ , ("clientcert", node) , ("is_virtual", "true") , ("concat_basedir", "/var/lib/puppet/concat") ] allfacts = nfacts `HM.union` ofacts genFacts = HM.fromList return (allfacts & traverse %~ PString)-
Hiera/Server.hs view
@@ -13,6 +13,7 @@ module Hiera.Server ( startHiera , dummyHiera+ , hieraLoggerName -- * Re-export (query API) , HieraQueryFunc ) where@@ -41,8 +42,8 @@ import Puppet.PP import Puppet.Utils (strictifyEither) -loggerName :: String-loggerName = "Hiera.Server"+hieraLoggerName :: String+hieraLoggerName = "Hiera.Server" data HieraConfigFile = HieraConfigFile { _backends :: [Backend]@@ -159,7 +160,7 @@ case resolveInterpolable vars strs of Just s -> queryCombinator qtype (map (query'' s) _backends) Nothing -> do- LOG.infoM loggerName (show $ "Hiera lookup: skipping using hierarchy level" <+> pretty strs+ LOG.infoM hieraLoggerName (show $ "Hiera lookup: skipping using hierarchy level" <+> pretty strs <$$> "It couldn't be interpolated with known variables:" <+> varlist) return Nothing query'' :: T.Text -> Backend -> IO (Maybe PValue)@@ -177,14 +178,14 @@ mfromJSON (Just v) = case A.fromJSON v of 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))+ LOG.warningM hieraLoggerName (show $ "Hiera:" <+> dullred "could not convert this Value to a Puppet type" <> ":" <+> string (show v)) return Nothing v <- liftIO (F.query cache filename (decodefunction filename)) case v of S.Left r -> do let errs = "Hiera: error when reading file " <> string filename <+> string r if "Yaml file not found: " `L.isInfixOf` r- then LOG.debugM loggerName (show errs)- else LOG.warningM loggerName (show errs)+ then LOG.debugM hieraLoggerName (show errs)+ else LOG.warningM hieraLoggerName (show errs) return Nothing S.Right x -> mfromJSON (x ^? key hquery)
Puppet/Daemon.hs view
@@ -1,30 +1,35 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-}-module Puppet.Daemon (initDaemon) where+module Puppet.Daemon (+ initDaemon+ , checkError+ -- * Re-exports+ , module Puppet.Interpreter.Types+ , module Puppet.PP+) where -import Control.Applicative import Control.Exception import Control.Exception.Lens-import Control.Lens+import qualified Control.Lens as L+import Control.Lens.Operators 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 Data.Traversable (for) import Data.Tuple.Strict import qualified Data.Vector as V-import Debug.Trace-import Erb.Compute+import Debug.Trace (traceEventIO) import Foreign.Ruby.Safe-import Prelude+import System.Exit (exitFailure) import System.IO (stdout)-import System.Log.Formatter as LOG-import System.Log.Handler as LOG-import System.Log.Handler.Simple as LOG+import qualified System.Log.Formatter as LOG (simpleLogFormatter)+import System.Log.Handler (setFormatter)+import qualified System.Log.Handler.Simple as LOG (streamHandler) import qualified System.Log.Logger as LOG +import Erb.Compute import Hiera.Server import Puppet.Interpreter import Puppet.Interpreter.IO@@ -68,7 +73,7 @@ -} initDaemon :: Preferences IO -> IO DaemonMethods initDaemon prefs = do- setupConsoleLogger+ setupLogger (prefs ^. prefLogLevel) logDebug "initDaemon" traceEventIO "initDaemon" templateStats <- newStats@@ -76,15 +81,28 @@ catalogStats <- newStats pfilecache <- newFileCache intr <- startRubyInterpreter- hquery <- case prefs ^. hieraPath of+ hquery <- case prefs ^. prefHieraPath of Just p -> either error id <$> startHiera p Nothing -> return dummyHiera- luacontainer <- initLuaMaster (T.pack (prefs ^. puppetPaths.modulesPath))+ luacontainer <- initLuaMaster (T.pack (prefs ^. prefPuppetPaths.modulesPath)) let myprefs = prefs & prefExtFuncs %~ HM.union luacontainer getStatements = parseFunction myprefs pfilecache parserStats getTemplate <- initTemplateDaemon intr myprefs templateStats return (DaemonMethods (gCatalog myprefs getStatements getTemplate catalogStats hquery) parserStats catalogStats templateStats) ++-- Public utils func to work with the daemon --++-- | In case of a Left value, print the error and exit immediately+checkError :: Show e => Doc -> Either e a -> IO a+checkError desc = either exit return+ where+ exit = \err -> putDoc (display err) >> exitFailure+ display err = red desc <> ": " <+> (string . show) err+++-- Some utils func internal to this module --+ gCatalog :: Preferences IO -> ( TopLevelType -> T.Text -> IO (S.Either PrettyError Statement) ) -> (Either T.Text T.Text -> InterpreterState -> InterpreterReader IO -> IO (S.Either PrettyError T.Text))@@ -93,34 +111,34 @@ -> 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)+gCatalog prefs getStatements getTemplate stats hquery node facts = do+ logDebug ("Received query for node " <> node)+ traceEventIO ("START gCatalog " <> T.unpack node) let catalogComputation = getCatalog (InterpreterReader- (prefs ^. natTypes)+ (prefs ^. prefNatTypes) getStatements getTemplate (prefs ^. prefPDB) (prefs ^. prefExtFuncs)- ndename+ node hquery defaultImpureMethods- (prefs ^. ignoredmodules)- (prefs ^. externalmodules)- (prefs ^. strictness == Strict)- (prefs ^. puppetPaths)+ (prefs ^. prefIgnoredmodules)+ (prefs ^. prefExternalmodules)+ (prefs ^. prefStrictness == Strict)+ (prefs ^. prefPuppetPaths) )- ndename+ node facts- (prefs^.puppetSettings)- (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)- if prefs ^. extraTests+ (prefs ^. prefPuppetSettings)+ (stmts :!: warnings) <- measure stats node catalogComputation+ mapM_ (\(p :!: m) -> LOG.logM daemonLoggerName p (displayS (renderCompact (ttext node <> ":" <+> m)) "")) warnings+ traceEventIO ("STOP gCatalog " <> T.unpack node)+ if prefs ^. prefExtraTests then runOptionalTests stmts else return stmts where- runOptionalTests stm = case stm^?S._Right._1 of+ runOptionalTests stm = case stm^?S._Right.L._1 of Nothing -> return stm (Just c) -> catching _PrettyError (do {testCatalog prefs c; return stm})@@ -142,38 +160,39 @@ -- 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 ^. puppetPaths.manifestPath) <> "/site.pp")+compileFileList prefs TopNode _ = S.Right (T.pack (prefs ^. prefPuppetPaths.manifestPath) <> "/site.pp") compileFileList prefs _ name = moduleInfo where moduleInfo | length nameparts == 1 = S.Right (mpath <> "/" <> name <> "/manifests/init.pp") | null nameparts = S.Left "no name parts, error in compilefilelist" | otherwise = S.Right (mpath <> "/" <> head nameparts <> "/manifests/" <> T.intercalate "/" (tail nameparts) <> ".pp")- mpath = T.pack (prefs ^. puppetPaths.modulesPath)+ mpath = T.pack (prefs ^. prefPuppetPaths.modulesPath) nameparts = T.splitOn "::" name parseFile :: FilePath -> IO (S.Either String (V.Vector Statement)) parseFile fname = do traceEventIO ("START parsing " ++ fname) cnt <- T.readFile fname- o <- case runPParser puppetParser fname cnt of+ o <- case runPParser fname cnt of Right r -> traceEventIO ("Stopped parsing " ++ fname) >> return (S.Right r) 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"+daemonLoggerName :: String+daemonLoggerName = "Puppet.Daemon" logDebug :: T.Text -> IO ()-logDebug = LOG.debugM loggerName . T.unpack+logDebug = LOG.debugM daemonLoggerName . T.unpack -setupConsoleLogger :: IO ()-setupConsoleLogger = do- hs <- for [LOG.DEBUG, LOG.INFO, LOG.NOTICE, LOG.WARNING] consoleLogHandler- LOG.updateGlobalLogger LOG.rootLoggerName $ LOG.setHandlers hs- where- consoleLogHandler p = LOG.setFormatter- <$> LOG.streamHandler stdout p- <*> pure (LOG.simpleLogFormatter "$prio: $msg")+setupLogger :: LOG.Priority -> IO ()+setupLogger p = do+ LOG.updateGlobalLogger daemonLoggerName (LOG.setLevel p)+ LOG.updateGlobalLogger hieraLoggerName (LOG.setLevel p)+ hs <- consoleLogHandler+ LOG.updateGlobalLogger LOG.rootLoggerName $ LOG.setHandlers [hs]+ where+ consoleLogHandler = setFormatter+ <$> LOG.streamHandler stdout LOG.DEBUG+ <*> pure (LOG.simpleLogFormatter "$prio: $msg")
Puppet/Interpreter.hs view
@@ -14,36 +14,39 @@ import Puppet.Parser.PrettyPrinter import Puppet.Parser.Types import Puppet.PP+import Puppet.Utils import Control.Applicative import Control.Lens import Control.Monad.Except import Control.Monad.Operational hiding (view)+import Control.Monad.Trans.Except import qualified Data.Either.Strict as S-import Data.Foldable (Foldable, foldl', foldlM,- toList)+import Data.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 Data.Semigroup (Max(..)) import qualified Data.Text as T-import Data.Traversable (mapM, for)+import Data.Traversable (for) import qualified Data.Tree as T import Data.Tuple.Strict (Pair (..))-import qualified Data.Tuple.Strict as S import qualified Data.Vector as V-import Puppet.Utils import System.Log.Logger-import Prelude hiding (mapM) -- helpers vmapM :: (Monad m, Foldable t) => (a -> m b) -> t a -> m [b] vmapM f = mapM f . toList +normalizeRIdentifier :: T.Text -> T.Text -> RIdentifier+normalizeRIdentifier t = RIdentifier rt+ where+ rt = fromMaybe t (T.stripPrefix "::" t)+ getModulename :: RIdentifier -> T.Text getModulename (RIdentifier t n) = let gm x = case T.splitOn "::" x of@@ -90,7 +93,7 @@ let getOver = use (scopes . ix scp . scopeOverrides) -- retrieves current overrides addDefaults r = ifoldlM (addAttribute CantReplace) r thisresdefaults where thisresdefaults = defs ^. ix (r ^. rid . itype) . defValues- addOverrides r = getOver >>= foldlM addOverrides' r+ addOverrides r = getOver >>= foldlM addOverrides' r . view (at (r ^. rid)) addOverrides' r (ResRefOverride _ prms p) = do -- we used this override, so we discard it scopes . ix scp . scopeOverrides . at (r ^. rid) .= Nothing@@ -245,7 +248,7 @@ let checkExists r msg = do let modulename = getModulename r ign <- singleton (IsIgnoredModule modulename)- unless ((defs & has (ix r)) || ign) (throwPosError msg)+ unless (has (ix r) defs || ign) (throwPosError msg) errmsg = "Unknown resource" <+> pretty ri <+> "used in the following relationships:" <+> vcat (map pretty lifs) checkExists ri errmsg let genlnk :: LinkInformation -> InterpreterMonad RIdentifier@@ -380,7 +383,7 @@ curPos .= p rn1 <- map (fixResourceName t1) <$> resolveExpressionStrings n1 rn2 <- map (fixResourceName t2) <$> resolveExpressionStrings n2- extraRelations <>= [ LinkInformation (RIdentifier t1 an1) (RIdentifier t2 an2) lt p | an1 <- rn1, an2 <- rn2 ]+ extraRelations <>= [ LinkInformation (normalizeRIdentifier t1 an1) (normalizeRIdentifier t2 an2) lt p | an1 <- rn1, an2 <- rn2 ] return [] evaluateStatement (ResourceDeclaration (ResDec rt ern eargs virt p)) = do curPos .= p@@ -427,7 +430,7 @@ rn <- resolveExpressionString urn scp <- getScopeName curoverrides <- use (scopes . ix scp . scopeOverrides)- let rident = RIdentifier rt rn+ let rident = normalizeRIdentifier rt rn -- check that we didn't already override those values withAssignements <- case curoverrides ^. at rident of Just (ResRefOverride _ prevass prevpos) -> do@@ -476,44 +479,44 @@ -- only) or default values. loadParameters :: Foldable f => Container PValue -> f (Pair T.Text (S.Maybe Expression)) -> PPosition -> S.Maybe T.Text -> InterpreterMonad () loadParameters params classParams defaultPos wHiera = do- params' <- case wHiera of- S.Just classname -> do- -- pass 1 : with classes, we retrieve the parameters that have no default values and- -- that are not set, to try to get them with Hiera- let !classParamSet = HS.fromList (S.fst <$> classParams ^.. folded)- !definedParamSet = ikeys params- !unsetParams = classParamSet `HS.difference` definedParamSet- loadHieraParam curprms paramname = do- v <- runHiera (classname <> "::" <> paramname) Priority- case v of- 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- 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)- -- 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' )+ p <- use curPos curPos .= defaultPos- forM_ defaultPairs $ \(k :!: v) -> do- rv <- case v of- S.Nothing -> throwPosError "Internal error: invalid invariant at loadParameters"- S.Just e -> resolveExpression e- loadVariable k rv+ let classParamSet = HS.fromList (classParams ^.. folded . _1)+ spuriousParams = ikeys params `HS.difference` classParamSet+ mclassdesc = S.maybe mempty ((\x -> mempty <+> "when including class" <+> x) . ttext) wHiera + -- the following functions `throwE (Max False)` when there is no value, and `throwE (Max True)` when this value+ -- in PUndef.+ checkUndef :: Maybe PValue -> ExceptT (Max Bool) InterpreterMonad PValue+ checkUndef Nothing = throwE (Max False)+ checkUndef (Just PUndef) = throwE (Max True)+ checkUndef (Just v) = return v++ checkHiera :: T.Text -> ExceptT (Max Bool) InterpreterMonad PValue+ checkHiera k = case wHiera of+ S.Nothing -> throwE (Max False)+ S.Just classname -> lift (runHiera (classname <> "::" <> k) Priority) >>= checkUndef++ checkDef :: T.Text -> ExceptT (Max Bool) InterpreterMonad PValue+ checkDef k = checkUndef (params ^. at k)++ checkDefault :: S.Maybe Expression -> ExceptT (Max Bool) InterpreterMonad PValue+ checkDefault S.Nothing = throwE (Max False)+ checkDefault (S.Just expr) = lift (resolveExpression expr)++ unless (fnull spuriousParams) $ throwPosError ("The following parameters are unknown:" <+> tupled (map (dullyellow . ttext) $ toList spuriousParams) <> mclassdesc)++ -- try to set a value to all parameters+ -- The order of evaluation is defined / hiera / default+ unsetParams <- fmap concat $ for (toList classParams) $ \(k :!: defValue) -> do+ ev <- runExceptT (checkDef k <|> checkHiera k <|> checkDefault defValue)+ case ev of+ Right v -> loadVariable k v >> return []+ Left (Max True) -> loadVariable k PUndef >> return []+ Left (Max False) -> return [k]+ curPos .= p+ unless (fnull unsetParams) $ throwPosError ("The following mandatory parameters were not set:" <+> tupled (map ttext $ toList unsetParams) <> mclassdesc)+ data ScopeEnteringContext = SENormal | SEChild !T.Text -- ^ We enter the scope as the child of another class | SEParent !T.Text -- ^ We enter the scope as the parent of another class@@ -670,7 +673,7 @@ addRelationship :: LinkType -> PValue -> Resource -> InterpreterMonad Resource addRelationship lt (PResourceReference dt dn) r = return (r & rrelations %~ insertLt) where- insertLt = iinsertWith (<>) (RIdentifier dt dn) (HS.singleton lt)+ insertLt = iinsertWith (<>) (normalizeRIdentifier dt dn) (HS.singleton lt) addRelationship lt (PArray vals) r = foldlM (flip (addRelationship lt)) r vals addRelationship _ PUndef r = return r addRelationship _ notrr _ = throwPosError ("Expected a resource reference, not:" <+> pretty notrr)@@ -705,7 +708,7 @@ -- We will not bark if the same attribute -- is defined multiple times with distinct -- values.- let errmsg = "Attribute" <+> dullmagenta (ttext t) <+> "defined multiple times for" <+> pretty (r ^. rid) <+> showPPos (r ^. rpos)+ let errmsg = "Attribute" <+> dullmagenta (ttext t) <+> "defined multiple times for" <+> pretty r if curval == v then checkStrict errmsg errmsg else throwPosError errmsg@@ -724,16 +727,16 @@ allsegs x = x : T.splitOn "::" x (!classtags, !defaultLink) = getClassTags cnt getClassTags (ContClass cn ) = (allsegs cn,RIdentifier "class" cn)- getClassTags (ContDefine dt dn _) = (allsegs dt,RIdentifier dt dn)+ getClassTags (ContDefine dt dn _) = (allsegs dt,normalizeRIdentifier dt dn) getClassTags (ContRoot ) = ([],RIdentifier "class" "::") getClassTags (ContImported _ ) = ([],RIdentifier "class" "::") getClassTags (ContImport _ _ ) = ([],RIdentifier "class" "::") defaultRelation = HM.singleton defaultLink (HS.singleton RRequire) allScope <- use curScope fqdn <- singleton GetNodeName- let baseresource = Resource (RIdentifier rt rn) (HS.singleton rn) mempty defaultRelation allScope vrt defaulttags p fqdn+ let baseresource = Resource (normalizeRIdentifier rt rn) (HS.singleton rn) mempty defaultRelation allScope vrt defaulttags p fqdn r <- ifoldlM (addAttribute CantOverride) baseresource arg- let resid = RIdentifier rt rn+ let resid = normalizeRIdentifier rt rn case rt of "class" -> {-# SCC "rrClass" #-} do definedResources . at resid ?= r@@ -773,6 +776,12 @@ mainFunctionCall "info" a = logWithModifier INFO green a mainFunctionCall "notice" a = logWithModifier NOTICE white a mainFunctionCall "warning" a = logWithModifier WARNING dullyellow a+mainFunctionCall "contain" includes = concat <$> mapM doContain includes+ where doContain e = do+ classname <- resolvePValueString e+ use (loadedClasses . at classname) >>= \case+ Nothing -> loadClass classname S.Nothing mempty IncludeStandard+ Just _ -> return [] -- TODO check that this happened after class declaration mainFunctionCall "include" includes = concat <$> mapM doInclude includes where doInclude e = do classname <- resolvePValueString e@@ -850,7 +859,7 @@ ensureResource' :: T.Text -> HM.HashMap T.Text PValue -> T.Text -> InterpreterMonad [Resource] ensureResource' tp params ttl = do- def <- has (ix (RIdentifier tp ttl)) <$> use definedResources+ def <- has (ix (normalizeRIdentifier tp ttl)) <$> use definedResources if def then return [] else use curPos >>= registerResource tp ttl params Normal
Puppet/Interpreter/IO.hs view
@@ -15,7 +15,6 @@ import Puppet.Plugins () import Puppet.PP -import Control.Applicative import Control.Concurrent.MVar import Control.Exception import Control.Lens@@ -29,7 +28,6 @@ import Debug.Trace (traceEventIO) import GHC.Stack import qualified Scripting.Lua as Lua-import Prelude defaultImpureMethods :: (Functor m, MonadIO m) => ImpureMethods m defaultImpureMethods = ImpureMethods (liftIO currentCallStack)
Puppet/Interpreter/Pure.hs view
@@ -20,9 +20,7 @@ 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-import Prelude -- | Worst name ever, this is a set of pure stub for the 'ImpureMethods' -- type.
Puppet/Interpreter/Resolve.hs view
@@ -37,7 +37,6 @@ import Puppet.PP import Puppet.Utils -import Control.Applicative import Control.Lens import Control.Monad import Control.Monad.Operational (singleton)@@ -63,7 +62,6 @@ import Text.ParserCombinators.ReadP (readP_to_S) import qualified Text.PrettyPrint.ANSI.Leijen as PP import Text.Regex.PCRE.ByteString.Utils-import Prelude sha1 :: ByteString -> ByteString sha1 = convert . (hash :: ByteString -> Digest SHA1)@@ -425,8 +423,8 @@ else fmap PBoolean (isNativeType t) resolveFunction' "defined" x = throwPosError ("defined(): expects a single resource reference, type or class name, and not" <+> pretty x) resolveFunction' "fail" x = throwPosError ("fail:" <+> pretty x)-resolveFunction' "inline_template" [templatename] = calcTemplate Left templatename-resolveFunction' "inline_template" _ = throwPosError "inline_template(): Expects a single argument"+resolveFunction' "inline_template" [] = throwPosError "inline_template(): Expects at least one argument"+resolveFunction' "inline_template" templates = PString . mconcat <$> mapM (calcTemplate Left) templates resolveFunction' "md5" [pstr] = fmap (PString . T.decodeUtf8 . B16.encode . md5 . T.encodeUtf8) (resolvePValueString pstr) resolveFunction' "md5" _ = throwPosError "md5(): Expects a single argument" resolveFunction' "regsubst" [ptarget, pregexp, preplacement] = resolveFunction' "regsubst" [ptarget, pregexp, preplacement, PString "G"]@@ -469,8 +467,8 @@ scp <- getScopeName scpset <- use (scopes . ix scp . scopeExtraTags) return (PBoolean (scpset `HS.intersection` tags == tags))-resolveFunction' "template" [templatename] = calcTemplate Right templatename-resolveFunction' "template" _ = throwPosError "template(): Expects a single argument"+resolveFunction' "template" [] = throwPosError "template(): Expects at least one argument"+resolveFunction' "template" templates = PString . mconcat <$> mapM (calcTemplate Right) templates resolveFunction' "versioncmp" [pa,pb] = do a <- resolvePValueString pa b <- resolvePValueString pb@@ -519,11 +517,11 @@ Nothing -> return (PArray rv) (Just k) -> fmap PArray (V.mapM (extractSubHash k) rv) -calcTemplate :: (T.Text -> Either T.Text T.Text) -> PValue -> InterpreterMonad PValue+calcTemplate :: (T.Text -> Either T.Text T.Text) -> PValue -> InterpreterMonad T.Text calcTemplate templatetype templatename = do fname <- resolvePValueString templatename stt <- use id- PString `fmap` singleton (ComputeTemplate (templatetype fname) stt)+ singleton (ComputeTemplate (templatetype fname) stt) resolveExpressionSE :: Expression -> InterpreterMonad PValue resolveExpressionSE e = resolveExpression e >>=
Puppet/Interpreter/Types.hs view
@@ -105,48 +105,46 @@ , eitherDocIO ) where -import Control.Applicative hiding (empty)-import Control.Concurrent.MVar (MVar)+import Control.Concurrent.MVar (MVar) import Control.Exception-import Control.Lens+import Control.Lens hiding (Strict) import Control.Monad.Except import Control.Monad.Operational import Control.Monad.State.Strict import Control.Monad.Trans.Either 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 Data.Attoparsec.Text (parseOnly, rational)+import qualified Data.ByteString as BS+import qualified Data.Either.Strict as S+import qualified Data.Foldable as F import Data.Hashable-import qualified Data.HashMap.Strict as HM-import qualified Data.HashSet as HS-import Data.Maybe (fromMaybe)-import qualified Data.Maybe.Strict as S-import Data.Monoid 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 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.Helpers-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 Servant.Common.Text-import qualified System.Log.Logger as LOG-import Text.Parsec.Pos-import Text.PrettyPrint.ANSI.Leijen hiding (rational, (<$>))-import Prelude+import qualified System.Log.Logger as LOG+import Text.Megaparsec.Pos -import Puppet.Pathes import Puppet.Parser.PrettyPrinter import Puppet.Parser.Types+import Puppet.Pathes+import Puppet.PP hiding (rational) import Puppet.Stats metaparameters :: HS.HashSet T.Text
Puppet/Lens.hs view
@@ -12,7 +12,6 @@ , _PUndef , _PArray -- * Parsing prism- , _PParse -- * Lenses and Prisms for 'Statement's , _ResourceDeclaration , _DefaultDeclaration@@ -71,24 +70,18 @@ ) where import Control.Lens-import Control.Applicative -import Puppet.PP (displayNocolor) import Puppet.Parser.Types import Puppet.Interpreter.Types import Puppet.Interpreter.Pure import Puppet.Interpreter.Resolve-import Puppet.Parser-import Puppet.Parser.PrettyPrinter (ppStatements) import qualified Data.Vector as V import qualified Data.HashMap.Strict as HM import qualified Data.Text as T import qualified Data.Maybe.Strict as S import Data.Tuple.Strict hiding (uncurry)-import Text.Parser.Combinators (eof) import Control.Exception (SomeException, toException, fromException)-import Prelude -- Prisms makePrisms ''PValue@@ -212,14 +205,6 @@ toU (PResourceReference t n) = UResourceReference t (Terminal (UString n)) toU (PArray r) = UArray (fmap (Terminal . toU) r) toU (PHash h) = UHash (V.fromList $ map (\(k,v) -> (Terminal (UString k) :!: Terminal (toU v))) $ HM.toList h)--_PParse :: Prism' T.Text (V.Vector Statement)-_PParse = prism dspl prs- where- prs i = case runPParser (puppetParser <* eof) "dummy" i of- Left _ -> Left i- Right x -> Right x- dspl = T.pack . displayNocolor . ppStatements -- | Extracts the statements from 'ClassDeclaration', 'DefineDeclaration', -- 'Node' and the spurious statements of 'TopContainer'.
Puppet/NativeTypes/File.hs view
@@ -22,27 +22,29 @@ parameterfunctions :: [(T.Text, [T.Text -> NativeTypeValidate])] parameterfunctions =- [("backup" , [string])- ,("checksum" , [values ["md5", "md5lite", "mtime", "ctime", "none"]])- ,("content" , [string])- --,("ensure" , [defaultvalue "present", string, values ["directory","file","present","absent","link"]])- ,("ensure" , [defaultvalue "present", string])- ,("force" , [string, values ["true","false"]])- ,("group" , [defaultvalue "root", string])- ,("ignore" , [strings])- ,("links" , [string])- ,("mode" , [defaultvalue "0644", string])- ,("owner" , [string])- ,("path" , [nameval, fullyQualified, noTrailingSlash])- ,("provider" , [values ["posix","windows"]])- ,("purge" , [string, values ["true","false"]])- ,("recurse" , [string, values ["inf","true","false","remote"]])- ,("recurselimit", [integer])- ,("replace" , [string, values ["true","false"]])- ,("sourceselect", [values ["first","all"]])- ,("target" , [string])- ,("source" , [rarray, strings, flip runarray checkSource])- ,("seluser" , [string])+ [("backup" , [string])+ ,("checksum" , [values ["md5", "md5lite", "mtime", "ctime", "none"]])+ ,("content" , [string])+ --,("ensure" , [defaultvalue "present", string, values ["directory","file","present","absent","link"]])+ ,("ensure" , [defaultvalue "present", string])+ ,("force" , [string, values ["true","false"]])+ ,("group" , [defaultvalue "root", string])+ ,("ignore" , [strings])+ ,("links" , [string])+ ,("mode" , [defaultvalue "0644", string])+ ,("owner" , [string])+ ,("path" , [nameval, fullyQualified, noTrailingSlash])+ ,("provider" , [values ["posix","windows"]])+ ,("purge" , [string, values ["true","false"]])+ ,("recurse" , [string, values ["inf","true","false","remote"]])+ ,("recurselimit " , [integer])+ ,("replace" , [string, values ["true","false"]])+ ,("sourceselect " , [values ["first","all"]])+ ,("target" , [string])+ ,("source" , [rarray, strings, flip runarray checkSource])+ ,("seluser" , [string])+ ,("validate_cmd" , [string])+ ,("validate_replacement" , [string]) ] validateMode :: NativeTypeValidate
Puppet/NativeTypes/Package.hs view
@@ -98,12 +98,12 @@ checkAdminFile = Right -- TODO, check that it only works for aix checkEnsure :: (HS.HashSet PackagingFeatures, Resource) -> Either PrettyError (HS.HashSet PackagingFeatures, Resource) checkEnsure (s, res) = case res ^. rattributes . at "ensure" of- Just (PString "latest") -> checkFeature s res Installable >> checkFeature s res Versionable+ Just (PString "latest") -> checkFeature s res Installable Just (PString "purged") -> checkFeature s res Purgeable Just (PString "absent") -> checkFeature s res Uninstallable Just (PString "installed") -> checkFeature s res Installable Just (PString "present") -> checkFeature s res Installable Just (PString "held") -> checkFeature s res Installable >> checkFeature s res Holdable- _ -> Right (s, res)+ _ -> checkFeature s res Versionable decap :: (HS.HashSet PackagingFeatures, Resource) -> Either PrettyError Resource decap = Right . snd
Puppet/OptionalTests.hs view
@@ -3,19 +3,16 @@ -- These exceptions can be caught (see the exceptions package). module Puppet.OptionalTests (testCatalog) where -import Control.Applicative import Control.Lens import Control.Monad (unless) import Control.Monad.Catch import Control.Monad.Trans (liftIO) import Control.Monad.Trans.Except-import Data.Foldable (asum, elem, toList,- traverse_)+import Data.Foldable (asum, toList, traverse_) import qualified Data.HashSet as HS 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@@ -27,7 +24,7 @@ -- | Entry point for all optional tests testCatalog :: Preferences IO -> FinalCatalog -> IO ()-testCatalog prefs c = testFileSources (prefs^.puppetPaths.baseDir) c >> testUsersGroups (prefs^.knownusers) (prefs^.knowngroups) c+testCatalog prefs c = testFileSources (prefs ^. prefPuppetPaths.baseDir) c >> testUsersGroups (prefs ^. prefKnownusers) (prefs ^. prefKnowngroups) c -- | Tests that all users and groups are defined testUsersGroups :: [T.Text] -> [T.Text] -> FinalCatalog -> IO ()
Puppet/Parser.hs view
@@ -1,6 +1,3 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TupleSections #-} {-| Parse puppet source code from text. -} module Puppet.Parser (@@ -14,7 +11,6 @@ import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Vector as V-import qualified Data.HashSet as HS import qualified Data.Maybe.Strict as S import qualified Data.Foldable as F import Data.Tuple.Strict hiding (fst,zip)@@ -29,33 +25,69 @@ import Puppet.Utils import Data.Scientific-import Text.Parsec.Error (ParseError)-import Text.Parsec.Expr-import Text.Parsec.Pos (SourcePos,SourceName)-import qualified Text.Parsec.Prim as PP-import Text.Parsec.Text ()-import Text.Parser.Char-import Text.Parser.Combinators-import Text.Parser.LookAhead-import Text.Parser.Token hiding (stringLiteral')-import Text.Parser.Token.Highlight +import Text.Megaparsec hiding (token)+import Text.Megaparsec.Expr+import Text.Megaparsec.Text+import qualified Text.Megaparsec.Lexer as L+ -- | Run a puppet parser against some 'T.Text' input.-runPParser :: Parser a -> SourceName -> T.Text -> Either ParseError a-runPParser (ParserT p) = PP.parse p+runPParser :: String -> T.Text -> Either ParseError (V.Vector Statement)+runPParser = parse puppetParser +someSpace :: Parser ()+someSpace = L.space (skipSome spaceChar) (L.skipLineComment "#") (L.skipBlockComment "/*" "*/")++token :: Parser a -> Parser a+token = L.lexeme someSpace++integerOrDouble :: Parser (Either Integer Double)+integerOrDouble = fmap Right (try (L.signed someSpace L.float)) <|> fmap Left (hex <|> dec)+ where+ dec = L.signed someSpace L.integer+ hex = try (string "0x") *> L.hexadecimal+++symbol :: String -> Parser ()+symbol = void . try . L.symbol someSpace++symbolic :: Char -> Parser ()+symbolic = symbol . pure++braces :: Parser a -> Parser a+braces = between (symbol "{") (symbol "}")++parens :: Parser a -> Parser a+parens = between (symbol "(") (symbol ")")++brackets :: Parser a -> Parser a+brackets = between (symbol "[") (symbol "]")++comma :: Parser ()+comma = symbol ","++sepComma :: Parser a -> Parser [a]+sepComma p = p `sepEndBy` comma++sepComma1 :: Parser a -> Parser [a]+sepComma1 p = p `sepEndBy1` comma+ -- | Parse a collection of puppet 'Statement'. puppetParser :: Parser (V.Vector Statement)-puppetParser = someSpace >> statementList+puppetParser = optional someSpace >> statementList -- | Parse a puppet 'Expression'. expression :: Parser Expression expression = condExpression- <|> ParserT (buildExpressionParser expressionTable (unParser (token terminal)))+ <|> makeExprParser (token terminal) expressionTable <?> "expression" where condExpression = do- selectedExpression <- try (token terminal <* symbolic '?')+ selectedExpression <- try $ do+ trm <- token terminal+ lookups <- optional indexLookupChain+ symbolic '?'+ return $ maybe trm ($ trm) lookups let cas = do c <- (SelectorDefault <$ symbol "default") -- default case <|> fmap SelectorValue (fmap UVariableReference variableReference@@ -67,32 +99,9 @@ void $ symbol "=>" e <- expression return (c :!: e)- cases <- braces (cas `sepEndBy1` comma)+ cases <- braces (sepComma1 cas) return (ConditionalValue selectedExpression (V.fromList cases)) -newtype Parser a = ParserT { unParser :: PP.ParsecT T.Text () Identity a}- deriving (Functor, Applicative, Alternative)--deriving instance Monad Parser-deriving instance Parsing Parser-deriving instance CharParsing Parser-deriving instance LookAheadParsing Parser--getPosition :: Parser SourcePos-getPosition = ParserT PP.getPosition--type OP = PP.ParsecT T.Text () Identity--instance TokenParsing Parser where- someSpace = skipMany (simpleSpace <|> oneLineComment <|> multiLineComment)- where- simpleSpace = skipSome (satisfy isSpace)- oneLineComment = char '#' >> void (manyTill anyChar newline)- multiLineComment = try (string "/*") >> inComment- inComment = void (try (string "*/"))- <|> (skipSome (noneOf "*/") >> inComment)- <|> (oneOf "*/" >> inComment)- variable :: Parser Expression variable = Terminal . UVariableReference <$> variableReference @@ -103,11 +112,12 @@ escape '\'' = "'" escape x = ['\\',x] -identifierStyle :: IdentifierStyle Parser-identifierStyle = IdentifierStyle "Identifier" (satisfy acceptable) (satisfy acceptable) HS.empty Identifier ReservedIdentifier- where- acceptable x = isAsciiLower x || isAsciiUpper x || isDigit x || (x == '_')+identifier :: Parser String+identifier = some (satisfy identifierPart) +identifierPart :: Char -> Bool+identifierPart x = isAsciiLower x || isAsciiUpper x || isDigit x || (x == '_')+ identl :: Parser Char -> Parser Char -> Parser T.Text identl fstl nxtl = do f <- fstl@@ -115,10 +125,13 @@ return $ T.pack $ f : nxt operator :: String -> Parser ()-operator = void . highlight Operator . try . symbol+operator = void . try . symbol reserved :: String -> Parser ()-reserved = reserve identifierStyle+reserved s = try $ do+ void (string s)+ notFollowedBy (satisfy identifierPart)+ someSpace variableName :: Parser T.Text variableName = do@@ -164,11 +177,7 @@ parameterName = moduleName variableReference :: Parser T.Text-variableReference = do- void (char '$')- v <- variableName- when (v == "string") (fail "The special variable $string must not be used")- return v+variableReference = char '$' *> variableName interpolableString :: Parser (V.Vector Expression) interpolableString = V.fromList <$> between (char '"') (symbolic '"')@@ -211,10 +220,10 @@ <* symbolic '/' puppetArray :: Parser UValue-puppetArray = fmap (UArray . V.fromList) (brackets (expression `sepEndBy` comma)) <?> "Array"+puppetArray = fmap (UArray . V.fromList) (brackets (sepComma expression)) <?> "Array" puppetHash :: Parser UValue-puppetHash = fmap (UHash . V.fromList) (braces (hashPart `sepEndBy` comma)) <?> "Hash"+puppetHash = fmap (UHash . V.fromList) (braces (sepComma hashPart)) <?> "Hash" where hashPart = (:!:) <$> (expression <* operator "=>") <*> expression@@ -251,7 +260,7 @@ -- include foo::bar let argsc sep e = (fmap (Terminal . UString) (qualif1 className) <|> e <?> "Function argument A") `sep` comma terminalF = terminalG (fail "function hack")- expressionF = ParserT (buildExpressionParser expressionTable (unParser (token terminalF)) <?> "function expression")+ expressionF = makeExprParser (token terminalF) expressionTable <?> "function expression" withparens = parens (argsc sepEndBy expression) withoutparens = argsc sepEndBy1 expressionF args <- withparens <|> if nonparens@@ -296,45 +305,41 @@ terminal :: Parser Expression terminal = terminalG (fmap Terminal (fmap UHFunctionCall (try hfunctionCall) <|> try functionCall)) ---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 ) ]- , [ Prefix ( operator' "!" >> return Not ) ]- , [ Infix ( operator' "." >> return FunctionApplication ) AssocLeft ]- , [ Infix ( reserved' "in" >> return Contains ) AssocLeft ]- , [ Infix ( operator' "/" >> return Division ) AssocLeft- , Infix ( operator' "*" >> return Multiplication ) AssocLeft+expressionTable :: [[Operator Parser Expression]]+expressionTable = [ [ Postfix indexLookupChain ] -- http://stackoverflow.com/questions/10475337/parsec-expr-repeated-prefix-postfix-operator-not-supported+ , [ Prefix ( operator "-" >> return Negate ) ]+ , [ Prefix ( operator "!" >> return Not ) ]+ , [ InfixL ( operator "." >> return FunctionApplication ) ]+ , [ InfixL ( reserved "in" >> return Contains ) ]+ , [ InfixL ( operator "/" >> return Division )+ , InfixL ( operator "*" >> return Multiplication ) ]- , [ Infix ( operator' "+" >> return Addition ) AssocLeft- , Infix ( operator' "-" >> return Substraction ) AssocLeft+ , [ InfixL ( operator "+" >> return Addition )+ , InfixL ( operator "-" >> return Substraction ) ]- , [ Infix ( operator' "<<" >> return LeftShift ) AssocLeft- , Infix ( operator' ">>" >> return RightShift ) AssocLeft+ , [ InfixL ( operator "<<" >> return LeftShift )+ , InfixL ( operator ">>" >> return RightShift ) ]- , [ Infix ( operator' "==" >> return Equal ) AssocLeft- , Infix ( operator' "!=" >> return Different ) AssocLeft+ , [ InfixL ( operator "==" >> return Equal )+ , InfixL ( operator "!=" >> return Different ) ]- , [ Infix ( operator' "=~" >> return RegexMatch ) AssocLeft- , Infix ( operator' "!~" >> return NotRegexMatch ) AssocLeft+ , [ InfixL ( operator "=~" >> return RegexMatch )+ , InfixL ( operator "!~" >> return NotRegexMatch ) ]- , [ Infix ( operator' ">=" >> return MoreEqualThan ) AssocLeft- , Infix ( operator' "<=" >> return LessEqualThan ) AssocLeft- , Infix ( operator' ">" >> return MoreThan ) AssocLeft- , Infix ( operator' "<" >> return LessThan ) AssocLeft+ , [ InfixL ( operator ">=" >> return MoreEqualThan )+ , InfixL ( operator "<=" >> return LessEqualThan )+ , InfixL ( operator ">" >> return MoreThan )+ , InfixL ( operator "<" >> return LessThan ) ]- , [ Infix ( reserved' "and" >> return And ) AssocLeft- , Infix ( reserved' "or" >> return Or ) AssocLeft+ , [ InfixL ( reserved "and" >> return And )+ , InfixL ( reserved "or" >> return Or ) ] ]++indexLookupChain :: Parser (Expression -> Expression)+indexLookupChain = chainl1 checkLookup (return (flip (.))) where- checkLookup :: OP (Expression -> Expression)- checkLookup = flip Lookup <$> unParser (between (operator "[") (operator "]") expression)- operator' :: String -> OP ()- operator' = unParser . operator- reserved' :: String -> OP ()- reserved' = unParser . reserved+ checkLookup = flip Lookup <$> between (operator "[") (operator "]") expression stringExpression :: Parser Expression stringExpression = fmap (Terminal . UInterpolable) interpolableString <|> (reserved "undef" *> return (Terminal UUndef)) <|> fmap (Terminal . UBoolean) puppetBool <|> variable <|> fmap Terminal literalValue@@ -364,7 +369,7 @@ return [Nd n st inheritance (p :!: pe) | n <- ns] puppetClassParameters :: Parser (V.Vector (Pair T.Text (S.Maybe Expression)))-puppetClassParameters = V.fromList <$> parens (var `sepEndBy` comma)+puppetClassParameters = V.fromList <$> parens (sepComma var) where toStrictMaybe (Just x) = S.Just x toStrictMaybe Nothing = S.Nothing@@ -465,19 +470,20 @@ Just o' -> OperatorChain g o' <$> parseRelationships p Nothing -> pure (EndOfChain g) -resourceGroup' :: Parser [ResDec]-resourceGroup' = do+resourceGroup :: Parser [ResDec]+resourceGroup = do let resourceName = token stringExpression resourceDeclaration = do p <- getPosition- names <- brackets (resourceName `sepEndBy1` comma) <|> fmap return resourceName+ names <- brackets (sepComma1 resourceName) <|> fmap return resourceName void $ symbolic ':'- vals <- fmap V.fromList (assignment `sepEndBy` comma)+ vals <- fmap V.fromList (sepComma assignment) pe <- getPosition return [(n, vals, p :!: pe) | n <- names ] groupDeclaration = (,) <$> many (char '@') <*> typeName <* symbolic '{' (virts, rtype) <- try groupDeclaration -- for matching reasons, this gets a try until the opening brace- x <- resourceDeclaration `sepEndBy1` (symbolic ';' <|> comma)+ let sep = symbolic ';' <|> comma+ x <- resourceDeclaration `sepEndBy1` sep void $ symbolic '}' virtuality <- case virts of "" -> return Normal@@ -492,15 +498,14 @@ bw = identl (satisfy isAsciiLower) (satisfy acceptable) <?> "Assignment key" acceptable x = isAsciiLower x || isAsciiUpper x || isDigit x || (x == '_') || (x == '-') --- TODO searchExpression :: Parser SearchExpression-searchExpression = parens searchExpression <|> check <|> combine+searchExpression = makeExprParser (token searchterm) searchTable where- combine = do- e1 <- parens searchExpression <|> check- opr <- (operator "and" *> return AndSearch) <|> (operator "or" *> return OrSearch)- e2 <- searchExpression- return (opr e1 e2)+ searchTable :: [[Operator Parser SearchExpression]]+ searchTable = [ [ InfixL ( reserved "and" >> return AndSearch )+ , InfixL ( reserved "or" >> return OrSearch )+ ] ]+ searchterm = parens searchExpression <|> check check = do attrib <- parameterName opr <- (operator "==" *> return EqualitySearch) <|> (operator "!=" *> return NonEqualitySearch)@@ -516,7 +521,7 @@ void (char '|') void (count (length openchev) (char '>')) someSpace- overrides <- option [] $ braces (assignment `sepEndBy` comma)+ overrides <- option [] $ braces (sepComma assignment) let collectortype = if length openchev == 1 then Collector else ExportedCollector@@ -571,7 +576,7 @@ resourceDefaults = do p <- getPosition rnd <- resourceNameRef- let assignmentList = V.fromList <$> assignment `sepEndBy1` comma+ let assignmentList = V.fromList <$> sepComma1 assignment asl <- braces assignmentList pe <- getPosition return (DefaultDec rnd asl (p :!: pe))@@ -581,7 +586,7 @@ p <- getPosition restype <- resourceNameRef names <- brackets (expression `sepBy1` comma) <?> "Resource reference values"- assignments <- V.fromList <$> braces (assignment `sepEndBy` comma)+ assignments <- V.fromList <$> braces (sepComma assignment) pe <- getPosition return [ ResOver restype n assignments (p :!: pe) | n <- names ] @@ -606,7 +611,7 @@ pe <- getPosition pure (ChainResRefr restype resnames (p :!: pe)) _ -> ChainResColl <$> resourceCollection p restype- chain <- parseRelationships $ pure <$> try withresname <|> map ChainResDecl <$> resourceGroup'+ chain <- parseRelationships $ pure <$> try withresname <|> map ChainResDecl <$> resourceGroup let relations = do (g1, g2, lt) <- zipChain chain (rt1, rn1, _ :!: pe1) <- concatMap extractResRef g1@@ -652,7 +657,7 @@ parseHParams :: Parser BlockParameters parseHParams = between (symbolic '|') (symbolic '|') hp where- acceptablePart = T.pack <$> ident identifierStyle+ acceptablePart = T.pack <$> identifier hp = do vars <- (char '$' *> acceptablePart) `sepBy1` comma case vars of
Puppet/Parser/Types.hs view
@@ -61,7 +61,7 @@ import GHC.Generics -import Text.Parsec.Pos+import Text.Megaparsec.Pos import Text.Regex.PCRE.String -- | Properly capitalizes resource types@@ -78,13 +78,13 @@ -- | Position in a puppet file. Currently an alias to 'SourcePos'. type Position = SourcePos -lSourceName :: Lens' Position SourceName+lSourceName :: Lens' Position String lSourceName = lens sourceName setSourceName -lSourceLine :: Lens' Position Line+lSourceLine :: Lens' Position Int lSourceLine = lens sourceLine setSourceLine -lSourceColumn :: Lens' Position Column+lSourceColumn :: Lens' Position Int lSourceColumn = lens sourceColumn setSourceColumn -- | Generates an initial position based on a filename.@@ -245,7 +245,8 @@ data ResDec = ResDec !T.Text !Expression !(V.Vector (Pair T.Text Expression)) !Virtuality !PPosition deriving (Eq, Show) data DefaultDec = DefaultDec !T.Text !(V.Vector (Pair T.Text Expression)) !PPosition deriving (Eq, Show) data ResOver = ResOver !T.Text !Expression !(V.Vector (Pair T.Text Expression)) !PPosition deriving (Eq, Show)--- | All types of conditional statements are stored that way (@case@, @if@, etc.)+-- | All types of conditional statements (@case@, @if@, etc.) are stored as an ordered list of pair (condition, statements)+-- (interpreted as "if first cond is true, choose first statements, else take the next pair, check the condition ...") data CondStatement = CondStatement !(V.Vector (Pair Expression (V.Vector Statement))) !PPosition deriving (Eq, Show) data ClassDecl = ClassDecl !T.Text !(V.Vector (Pair T.Text (S.Maybe Expression))) !(S.Maybe T.Text) !(V.Vector Statement) !PPosition deriving (Eq, Show) data DefineDec = DefineDec !T.Text !(V.Vector (Pair T.Text (S.Maybe Expression))) !(V.Vector Statement) !PPosition deriving (Eq, Show)
Puppet/Plugins.hs view
@@ -30,7 +30,6 @@ import Puppet.PP import qualified Scripting.Lua as Lua import Control.Exception-import Control.Applicative import qualified Data.HashMap.Strict as HM import System.IO import qualified Data.Text as T@@ -43,7 +42,6 @@ import Data.Scientific import qualified Data.ByteString as BS import Control.Lens-import Prelude import Debug.Trace import Puppet.Interpreter.Types
Puppet/Preferences.hs view
@@ -12,7 +12,6 @@ , HasPuppetDirPaths(..) ) where -import Control.Applicative import Control.Lens import Control.Monad (mzero) import Data.Aeson@@ -22,7 +21,7 @@ import Data.Text (Text) import qualified Data.Text as T import System.Posix (fileExist)-import Prelude+import qualified System.Log.Logger as LOG import Puppet.Interpreter.Types import Puppet.NativeTypes@@ -35,20 +34,21 @@ import PuppetDB.Dummy data Preferences m = Preferences- { _puppetPaths :: PuppetDirPaths- , _prefPDB :: PuppetDBAPI m- , _natTypes :: Container NativeTypeMethods -- ^ The list of native types.- , _prefExtFuncs :: Container ( [PValue] -> InterpreterMonad PValue )- , _hieraPath :: Maybe FilePath- , _ignoredmodules :: HS.HashSet Text- , _strictness :: Strictness- , _extraTests :: Bool- , _knownusers :: [Text]- , _knowngroups :: [Text]- , _externalmodules :: HS.HashSet Text- , _puppetSettings :: Container Text- , _factsOverride :: Container PValue- , _factsDefault :: Container PValue+ { _prefPuppetPaths :: PuppetDirPaths+ , _prefPDB :: PuppetDBAPI m+ , _prefNatTypes :: Container NativeTypeMethods -- ^ The list of native types.+ , _prefExtFuncs :: Container ( [PValue] -> InterpreterMonad PValue )+ , _prefHieraPath :: Maybe FilePath+ , _prefIgnoredmodules :: HS.HashSet Text+ , _prefStrictness :: Strictness+ , _prefExtraTests :: Bool+ , _prefKnownusers :: [Text]+ , _prefKnowngroups :: [Text]+ , _prefExternalmodules :: HS.HashSet Text+ , _prefPuppetSettings :: Container Text+ , _prefFactsOverride :: Container PValue+ , _prefFactsDefault :: Container PValue+ , _prefLogLevel :: LOG.Priority } data Defaults = Defaults@@ -103,6 +103,7 @@ (getPuppetSettings dirpaths defaults) (getFactsOverride defaults) (getFactsDefault defaults)+ LOG.NOTICE -- good default as INFO is quite noisy loadDefaults :: FilePath -> IO (Maybe Defaults) loadDefaults fp = do@@ -117,7 +118,7 @@ getKnownusers = fromMaybe ["mysql", "vagrant","nginx", "nagios", "postgres", "puppet", "root", "syslog", "www-data"] . (>>= _dfKnownusers) getKnowngroups :: Maybe Defaults -> [Text]-getKnowngroups = fromMaybe ["adm", "syslog", "mysql", "nagios","postgres", "puppet", "root", "www-data"] . (>>= _dfKnowngroups)+getKnowngroups = fromMaybe ["adm", "syslog", "mysql", "nagios","postgres", "puppet", "root", "www-data", "postfix"] . (>>= _dfKnowngroups) getStrictness :: Maybe Defaults -> Strictness getStrictness = fromMaybe Permissive . (>>= _dfStrictness)@@ -136,6 +137,7 @@ where df :: Container Text df = HM.fromList [ ("confdir", T.pack $ dirpaths^.baseDir)+ , ("strict_variables", "true") ] getFactsOverride :: Maybe Defaults -> Container PValue
Puppet/Puppetlabs.hs view
@@ -26,6 +26,7 @@ extFun :: [(FilePath, Text, [PValue] -> InterpreterMonad PValue)] extFun = [ ("/apache", "bool2httpd", apacheBool2httpd)+ , ("/docker", "docker_run_flags", mockDockerRunFlags) , ("/postgresql", "postgresql_acls_to_resources_hash", pgAclsToHash) , ("/postgresql", "postgresql_password", pgPassword) , ("/foreman", "random_password", randomPassword)@@ -103,3 +104,8 @@ , ("auth_method", PString auth) ] aclToHash acl _ = throwPosError $ "Unable to parse acl line" <+> squotes (ttext (Text.unwords acl))++-- faked implementation, replace by the correct one if you need so.+mockDockerRunFlags :: MonadThrowPos m => [PValue] -> m PValue+mockDockerRunFlags arg@[PHash _]= (return . PString . Text.pack . displayNocolor . pretty . head) arg+mockDockerRunFlags arg@_ = throwPosError $ "Expect an hash as argument but was" <+> pretty arg
Puppet/Stats.hs view
@@ -3,10 +3,9 @@ This is not accurate in the presence of lazy evaluation. Nothing is forced. -}-module Puppet.Stats (measure, measure_, newStats, getStats, StatsTable, StatsPoint(..), MStats) where+module Puppet.Stats (measure, newStats, getStats, StatsTable, StatsPoint(..), MStats) where import Data.Time.Clock.POSIX (getPOSIXTime)-import Control.Monad import Control.Concurrent import qualified Data.HashMap.Strict as HM import qualified Data.Text as T@@ -52,11 +51,7 @@ else smi in stats & at statsname ?~ StatsPoint (sc+1) (st+tm) nmin nmax putMVar mtable nstats- return out---- | Just like 'measure', discarding the result value.-measure_ :: MStats -> T.Text -> IO a -> IO ()-measure_ mtable statsname action = void ( measure mtable statsname action )+ return $! out getTime :: IO Double getTime = realToFrac `fmap` getPOSIXTime@@ -68,4 +63,3 @@ end <- getTime let !delta = end - start return (delta, result)-
PuppetDB/TestDB.hs view
@@ -10,7 +10,6 @@ , initTestDB ) where -import Control.Applicative import Control.Concurrent.STM import Control.Exception import Control.Lens@@ -26,8 +25,7 @@ import qualified Data.Text as T import qualified Data.Vector as V import Data.Yaml-import Text.Parsec.Pos-import Prelude+import Text.Megaparsec.Pos import Puppet.Interpreter.Types import Puppet.Lens
README.adoc view
@@ -1,5 +1,8 @@ = Language-puppet +image:https://travis-ci.org/bartavelle/language-puppet.svg?branch=master["Build Status", link="https://travis-ci.org/bartavelle/language-puppet"]+image:https://img.shields.io/hackage/v/language-puppet.svg[link="http://hackage.haskell.org/package/language-puppet"]+ A library to work with Puppet manifests, test them and eventually replace everything ruby. .Basic usage:@@ -8,11 +11,11 @@ ``` .Easy build instructions:-```+```bash+git clone https://github.com/bartavelle/language-puppet.git cd language-puppet-cabal update-cabal sandbox init-cabal install -j -p+# Add ~/.local/bin to $PATH+stack install ``` There are also http://lpuppet.banquise.net/download/[binary packages available] and https://registry.hub.docker.com/u/pierrer/puppetresources[a docker images].
SafeProcess.hs view
@@ -25,20 +25,16 @@ , ProcessHandle ) -> IO a ) -> IO a-safeCreateProcess prog args streamIn streamOut streamErr fun = bracket- ( do- h <- createProcess (proc prog args)- { std_in = streamIn- , std_out = streamOut- , std_err = streamErr- , create_group = True }- return h+safeCreateProcess prog args streamIn streamOut streamErr = bracket+ ( createProcess (proc prog args) { std_in = streamIn+ , std_out = streamOut+ , std_err = streamErr+ , create_group = True } ) -- "interruptProcessGroupOf" is in the new System.Process. Since some -- programs return funny exit codes i implemented a "terminateProcessGroupOf". -- (\(_, _, _, ph) -> interruptProcessGroupOf ph >> waitForProcess ph) (\(_, _, _, ph) -> terminateProcessGroup ph >> waitForProcess ph)- fun {-# NOINLINE safeCreateProcess #-} safeReadProcess :: String -> [String] -> TL.Text -> IO (Either String T.Text)@@ -63,12 +59,8 @@ terminateProcessGroup :: ProcessHandle -> IO () terminateProcessGroup ph = do-#if MIN_VERSION_base(4,7,0) let (ProcessHandle pmvar _) = ph-#else- let (ProcessHandle pmvar) = ph-#endif readMVar pmvar >>= \case- OpenHandle pid -> do -- pid is a POSIX pid- signalProcessGroup 15 pid- _ -> return ()+ -- pid is a POSIX pid+ OpenHandle pid -> signalProcessGroup 15 pid+ _ -> return ()
language-puppet.cabal view
@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: language-puppet-version: 1.1.4+version: 1.1.4.1 synopsis: Tools to parse and evaluate the Puppet DSL. description: This is a set of tools that is supposed to fill all your Puppet needs : syntax checks, catalog compilation, PuppetDB queries, simulationg of complex interactions between nodes, Puppet master replacement, and more ! homepage: http://lpuppet.banquise.net/@@ -78,12 +78,13 @@ , Puppet.Plugins extensions: OverloadedStrings, BangPatterns ghc-options: -Wall -funbox-strict-fields -j1- ghc-prof-options: -auto-all -caf-all- build-depends: base >=4.6 && < 4.9+ -- ghc-prof-options: -auto-all -caf-all+ build-depends: base >=4.8 && < 4.9 , aeson >= 0.8 && < 0.10 , ansi-wl-pprint == 0.6.* , attoparsec >= 0.12 && < 0.14 , base16-bytestring == 0.1.*+ , bifunctors == 5 , bytestring , case-insensitive == 1.2.* , containers == 0.5.*@@ -91,7 +92,7 @@ , directory == 1.2.* , either >= 4.3 && < 4.5 , exceptions >= 0.8 && < 0.9- , filecache >= 0.2.8 && < 0.3+ , filecache >= 0.2.9 && < 0.3 , formatting , hashable == 1.2.* , hruby >= 0.3.1.6 && <0.4@@ -102,20 +103,22 @@ , memory >= 0.7 , mtl >= 2.2 && < 2.3 , operational >= 0.2.3 && < 0.3+ , megaparsec == 4.1.* , parsec == 3.1.* , parsers >= 0.11 && < 0.13- , pcre-utils >= 0.1.4 && < 0.2+ , pcre-utils >= 0.1.7 && < 0.2 , process >= 1.1 && < 1.3 , random , regex-pcre-builtin >= 0.94.4 , scientific >= 0.2 && < 0.4 , servant == 0.4.* , servant-client == 0.4.*+ , semigroups , split == 0.2.* , stm == 2.4.*- , strict-base-types >= 0.2.2+ , strict-base-types == 0.3.* , text >= 0.11- , time >= 1.4 && < 2+ , time >= 1.5 && < 2 , transformers == 0.4.* , unix >= 2.6 && < 2.8 , unordered-containers == 0.2.*@@ -126,21 +129,21 @@ type: exitcode-stdio-1.0 ghc-options: -Wall -rtsopts -threaded extensions: OverloadedStrings- build-depends: language-puppet,base,text,lens,parsers,hspec+ build-depends: language-puppet,base,text,lens,megaparsec,hspec main-is: evals.hs Test-Suite test-lexer hs-source-dirs: tests type: exitcode-stdio-1.0 ghc-options: -Wall -rtsopts -threaded extensions: OverloadedStrings- build-depends: language-puppet,base,Glob,text,parsec,vector,ansi-wl-pprint,unix+ build-depends: language-puppet,base,Glob,text,megaparsec,vector,ansi-wl-pprint,unix main-is: lexer.hs Test-Suite test-expr hs-source-dirs: tests type: exitcode-stdio-1.0 ghc-options: -Wall -rtsopts -threaded extensions: OverloadedStrings- build-depends: language-puppet,base,text,parsers,vector,ansi-wl-pprint, strict-base-types+ build-depends: language-puppet,base,text,megaparsec,vector,ansi-wl-pprint, strict-base-types main-is: expr.hs Test-Suite test-hiera hs-source-dirs: tests@@ -168,14 +171,14 @@ hs-source-dirs: progs extensions: BangPatterns, OverloadedStrings ghc-options: -Wall -rtsopts -threaded -with-rtsopts "-A2M" -eventlog- ghc-prof-options: -auto-all -caf-all -fprof-auto- build-depends: language-puppet,base,text,parsec,vector,ansi-wl-pprint,bytestring,mtl,hslogger,Diff,unordered-containers,strict-base-types,optparse-applicative >=0.11,regex-pcre-builtin,lens,aeson,yaml,parallel-io,containers,Glob,hspec >= 1.9, either, servant-client+ -- ghc-prof-options: -auto-all -caf-all -fprof-auto+ build-depends: language-puppet,base,text,megaparsec,vector,ansi-wl-pprint,bytestring,mtl,hslogger,Diff,unordered-containers,strict-base-types,optparse-applicative >=0.11,regex-pcre-builtin,lens,aeson,yaml,parallel-io,containers,Glob,hspec >= 1.9, either, servant-client main-is: PuppetResources.hs executable pdbquery hs-source-dirs: progs extensions: BangPatterns, OverloadedStrings ghc-options: -Wall -rtsopts -threaded- ghc-prof-options: -auto-all -caf-all -fprof-auto+ -- ghc-prof-options: -auto-all -caf-all -fprof-auto build-depends: language-puppet,base,optparse-applicative >= 0.11,text,yaml,bytestring,strict-base-types,lens,unordered-containers,vector,either,servant-client main-is: pdbQuery.hs
progs/PuppetResources.hs view
@@ -3,52 +3,47 @@ {-# LANGUAGE RecordWildCards #-} module Main where -import Control.Concurrent.ParallelIO (parallel)-import Control.Lens+import Control.Concurrent.ParallelIO (parallel)+import Control.Lens hiding (Strict) import Control.Monad import Control.Monad.Trans.Either-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-import qualified Data.HashMap.Strict as HM-import qualified Data.HashSet as HS-import Data.List (isInfixOf)-import Data.Maybe (fromMaybe, 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.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 (fromMaybe, 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.Tuple (swap)+import qualified Data.Vector as V import Options.Applicative-import Servant.Common.BaseUrl-import System.Exit (exitFailure, exitSuccess)-import qualified System.FilePath.Glob as G-import System.IO-import qualified System.Log.Logger as LOG-import qualified Text.Parsec as P-import Text.Regex.PCRE.String+import Servant.Common.BaseUrl (parseBaseUrl)+import System.Exit (exitFailure, exitSuccess)+import qualified System.FilePath.Glob as G+import System.IO (hIsTerminalDevice, stdout)+import qualified System.Log.Logger as LOG+import qualified Text.Megaparsec as P+import qualified Text.Regex.PCRE.String as REG import Facter import Puppet.Daemon-import Puppet.Interpreter.PrettyPrinter ()-import Puppet.Interpreter.Types import Puppet.Lens import Puppet.Parser-import Puppet.Parser.PrettyPrinter (ppStatements)+import Puppet.Parser.PrettyPrinter (ppStatements) import Puppet.Parser.Types-import Puppet.PP import Puppet.Preferences import Puppet.Stats-import PuppetDB.Common-import PuppetDB.Dummy-import PuppetDB.Remote-import PuppetDB.TestDB+import PuppetDB.Common (generateWireCatalog)+import PuppetDB.Dummy (dummyPuppetDB)+import PuppetDB.Remote (pdbConnect)+import PuppetDB.TestDB (loadTestDB) -import Prelude type QueryFunc = Nodename -> IO (S.Either PrettyError (FinalCatalog, EdgeMap, FinalCatalog, [Resource])) @@ -148,9 +143,6 @@ ( long "noextratests" <> help "Disable extra tests (eg.: check that files exist on local disk") -checkError :: Show e => Doc -> Either e a -> IO a-checkError r (Left rr) = error (show (red r <> ": " <+> (string . show) rr))-checkError _ (Right x) = return x -- | Like catMaybes, but it counts the Nothing values catMaybesCount :: [Maybe a] -> ([a], Sum Int)@@ -167,8 +159,6 @@ -> Options -> IO (QueryFunc, PuppetDBAPI IO, MStats, MStats, MStats) initializedaemonWithPuppet workingdir (Options {..}) = do- LOG.updateGlobalLogger "Puppet.Daemon" (LOG.setLevel _optLoglevel)- LOG.updateGlobalLogger "Hiera.Server" (LOG.setLevel _optLoglevel) pdbapi <- case (_optPdburl, _optPdbfile) of (Nothing, Nothing) -> return dummyPuppetDB (Just _, Just _) -> error "You must choose between a testing PuppetDB and a remote one"@@ -177,12 +167,13 @@ >>= checkError "Error when connecting to the remote PuppetDB" (_, Just file) -> loadTestDB file >>= checkError "Error when initializing the PuppetDB API" prf <- dfPreferences workingdir <&> prefPDB .~ pdbapi- <&> hieraPath .~ _optHieraFile- <&> ignoredmodules %~ (`fromMaybe` _optIgnoredMods)- <&> (if _optStrictMode then strictness .~ Strict else id)- <&> (if _optNoExtraTests then extraTests .~ False else id)+ <&> prefHieraPath .~ _optHieraFile+ <&> prefIgnoredmodules %~ (`fromMaybe` _optIgnoredMods)+ <&> (if _optStrictMode then prefStrictness .~ Strict else id)+ <&> (if _optNoExtraTests then prefExtraTests .~ False else id)+ <&> prefLogLevel .~ _optLoglevel q <- initDaemon prf- let queryfunc = \node -> fmap (unifyFacts (prf^.factsDefault) (prf^.factsOverride)) (puppetDBFacts node pdbapi) >>= _dGetCatalog q node+ let queryfunc = \node -> fmap (unifyFacts (prf ^. prefFactsDefault) (prf ^. prefFactsOverride)) (puppetDBFacts node pdbapi) >>= _dGetCatalog q node return (queryfunc, pdbapi, _dParserStats q, _dCatalogStats q, _dTemplateStats q) where -- merge 3 sets of facts : some defaults, the original set and some override@@ -190,7 +181,7 @@ unifyFacts defaults override c = override `HM.union` c `HM.union` defaults parseFile :: FilePath -> IO (Either P.ParseError (V.Vector Statement))-parseFile = fmap . runPParser puppetParser <*> T.readFile+parseFile fp = runPParser fp <$> T.readFile fp printContent :: T.Text -> FinalCatalog -> IO () printContent filename catalog =@@ -304,7 +295,7 @@ putStr ("\nTested " ++ show nbnodes ++ " nodes. ") unless (nbnodes == 0) $ do putStrLn (formatDouble parserShare <> "% of total CPU time spent parsing, " <> formatDouble templateShare <> "% spent computing templates")- when (_optLoglevel <= LOG.INFO) $ do+ when (_optLoglevel <= LOG.NOTICE) $ 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")@@ -359,20 +350,21 @@ where -- filter catalog using the adhoc lens filterC Nothing _ c = return c- filterC (Just regexp) l c = compile compBlank execBlank (T.unpack regexp) >>= \case+ filterC (Just regexp) l c = REG.compile REG.compBlank REG.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-+ filterResource reg l v = REG.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 {_optParse = Just fp}) = parseFile fp >>= \case+run (Options {_optParse = Just fp, ..}) = parseFile fp >>= \case Left rr -> error ("parse error:" ++ show rr)- Right s -> putDoc $ ppStatements s+ Right s -> if _optLoglevel == LOG.DEBUG+ then mapM_ print s+ else putDoc $ ppStatements s run (Options {_optPuppetdir = Nothing, _optParse = Nothing }) = error "Without a puppet dir, only the `--parse` option can be supported"@@ -387,12 +379,8 @@ -- | Multiple nodes mode (`--all`) option run cmd@(Options {_optNodename = Nothing , _optMultnodes = Just nodes, _optPuppetdir = 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 {_optLoglevel = LOG.ERROR})+ (queryfunc, _, mPStats,mCStats,mTStats) <- initializedaemonWithPuppet workingdir cmd computeStats workingdir cmd queryfunc (mPStats, mCStats, mTStats) =<< retrieveNodes nodes- where retrieveNodes :: MultNodes -> IO [Nodename] retrieveNodes AllNodes = do
ruby/hrubyerb.rb view
@@ -77,7 +77,7 @@ class ErbBinding @options = {}- def initialize(context,variables,filename='x',stt,rdr)+ def initialize(context,variables,stt,rdr,filename='x') @stt = stt @rdr = rdr @scope = Scope.new(context,variables,filename,stt,rdr)
tests/evals.hs view
@@ -9,10 +9,8 @@ import System.Environment import Test.Hspec-import Control.Applicative-import Text.Parser.Combinators (eof)+import Text.Megaparsec (eof, parse) import Data.Foldable (forM_)-import Prelude pureTests :: [T.Text] pureTests = [ "4 + 2 == 6"@@ -27,19 +25,20 @@ , "regsubst('127', '([0-9]+)', '<\\1>', 'G') == '<127>'" , "regsubst(['1','2','3'], '([0-9]+)', '<\\1>', 'G') == ['<1>','<2>','<3>']" , "versioncmp('2.1','2.2') == -1"+ , "inline_template('a','b') == 'ab'" ] main :: IO () main = do let check :: T.Text -> Either String ()- check t = case runPParser (expression <* eof) "dummy" t of+ check t = case parse (expression <* eof) "dummy" t of Left rr -> Left (T.unpack t ++ " -> " ++ show rr) Right e -> case dummyEval (resolveExpression e) of Right (PBoolean True) -> Right () Right x -> Left (T.unpack t ++ " -> " ++ show (pretty x)) Left rr -> Left (T.unpack t ++ " -> " ++ show rr) runcheck :: String -> IO ()- runcheck t = case runPParser (expression <* eof) "dummy" (T.pack t) of+ runcheck t = case parse (expression <* eof) "dummy" (T.pack t) of Left rr -> error ("Can't parse: " ++ show rr) Right e -> case dummyEval (resolveExpression e) of Right x -> print (pretty x)@@ -48,5 +47,3 @@ if null args then hspec $ describe "evaluation" $ forM_ pureTests $ \t -> it ("should evaluate " ++ show t) $ either error (const True) (check t) else mapM_ runcheck args--
tests/expr.hs view
@@ -1,6 +1,5 @@ module Main where -import Control.Applicative import Control.Arrow (first) import Control.Monad import Data.Maybe@@ -10,8 +9,7 @@ import Puppet.Parser import Puppet.Parser.PrettyPrinter () import Puppet.Parser.Types-import Text.Parser.Combinators-import Prelude+import Text.Megaparsec testcases :: [(T.Text, Expression)] testcases =@@ -32,7 +30,7 @@ main :: IO () main = do- let testres = map (first (runPParser (expression <* eof) "tests")) testcases+ let testres = map (first (parse (expression <* eof) "tests")) testcases isFailure (Left x, _) = Just (show x) isFailure (Right x, e) = if x == e then Nothing
tests/lexer.hs view
@@ -7,6 +7,7 @@ import System.Environment import Puppet.Parser.PrettyPrinter import Text.PrettyPrint.ANSI.Leijen+import Text.Megaparsec (parse, eof) import System.Posix.Terminal import System.Posix.Types import System.IO@@ -16,16 +17,14 @@ allchecks = do filelist <- fmap (head . fst) (globDir [compile "*.pp"] "tests/lexer") testres <- mapM testparser filelist- let testsrs = map fst testres- isgood = all snd testres- outlist = zip [1..(length testres)] testsrs- mapM_ (\(n,t) -> putStrLn $ show n ++ " " ++ t) outlist+ let isgood = all snd testres+ mapM_ (\(rr, t) -> unless t (putStrLn rr)) testres unless isgood (error "fail") -- returns errors testparser :: FilePath -> IO (String, Bool)-testparser fp = do- fmap (runPParser puppetParser fp) (T.readFile fp) >>= \case+testparser fp =+ fmap (parse (puppetParser <* eof) fp) (T.readFile fp) >>= \case Right _ -> return ("PASS", True) Left rr -> return (show rr, False) @@ -33,7 +32,7 @@ check fname = do putStr fname putStr ": "- res <- fmap (runPParser puppetParser fname) (T.readFile fname)+ res <- fmap (parse puppetParser fname) (T.readFile fname) is <- queryTerminal (Fd 1) let rfunc = if is then renderPretty 0.2 200