diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -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 diff --git a/Erb/Compute.hs b/Erb/Compute.hs --- a/Erb/Compute.hs +++ b/Erb/Compute.hs @@ -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 diff --git a/Facter.hs b/Facter.hs --- a/Facter.hs +++ b/Facter.hs @@ -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) - diff --git a/Hiera/Server.hs b/Hiera/Server.hs --- a/Hiera/Server.hs +++ b/Hiera/Server.hs @@ -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) diff --git a/Puppet/Daemon.hs b/Puppet/Daemon.hs --- a/Puppet/Daemon.hs +++ b/Puppet/Daemon.hs @@ -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") diff --git a/Puppet/Interpreter.hs b/Puppet/Interpreter.hs --- a/Puppet/Interpreter.hs +++ b/Puppet/Interpreter.hs @@ -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 diff --git a/Puppet/Interpreter/IO.hs b/Puppet/Interpreter/IO.hs --- a/Puppet/Interpreter/IO.hs +++ b/Puppet/Interpreter/IO.hs @@ -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) diff --git a/Puppet/Interpreter/Pure.hs b/Puppet/Interpreter/Pure.hs --- a/Puppet/Interpreter/Pure.hs +++ b/Puppet/Interpreter/Pure.hs @@ -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. diff --git a/Puppet/Interpreter/Resolve.hs b/Puppet/Interpreter/Resolve.hs --- a/Puppet/Interpreter/Resolve.hs +++ b/Puppet/Interpreter/Resolve.hs @@ -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 >>= diff --git a/Puppet/Interpreter/Types.hs b/Puppet/Interpreter/Types.hs --- a/Puppet/Interpreter/Types.hs +++ b/Puppet/Interpreter/Types.hs @@ -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 diff --git a/Puppet/Lens.hs b/Puppet/Lens.hs --- a/Puppet/Lens.hs +++ b/Puppet/Lens.hs @@ -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'. diff --git a/Puppet/NativeTypes/File.hs b/Puppet/NativeTypes/File.hs --- a/Puppet/NativeTypes/File.hs +++ b/Puppet/NativeTypes/File.hs @@ -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 diff --git a/Puppet/NativeTypes/Package.hs b/Puppet/NativeTypes/Package.hs --- a/Puppet/NativeTypes/Package.hs +++ b/Puppet/NativeTypes/Package.hs @@ -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 diff --git a/Puppet/OptionalTests.hs b/Puppet/OptionalTests.hs --- a/Puppet/OptionalTests.hs +++ b/Puppet/OptionalTests.hs @@ -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 () diff --git a/Puppet/Parser.hs b/Puppet/Parser.hs --- a/Puppet/Parser.hs +++ b/Puppet/Parser.hs @@ -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 diff --git a/Puppet/Parser/Types.hs b/Puppet/Parser/Types.hs --- a/Puppet/Parser/Types.hs +++ b/Puppet/Parser/Types.hs @@ -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) diff --git a/Puppet/Plugins.hs b/Puppet/Plugins.hs --- a/Puppet/Plugins.hs +++ b/Puppet/Plugins.hs @@ -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 diff --git a/Puppet/Preferences.hs b/Puppet/Preferences.hs --- a/Puppet/Preferences.hs +++ b/Puppet/Preferences.hs @@ -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 diff --git a/Puppet/Puppetlabs.hs b/Puppet/Puppetlabs.hs --- a/Puppet/Puppetlabs.hs +++ b/Puppet/Puppetlabs.hs @@ -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 diff --git a/Puppet/Stats.hs b/Puppet/Stats.hs --- a/Puppet/Stats.hs +++ b/Puppet/Stats.hs @@ -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) - diff --git a/PuppetDB/TestDB.hs b/PuppetDB/TestDB.hs --- a/PuppetDB/TestDB.hs +++ b/PuppetDB/TestDB.hs @@ -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 diff --git a/README.adoc b/README.adoc --- a/README.adoc +++ b/README.adoc @@ -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]. diff --git a/SafeProcess.hs b/SafeProcess.hs --- a/SafeProcess.hs +++ b/SafeProcess.hs @@ -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 () diff --git a/language-puppet.cabal b/language-puppet.cabal --- a/language-puppet.cabal +++ b/language-puppet.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: language-puppet -version: 1.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 diff --git a/progs/PuppetResources.hs b/progs/PuppetResources.hs --- a/progs/PuppetResources.hs +++ b/progs/PuppetResources.hs @@ -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 diff --git a/ruby/hrubyerb.rb b/ruby/hrubyerb.rb --- a/ruby/hrubyerb.rb +++ b/ruby/hrubyerb.rb @@ -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) diff --git a/tests/evals.hs b/tests/evals.hs --- a/tests/evals.hs +++ b/tests/evals.hs @@ -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 - - diff --git a/tests/expr.hs b/tests/expr.hs --- a/tests/expr.hs +++ b/tests/expr.hs @@ -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 diff --git a/tests/lexer.hs b/tests/lexer.hs --- a/tests/lexer.hs +++ b/tests/lexer.hs @@ -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