diff --git a/Erb/Compute.hs b/Erb/Compute.hs --- a/Erb/Compute.hs +++ b/Erb/Compute.hs @@ -1,7 +1,5 @@ {-# LANGUAGE CPP #-} -#ifdef HRUBY {-# LANGUAGE ForeignFunctionInterface #-} -#endif {-# LANGUAGE LambdaCase #-} module Erb.Compute(computeTemplate, initTemplateDaemon) where @@ -30,27 +28,11 @@ import Data.FileCache import Control.Lens -#ifdef HRUBY +import Data.Tuple.Strict import qualified Foreign.Ruby as FR import Foreign.Ruby.Safe -import Data.Tuple.Strict -#else -import System.IO -import SafeProcess -import Data.List -import qualified Data.Text.IO as T -import qualified Data.Text.Lazy.IO as TL -import qualified Data.Text.Lazy.Builder as T -import qualified Data.Foldable as F -import qualified Data.Vector as V - --- we don't have a nice interpreter whithout hruby, but we can keep the --- function signatures with this hack -type RubyInterpreter = () -#endif - newtype TemplateParseError = TemplateParseError { tgetError :: ParseError } instance Error TemplateParseError where @@ -60,7 +42,6 @@ type TemplateQuery = (Chan TemplateAnswer, Either T.Text T.Text, T.Text, Container ScopeInformation) type TemplateAnswer = S.Either PrettyError T.Text -#ifdef HRUBY showRubyError :: RubyError -> PrettyError showRubyError (Stack msg stk) = PrettyError $ dullred (string msg) dullyellow (string stk) showRubyError (WithOutput str _) = PrettyError $ dullred (string str) @@ -77,14 +58,6 @@ void $ forkIO $ templateDaemon intr (T.pack modpath) (T.pack templatepath) controlchan mvstats templatecache return (templateQuery controlchan) Left rs -> returnError rs -#else -initTemplateDaemon :: Preferences -> MStats -> IO (Either T.Text T.Text -> T.Text -> Container ScopeInformation -> IO (S.Either PrettyError T.Text)) -initTemplateDaemon (Preferences _ modpath templatepath _ _ _ _ _ _) mvstats = do - controlchan <- newChan - templatecache <- newFileCache - forkIO (templateDaemon () (T.pack modpath) (T.pack templatepath) controlchan mvstats templatecache) - return (templateQuery controlchan) -#endif templateQuery :: Chan TemplateQuery -> Either T.Text T.Text -> T.Text -> Container ScopeInformation -> IO (S.Either PrettyError T.Text) templateQuery qchan filename scope variables = do @@ -155,7 +128,6 @@ cabalPath <- getDataFileName $ "ruby/" ++ rubybin :: IO FilePath checkpath cabalPath withExecutablePath -#ifdef HRUBY -- This must be called from the proper thread. As this is callback, this -- should be ok. hrresolveVariable :: RValue -> RValue -> RValue -> RValue -> IO RValue @@ -205,61 +177,3 @@ Just result -> return (S.Right result) Nothing -> return (S.Left "Could not deserialiaze ruby output") -#else -saveTmpContent :: T.Text -> IO FilePath -saveTmpContent cnt = do - (name, h) <- openTempFile "/tmp" "inline_template.erb" - T.hPutStr h cnt - hClose h - return name - -computeTemplateWRuby :: Either T.Text T.Text -> T.Text -> Container ScopeInformation -> IO TemplateAnswer -computeTemplateWRuby fileinfo curcontext variables = do - (temp, filename) <- case fileinfo of - Right x -> return (Nothing, x) - Left cnt -> do - tmpfile <- saveTmpContent cnt - return (Just tmpfile, "inline") - let rubyvars = "{\n" <> mconcat (intersperse ",\n" (concatMap toRubyVars (itoList variables))) <> "\n}\n" :: T.Builder - input = T.fromText curcontext <> "\n" <> T.fromText filename <> "\n" <> rubyvars :: T.Builder - ufilename = T.unpack filename - rubyscriptpath <- getRubyScriptPath "calcerb.rb" - traceEventIO ("START ruby " ++ ufilename) - !ret <- safeReadProcessTimeout "ruby" [rubyscriptpath] (T.toLazyText input) 1000 - traceEventIO ("STOP ruby " ++ ufilename) - F.forM_ temp removeLink - case ret of - Just (Right x) -> return $! S.Right x - Just (Left er) -> do - (tmpfilename, tmphandle) <- openTempFile "/tmp" "templatefail" - TL.hPutStr tmphandle (T.toLazyText input) - hClose tmphandle - return $ S.Left $ dullred (text er) <+> "- for template" <+> text ufilename <+> "input in" <+> text tmpfilename - Nothing -> return $ S.Left "Process did not terminate" - -minterc :: T.Builder -> [T.Builder] -> T.Builder -minterc _ [] = mempty -minterc _ [a] = a -minterc !separator (x:xs) = x <> foldl' minterc' mempty xs - where - minterc' !curbuilder !b = curbuilder <> separator <> b - -renderString :: T.Text -> T.Builder -renderString x = let !y = T.fromString (show x) in y - -toRubyVars :: (T.Text, ScopeInformation) -> [T.Builder] -toRubyVars (ctx, scp) = concatMap (\(varname, varval :!: _) -> toRuby (ctx <> "::" <> varname, varval)) (itoList (scp ^. scopeVariables)) - -toRuby :: (T.Text, PValue) -> [T.Builder] -toRuby (_, PUndef) = [] -toRuby (varname, varval) = ["\t" <> renderString varname <> " => " <> toRuby' varval] - -toRuby' :: PValue -> T.Builder -toRuby' (PString str) = renderString str -toRuby' (PBoolean True) = "true" -toRuby' (PBoolean False) = "false" -toRuby' (PArray rr) = "[" <> minterc ", " (map toRuby' (rr ^.. traverse)) <> "]" -toRuby' (PHash hh) = "{ " <> minterc ", " (map (\(varname, varval) -> renderString varname <> " => " <> toRuby' varval) (itolist hh)) <> " }" -toRuby' PUndef = ":undef" -toRuby' (PResourceReference rtype rname) = renderString ( rtype <> "[" <> rname <> "]" ) -#endif diff --git a/Facter.hs b/Facter.hs --- a/Facter.hs +++ b/Facter.hs @@ -15,6 +15,7 @@ import Data.List.Split (splitOn) import Data.List (intercalate,stripPrefix) import System.Environment +import System.Directory (doesFileExist) import Data.Maybe (mapMaybe) storageunits :: [(String, Int)] @@ -62,6 +63,40 @@ factOS :: IO [(String, String)] factOS = do + islsb <- doesFileExist "/etc/lsb-release" + isdeb <- doesFileExist "/etc/debian_version" + case (islsb, isdeb) of + (True, _) -> factOSLSB + (_, True) -> factOSDebian + _ -> return [] + +factOSDebian :: IO [(String, String)] +factOSDebian = fmap (toV . head . lines) (readFile "/etc/debian_version") + where + toV v = [ ("lsbdistid" , "Debian") + , ("operatingsystem" , "Debian") + , ("lsbdistrelease" , v) + , ("operatingsystemrelease" , v) + , ("lsbmajdistrelease" , takeWhile (/='.') v) + , ("osfamily" , "Debian") + , ("lsbdistcodename" , codename v) + , ("lsbdistdescription" , "Debian GNU/Linux " ++ v ++ " (" ++ codename v ++ ")") + ] + codename v | null v = "unknown" + | h '7' = "wheezy" + | h '6' = "squeeze" + | h '5' = "lenny" + | h '4' = "etch" + | v == "3.1" = "sarge" + | v == "3.0" = "woody" + | v == "2.2" = "potato" + | v == "2.1" = "slink" + | v == "2.0" = "hamm" + | otherwise = "unknown" + where h x = head v == x + +factOSLSB :: IO [(String, String)] +factOSLSB = do lsb <- fmap (map (break (== '=')) . lines) (readFile "/etc/lsb-release") let getval st | null filterd = "?" | otherwise = rvalue diff --git a/Puppet/Daemon.hs b/Puppet/Daemon.hs --- a/Puppet/Daemon.hs +++ b/Puppet/Daemon.hs @@ -26,10 +26,7 @@ import qualified Data.Either.Strict as S import Data.Tuple.Strict import Control.Exception - -#ifdef HRUBY import Foreign.Ruby.Safe -#endif loggerName :: String loggerName = "Puppet.Daemon" @@ -86,12 +83,8 @@ catalogStats <- newStats pfilecache <- newFileCache let getStatements = parseFunction prefs pfilecache parserStats -#ifdef HRUBY intr <- startRubyInterpreter getTemplate <- initTemplateDaemon intr prefs templateStats -#else - getTemplate <- initTemplateDaemon prefs templateStats -#endif hquery <- case prefs ^. hieraPath of Just p -> startHiera p >>= \case Left _ -> return dummyHiera @@ -157,10 +150,8 @@ parseFile fname = do traceEventIO ("START parsing " ++ fname) cnt <- T.readFile fname - o <- case runMyParser puppetParser fname cnt of + o <- case runPParser puppetParser 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 - - diff --git a/Puppet/Interpreter.hs b/Puppet/Interpreter.hs --- a/Puppet/Interpreter.hs +++ b/Puppet/Interpreter.hs @@ -5,6 +5,7 @@ import Puppet.Interpreter.PrettyPrinter(containerComma) import Puppet.Interpreter.Resolve import Puppet.Parser.Types +import Puppet.Lens import Puppet.Parser.PrettyPrinter import Puppet.PP hiding ((<$>)) import Puppet.NativeTypes @@ -26,14 +27,23 @@ import qualified Data.Graph as G import qualified Data.Tree as T import Data.Foldable (toList,foldl',Foldable,foldlM) -import Data.Traversable (mapM,forM) -import Control.Monad.Operational +import Data.Traversable (mapM) +import Control.Monad.Operational hiding (view) import Control.Applicative -- helpers vmapM :: (Monad m, Foldable t) => (a -> m b) -> t a -> m [b] vmapM f = mapM f . toList +getModulename :: RIdentifier -> T.Text +getModulename (RIdentifier t n) = + let gm x = case T.splitOn "::" x of + [] -> x + (y:_) -> y + in case t of + "class" -> gm n + _ -> gm t + -- | This is the main function for computing catalogs. It returns the -- result of the compulation (either an error, or a tuple containing all -- the resources, dependency map, exported resources, and defined resources @@ -61,17 +71,13 @@ return (strictifyEither output :!: warnings) isParent :: T.Text -> CurContainerDesc -> InterpreterMonad Bool -isParent _ (ContImport _ _) = return False -- no relationship through import -isParent _ ContRoot = return False -isParent _ (ContImported _) = return False -isParent _ (ContDefine _ _ _) = return False -isParent cur (ContClass possibleparent) = do - preuse (scopes . ix cur . scopeParent) >>= \case +isParent cur (ContClass possibleparent) = preuse (scopes . ix cur . scopeParent) >>= \case Nothing -> throwPosError ("Internal error: could not find scope" <+> ttext cur <+> "possible parent" <+> ttext possibleparent) Just S.Nothing -> return False Just (S.Just p) -> if p == possibleparent then return True else isParent p (ContClass possibleparent) +isParent _ _ = return False finalize :: [Resource] -> InterpreterMonad [Resource] finalize rlist = do @@ -79,17 +85,12 @@ scp <- getScopeName defs <- use (scopes . ix scp . scopeDefaults) let getOver = use (scopes . ix scp . scopeOverrides) -- retrieves current overrides - addDefaults r = do - let thisresdefaults = defs ^. ix (r ^. rid . itype) . defValues - foldM (addAttribute CantReplace) r (itoList thisresdefaults) - addOverrides r = do - overs <- getOver - case overs ^. at (r ^. rid) of - Just x -> do - scopes . ix scp . scopeOverrides . at (r ^. rid) .= Nothing - addOverrides' r x - Nothing -> return r + addDefaults r = ifoldlM (addAttribute CantReplace) r thisresdefaults + where thisresdefaults = defs ^. ix (r ^. rid . itype) . defValues + addOverrides r = getOver >>= foldlM addOverrides' r addOverrides' r (ResRefOverride _ prms p) = do + -- we used this override, so we discard it + scopes . ix scp . scopeOverrides . at (r ^. rid) .= Nothing let forb = throwPosError ("Override of parameters of the following resource is forbidden in the current context:" pretty r <+> showPPos p) s <- getScope overrideType <- case r ^. rscope of @@ -100,7 +101,7 @@ if i then return Replace -- we can override what's defined in a parent else forb - foldM (\cr a -> addAttribute overrideType cr a) r (HM.toList prms) + ifoldlM (addAttribute overrideType) r prms withDefaults <- mapM (addOverrides >=> addDefaults) rlist -- There might be some overrides that could not be applied. The only -- valid reason is that they override something in exported resources. @@ -113,16 +114,14 @@ overrider r = do -- we must define if we can override the value let canOverride = CantOverride -- TODO check inheritance - foldM (addAttribute canOverride) r (itoList resprms) - toList <$> getOver >>= mapM_ keepforlater - let expandableDefine (curstd, curdef) r = do + ifoldlM (addAttribute canOverride) r resprms + void $ getOver >>= mapM keepforlater + let expandableDefine r = do n <- isNativeType (r ^. rid . itype) - return $! if n || (r ^. rvirtuality /= Normal) - then (r : curstd, curdef) - else (curstd, r : curdef) - (standard, defines) <- foldM expandableDefine ([], []) withDefaults - expanded <- mapM expandDefine defines - return $! standard ++ concat expanded + if n + then return [r] + else expandDefine r + join <$> mapM expandableDefine withDefaults popScope :: InterpreterMonad () popScope = curScope %= tail @@ -141,7 +140,7 @@ evalTopLevel x = return ([], x) getstt :: TopLevelType -> T.Text -> InterpreterMonad ([Resource], Statement) -getstt topleveltype toplevelname = do +getstt topleveltype toplevelname = -- check if this is a known class (spurious or inner class) use (nestedDeclarations . at (topleveltype, toplevelname)) >>= \case Just x -> return ([], x) -- it is known ! @@ -223,7 +222,10 @@ -- check that all resources are defined, and build graph let checkResDef :: (RIdentifier, [LinkInformation]) -> InterpreterMonad (RIdentifier, RIdentifier, [RIdentifier]) checkResDef (ri, lifs) = do - let checkExists r msg = unless (defs & has (ix r)) (throwPosError msg) + let checkExists r msg = do + let modulename = getModulename r + ign <- singleton (IsIgnoredModule modulename) + unless ((defs & has (ix r)) || 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 @@ -306,9 +308,11 @@ then nestedDeclarations . at (TopClass, cname) ?= r >> return [] else do scp <- getScopeName - if scp == "::" - then nestedDeclarations . at (TopClass, cname) ?= r >> return [] - else nestedDeclarations . at (TopClass, scp <> "::" <> cname) ?= r >> return [] + let rcname = if scp == "::" + then cname + else scp <> "::" <> cname + nestedDeclarations . at (TopClass, rcname) ?= r + return [] evaluateStatement r@(DefineDeclaration dname _ _ _) = if "::" `T.isInfixOf` dname then nestedDeclarations . at (TopDefine, dname) ?= r >> return [] @@ -341,14 +345,12 @@ o <- finalize res popScope return o - else return [] -evaluateStatement (Dependency (t1 :!: n1) (t2 :!: n2) p) = do +evaluateStatement (Dependency (t1 :!: n1) (t2 :!: n2) lt p) = do curPos .= p - rn1 <- resolveExpressionStrings n1 - rn2 <- resolveExpressionStrings n2 - forM_ rn1 $ \an1 -> forM_ rn2 $ \an2 -> - extraRelations %= (LinkInformation (RIdentifier t1 an1) (RIdentifier t2 an2) RBefore 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 ] return [] evaluateStatement (ResourceDeclaration rt ern eargs virt p) = do curPos .= p @@ -421,20 +423,19 @@ variableDefined <- preuse (scopes . ix scp . scopeVariables . ix varname) case (scopeDefined, variableDefined) of (False, _) -> throwPosError ("Internal error: trying to save a variable in unknown scope" <+> ttext scp) - (_, Just (_ :!: pp :!: ctx)) -> do - isParent scp (curcont ^. cctype) >>= \case + (_, Just (_ :!: pp :!: ctx)) -> isParent scp (curcont ^. cctype) >>= \case True -> do - debug ("The variable" - <+> pretty (UVariableReference varname) - <+> "had been overriden because of some arbitrary inheritance rule that was set up to emulate puppet behaviour. It was defined at" - <+> showPPos pp - ) + debug("The variable" + <+> pretty (UVariableReference varname) + <+> "had been overriden because of some arbitrary inheritance rule that was set up to emulate puppet behaviour. It was defined at" + <+> showPPos pp + ) scopes . ix scp . scopeVariables . at varname ?= (varval :!: p :!: curcont ^. cctype) False -> throwPosError ("Variable" <+> pretty (UVariableReference varname) <+> "already defined at" <+> showPPos pp - "Context:" <+> pretty ctx - "Value:" <+> pretty varval - "Current scope:" <+> ttext scp - ) + "Context:" <+> pretty ctx + "Value:" <+> pretty varval + "Current scope:" <+> ttext scp + ) _ -> scopes . ix scp . scopeVariables . at varname ?= (varval :!: p :!: curcont ^. cctype) -- | This function loads class and define parameters into scope. It checks @@ -531,9 +532,7 @@ expandDefine r = do let deftype = dropInitialColons (r ^. rid . itype) defname = r ^. rid . iname - modulename = case T.splitOn "::" deftype of - [] -> deftype - (x:_) -> x + modulename = getModulename (r ^. rid) let curContType = ContDefine deftype defname (r ^. rpos) p <- use curPos -- we add the relations of this define to the global list of relations @@ -555,17 +554,18 @@ curscp <- getScope when isImportedDefine (pushScope (ContImport (r ^. rnode) curscp )) pushScope curContType - loadVariable "title" (PString defname) - loadVariable "name" (PString defname) - -- not done through loadvariable because of override - -- errors - loadParameters (r ^. rattributes) defineParams cp S.Nothing - curPos .= cp imods <- singleton (IsIgnoredModule modulename) - res <- if imods + out <- if imods then return mempty - else evaluateStatementsVector stmts - out <- finalize (spurious ++ res) + else do + loadVariable "title" (PString defname) + loadVariable "name" (PString defname) + -- not done through loadvariable because of override + -- errors + loadParameters (r ^. rattributes) defineParams cp S.Nothing + curPos .= cp + res <- evaluateStatementsVector stmts + finalize (spurious ++ res) when isImportedDefine popScope popScope return out @@ -605,9 +605,7 @@ S.Nothing -> return [] S.Just ihname -> loadClass ihname (S.Just classname) mempty IncludeStandard let !scopedesc = ContClass classname - modulename = case T.splitOn "::" classname of - [] -> classname - (x:_) -> x + modulename = getModulename (RIdentifier "class" classname) secontext = case (inh, loadedfrom) of (S.Just x,_) -> SEChild (dropInitialColons x) (_,S.Just x) -> SEParent (dropInitialColons x) @@ -620,17 +618,16 @@ return [Resource (RIdentifier "class" classname) (HS.singleton classname) mempty mempty scp Normal mempty p fqdn] else return [] pushScope scopedesc - -- not done through loadvariable because of override - -- errors - loadVariable "title" (PString classname) - loadVariable "name" (PString classname) - loadParameters params classParams cp (S.Just classname) - curPos .= cp imods <- singleton (IsIgnoredModule modulename) - res <- if imods + out <- if imods then return mempty - else evaluateStatementsVector stmts - out <- finalize (classresource ++ spurious ++ inhstmts ++ res) + else do + loadVariable "title" (PString classname) + loadVariable "name" (PString classname) + loadParameters params classParams cp (S.Just classname) + curPos .= cp + res <- evaluateStatementsVector stmts + finalize (classresource ++ spurious ++ inhstmts ++ res) popScope return out _ -> throwPosError ("Internal error: we did not retrieve a ClassDeclaration, but had" <+> pretty cls) @@ -649,20 +646,20 @@ addTagResource :: Resource -> T.Text -> Resource addTagResource r rv = r & rtags . contains rv .~ True -addAttribute :: OverrideType -> Resource -> (T.Text, PValue) -> InterpreterMonad Resource -addAttribute _ r ("alias", v) = (\rv -> r & ralias . contains rv .~ True) <$> resolvePValueString v -addAttribute _ r ("audit", _) = use curPos >>= \p -> warn ("Metaparameter audit ignored at" <+> showPPos p) >> return r -addAttribute _ r ("noop", _) = use curPos >>= \p -> warn ("Metaparameter noop ignored at" <+> showPPos p) >> return r -addAttribute _ r ("loglevel", _) = use curPos >>= \p -> warn ("Metaparameter loglevel ignored at" <+> showPPos p) >> return r -addAttribute _ r ("schedule", _) = use curPos >>= \p -> warn ("Metaparameter schedule ignored at" <+> showPPos p) >> return r -addAttribute _ r ("stage", _) = use curPos >>= \p -> warn ("Metaparameter stage ignored at" <+> showPPos p) >> return r -addAttribute _ r ("tag", PArray v) = foldM (\cr cv -> addTagResource cr <$> resolvePValueString cv) r (toList v) -addAttribute _ r ("tag", v) = addTagResource r <$> resolvePValueString v -addAttribute _ r ("before", d) = addRelationship RBefore d r -addAttribute _ r ("notify", d) = addRelationship RNotify d r -addAttribute _ r ("require", d) = addRelationship RRequire d r -addAttribute _ r ("subscribe", d) = addRelationship RSubscribe d r -addAttribute b r (t,v) = case (r ^. rattributes . at t, b) of +addAttribute :: OverrideType -> T.Text -> Resource -> PValue -> InterpreterMonad Resource +addAttribute _ "alias" r v = (\rv -> r & ralias . contains rv .~ True) <$> resolvePValueString v +addAttribute _ "audit" r _ = use curPos >>= \p -> warn ("Metaparameter audit ignored at" <+> showPPos p) >> return r +addAttribute _ "noop" r _ = use curPos >>= \p -> warn ("Metaparameter noop ignored at" <+> showPPos p) >> return r +addAttribute _ "loglevel" r _ = use curPos >>= \p -> warn ("Metaparameter loglevel ignored at" <+> showPPos p) >> return r +addAttribute _ "schedule" r _ = use curPos >>= \p -> warn ("Metaparameter schedule ignored at" <+> showPPos p) >> return r +addAttribute _ "stage" r _ = use curPos >>= \p -> warn ("Metaparameter stage ignored at" <+> showPPos p) >> return r +addAttribute _ "tag" r (PArray v) = foldM (\cr cv -> addTagResource cr <$> resolvePValueString cv) r (toList v) +addAttribute _ "tag" r v = addTagResource r <$> resolvePValueString v +addAttribute _ "before" r d = addRelationship RBefore d r +addAttribute _ "notify" r d = addRelationship RNotify d r +addAttribute _ "require" r d = addRelationship RRequire d r +addAttribute _ "subscribe" r d = addRelationship RSubscribe d r +addAttribute b t r v = case (r ^. rattributes . at t, b) of (_, Replace) -> return (r & rattributes . at t ?~ v) (Nothing, _) -> return (r & rattributes . at t ?~ v) (_, CantReplace) -> return r @@ -696,7 +693,7 @@ allScope <- use curScope fqdn <- singleton GetNodeName let baseresource = Resource (RIdentifier rt rn) (HS.singleton rn) mempty defaultRelation allScope vrt defaulttags p fqdn - r <- foldM (addAttribute CantOverride) baseresource (itoList arg) + r <- ifoldlM (addAttribute CantOverride) baseresource arg let resid = RIdentifier rt rn case rt of "class" -> {-# SCC "rrClass" #-} do @@ -729,30 +726,31 @@ mainFunctionCall :: T.Text -> [PValue] -> InterpreterMonad [Resource] mainFunctionCall "showscope" _ = use curScope >>= warn . pretty >> return [] -- The logging functions -mainFunctionCall "alert" a = logWithModifier ALERT red a -mainFunctionCall "crit" a = logWithModifier CRITICAL red a -mainFunctionCall "debug" a = logWithModifier DEBUG dullwhite a -mainFunctionCall "emerg" a = logWithModifier EMERGENCY red a -mainFunctionCall "err" a = logWithModifier ERROR dullred a -mainFunctionCall "info" a = logWithModifier INFO green a -mainFunctionCall "notice" a = logWithModifier NOTICE white a +mainFunctionCall "alert" a = logWithModifier ALERT red a +mainFunctionCall "crit" a = logWithModifier CRITICAL red a +mainFunctionCall "debug" a = logWithModifier DEBUG dullwhite a +mainFunctionCall "emerg" a = logWithModifier EMERGENCY red a +mainFunctionCall "err" a = logWithModifier ERROR dullred a +mainFunctionCall "info" a = logWithModifier INFO green a +mainFunctionCall "notice" a = logWithModifier NOTICE white a mainFunctionCall "warning" a = logWithModifier WARNING dullyellow a -mainFunctionCall "include" includes = - fmap concat $ forM includes $ \e -> do - classname <- resolvePValueString e - loadClass classname S.Nothing mempty IncludeStandard +mainFunctionCall "include" includes = concat <$> mapM doInclude includes + where doInclude e = do + classname <- resolvePValueString e + loadClass classname S.Nothing mempty IncludeStandard mainFunctionCall "create_resources" [rtype, hs] = mainFunctionCall "create_resources" [rtype, hs, PHash mempty] mainFunctionCall "create_resources" [PString rtype, PHash hs, PHash defs] = do p <- use curPos - let genRes (rname, PHash rargs) = registerResource rtype rname (rargs <> defs) Normal p - genRes (rname, x) = throwPosError ("create_resource(): the value corresponding to key" <+> ttext rname <+> "should be a hash, not" <+> pretty x) - concat <$> mapM genRes (itoList hs) + let genRes rname (PHash rargs) = registerResource rtype rname (rargs <> defs) Normal p + genRes rname x = throwPosError ("create_resource(): the value corresponding to key" <+> ttext rname <+> "should be a hash, not" <+> pretty x) + concat . HM.elems <$> itraverse genRes hs mainFunctionCall "create_resources" args = throwPosError ("create_resource(): expects between two and three arguments, of type [string,hash,hash], and not:" <+> pretty args) mainFunctionCall "realize" args = do p <- use curPos let realiz (PResourceReference rt rn) = resMod %= (ResourceModifier rt ModifierMustMatch RealizeVirtual (REqualitySearch "title" (PString rn)) return p : ) realiz x = throwPosError ("realize(): all arguments must be resource references, not" <+> pretty x) - mapM_ realiz args >> return [] + mapM_ realiz args + return [] mainFunctionCall "tag" args = do scp <- getScopeName let addTag x = scopes . ix scp . scopeExtraTags . contains x .= True @@ -762,11 +760,9 @@ mainFunctionCall "fail" _ = throwPosError "fail(): This function takes a single argument" mainFunctionCall "hiera_include" [x] = do ndname <- resolvePValueString x - classes <- runHiera ndname ArrayMerge >>= \case - S.Just (PArray r) -> return (toList r) - _ -> return [] + classes <- toListOf (traverse . _PArray . traverse) <$> runHiera ndname ArrayMerge p <- use curPos - curPos %= (_1 . lSourceName %~ (<> " [hiera_include call]")) + curPos . _1 . lSourceName <>= " [hiera_include call]" o <- mainFunctionCall "include" classes curPos .= p return o diff --git a/Puppet/Interpreter/PrettyPrinter.hs b/Puppet/Interpreter/PrettyPrinter.hs --- a/Puppet/Interpreter/PrettyPrinter.hs +++ b/Puppet/Interpreter/PrettyPrinter.hs @@ -149,10 +149,4 @@ pretty (IsIgnoredModule m) = pf "IsIgnoredModule" [ttext m] instance Pretty LinkInformation where - pretty (LinkInformation lsrc ldst ltype lpos) = pretty lsrc <+> plt <+> pretty ldst <+> showPPos lpos - where - plt = case ltype of - RNotify -> "~>" - RRequire -> "<-" - RBefore -> "->" - RSubscribe -> "<~" + pretty (LinkInformation lsrc ldst ltype lpos) = pretty lsrc <+> pretty ltype <+> pretty ldst <+> showPPos lpos diff --git a/Puppet/Interpreter/Resolve.hs b/Puppet/Interpreter/Resolve.hs --- a/Puppet/Interpreter/Resolve.hs +++ b/Puppet/Interpreter/Resolve.hs @@ -24,7 +24,8 @@ hfGenerateAssociations, hfSetvars, hfRestorevars, - toNumbers + toNumbers, + fixResourceName ) where import Puppet.PP @@ -38,7 +39,7 @@ import Data.Version (parseVersion) import Text.ParserCombinators.ReadP (readP_to_S) -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, mapMaybe) import Data.Aeson hiding ((.=)) import Data.CaseInsensitive ( mk ) import qualified Data.Vector as V @@ -48,10 +49,8 @@ import qualified Data.Text.Encoding as T import Control.Applicative hiding ((<$>)) import Control.Monad -import Control.Monad.Error import Data.Tuple.Strict as S import Control.Lens -import Data.Maybe (mapMaybe) import Data.Aeson.Lens hiding (key) import qualified Data.Maybe.Strict as S import qualified Data.ByteString as BS @@ -68,6 +67,14 @@ -- numbers. type NumberPair = Pair Scientific Scientific +-- | Converts class resource names to lowercase (fix for the jenkins +-- plugin). +fixResourceName :: T.Text -- ^ Resource type + -> T.Text -- ^ Resource name + -> T.Text +fixResourceName "class" = T.toLower +fixResourceName _ = id + -- | A hiera helper function, that will throw all Hiera errors and log -- messages to the main monad. runHiera :: T.Text -> HieraQueryType -> InterpreterMonad (S.Maybe PValue) @@ -88,7 +95,7 @@ return o -- | The implementation of all hiera_* functions -hieraCall :: HieraQueryType -> PValue -> (Maybe PValue) -> (Maybe PValue) -> InterpreterMonad PValue +hieraCall :: HieraQueryType -> PValue -> Maybe PValue -> Maybe PValue -> InterpreterMonad PValue hieraCall _ _ _ (Just _) = throwPosError "Overriding the hierarchy is not yet supported" hieraCall qt q df _ = do qs <- resolvePValueString q @@ -140,7 +147,7 @@ -- | A simple helper that checks if a given type is native or a define. isNativeType :: T.Text -> InterpreterMonad Bool -isNativeType t = has (ix t) `fmap` (singleton GetNativeTypes) +isNativeType t = has (ix t) `fmap` singleton GetNativeTypes -- | A pure function for resolving variables. getVariable :: Container ScopeInformation -- ^ The whole scope data. @@ -149,7 +156,7 @@ -> Either Doc PValue getVariable scps scp fullvar = do (varscope, varname) <- case T.splitOn "::" fullvar of - [] -> throwError "This doesn't make any sense in resolveVariable" + [] -> Left "This doesn't make any sense in resolveVariable" [vn] -> return (scp, vn) -- Non qualified variables rst -> return (T.intercalate "::" (filter (not . T.null) (init rst)), last rst) -- qualified variables let extractVariable (varval :!: _ :!: _) = return varval @@ -158,7 +165,7 @@ Nothing -> -- check top level scope case scps ^? ix "::" . scopeVariables . ix varname of Just pp -> extractVariable pp - Nothing -> throwError ("Could not resolve variable" <+> pretty (UVariableReference fullvar) <+> "in context" <+> ttext varscope <+> "or root") + Nothing -> Left ("Could not resolve variable" <+> pretty (UVariableReference fullvar) <+> "in context" <+> ttext varscope <+> "or root") -- | A helper for numerical comparison functions. numberCompare :: Expression -> Expression -> (Scientific -> Scientific -> Bool) -> InterpreterMonad PValue @@ -276,7 +283,7 @@ rb <- resolveExpressionNumber b case rb of 0 -> throwPosError "Division by 0" - _ -> case ( (,) `fmap` preview _Integer ra <*> preview _Integer rb) of + _ -> case (,) `fmap` preview _Integer ra <*> preview _Integer rb of Just (ia, ib) -> return $ PNumber $ fromIntegral (ia `div` ib) _ -> return $ PNumber $ ra / rb resolveExpression (Multiplication a b) = binaryOperation a b (*) @@ -306,8 +313,8 @@ resolveValue (UResourceReference t e) = do r <- resolveExpressionStrings e case r of - [s] -> return (PResourceReference t s) - _ -> return (PArray (V.fromList (map (\s -> PResourceReference t s) r))) + [s] -> return (PResourceReference t (fixResourceName t s)) + _ -> return (PArray (V.fromList (map (PResourceReference t . fixResourceName t) r))) resolveValue (UArray a) = fmap PArray (V.mapM resolveExpression a) resolveValue (UHash a) = fmap (PHash . HM.fromList) (mapM resPair (V.toList a)) where @@ -391,7 +398,7 @@ t <- resolvePValueString ut -- case 1, netsted thingie nestedStuff <- use nestedDeclarations - if (has (ix (TopDefine, t)) nestedStuff) || (has (ix (TopClass, t)) nestedStuff) + if has (ix (TopDefine, t)) nestedStuff || has (ix (TopClass, t)) nestedStuff then return (PBoolean True) else do -- case 2, loadeded class lc <- use loadedClasses diff --git a/Puppet/Interpreter/Types.hs b/Puppet/Interpreter/Types.hs --- a/Puppet/Interpreter/Types.hs +++ b/Puppet/Interpreter/Types.hs @@ -29,7 +29,6 @@ import qualified Data.Traversable as TR import qualified Data.ByteString as BS import System.Log.Logger -import Data.List (foldl') import Control.Applicative hiding (empty) import Data.Time.Clock import GHC.Stack @@ -40,10 +39,8 @@ import Control.Exception import Control.Concurrent.MVar (MVar) import qualified Scripting.Lua as Lua - -#ifdef HRUBY import Foreign.Ruby -#endif +import qualified Data.Foldable as F metaparameters :: HS.HashSet T.Text metaparameters = HS.fromList ["tag","stage","name","title","alias","audit","check","loglevel","noop","schedule", "EXPORTEDSOURCE", "require", "before", "register", "notify"] @@ -245,10 +242,6 @@ instance Hashable RIdentifier --- | Relationship link type. -data LinkType = RNotify | RRequire | RBefore | RSubscribe deriving(Show, Eq,Generic) -instance Hashable LinkType - data ModifierType = ModifierCollector -- ^ For collectors, optional resources | ModifierMustMatch -- ^ For stuff like realize deriving Eq @@ -456,7 +449,6 @@ toJSON (PHash x) = Object (HM.map toJSON x) toJSON (PNumber n) = Number n -#ifdef HRUBY instance ToRuby PValue where toRuby = toRuby . toJSON instance FromRuby PValue where @@ -465,7 +457,7 @@ Just x -> case fromJSON x of Error _ -> return Nothing Success suc -> return (Just suc) -#endif + eitherDocIO :: IO (S.Either PrettyError a) -> IO (S.Either PrettyError a) eitherDocIO computation = (computation >>= check) `catch` (\e -> return $ S.Left $ PrettyError $ dullred $ text $ show (e :: SomeException)) where @@ -500,9 +492,9 @@ expandSet (ri, lts) = [(ri, lt) | lt <- HS.toList lts] -- | helper for hashmap, in case we want another kind of map .. -ifromList :: (Monoid m, At m) => [(Index m, IxValue m)] -> m +ifromList :: (Monoid m, At m, F.Foldable f) => f (Index m, IxValue m) -> m {-# INLINE ifromList #-} -ifromList = foldl' (\curm (k,v) -> curm & at k ?~ v) mempty +ifromList = F.foldl' (\curm (k,v) -> curm & at k ?~ v) mempty ikeys :: (Eq k, Hashable k) => HM.HashMap k v -> HS.HashSet k {-# INLINE ikeys #-} @@ -512,9 +504,9 @@ {-# INLINE isingleton #-} isingleton k v = mempty & at k ?~ v -ifromListWith :: (Monoid m, At m) => (IxValue m -> IxValue m -> IxValue m) -> [(Index m, IxValue m)] -> m +ifromListWith :: (Monoid m, At m, F.Foldable f) => (IxValue m -> IxValue m -> IxValue m) -> f (Index m, IxValue m) -> m {-# INLINE ifromListWith #-} -ifromListWith f = foldl' (\curmap (k,v) -> iinsertWith f k v curmap) mempty +ifromListWith f = F.foldl' (\curmap (k,v) -> iinsertWith f k v curmap) mempty iinsertWith :: At m => (IxValue m -> IxValue m -> IxValue m) -> Index m -> IxValue m -> m -> m {-# INLINE iinsertWith #-} @@ -531,12 +523,6 @@ {-# INLINE fnull #-} fnull = (== mempty) -rel2text :: LinkType -> T.Text -rel2text RNotify = "notify" -rel2text RRequire = "require" -rel2text RBefore = "before" -rel2text RSubscribe = "subscribe" - rid2text :: RIdentifier -> T.Text rid2text (RIdentifier t n) = capitalizeRT t `T.append` "[" `T.append` capn `T.append` "]" where @@ -671,16 +657,6 @@ parseJSON (String "file" ) = pure RFile parseJSON (String "line" ) = pure RLine parseJSON _ = fail "invalid field" - -instance FromJSON LinkType where - parseJSON (String "require") = pure RRequire - parseJSON (String "notify") = pure RNotify - parseJSON (String "subscribe") = pure RSubscribe - parseJSON (String "before") = pure RBefore - parseJSON _ = fail "invalid linktype" - -instance ToJSON LinkType where - toJSON = String . rel2text instance FromJSON RIdentifier where parseJSON (Object v) = RIdentifier <$> v .: "type" <*> v .: "title" diff --git a/Puppet/Lens.hs b/Puppet/Lens.hs --- a/Puppet/Lens.hs +++ b/Puppet/Lens.hs @@ -103,7 +103,7 @@ _PParse :: Prism' T.Text (V.Vector Statement) _PParse = prism dspl prs where - prs i = case runMyParser (puppetParser <* eof) "dummy" i of + prs i = case runPParser (puppetParser <* eof) "dummy" i of Left _ -> Left i Right x -> Right x dspl = T.pack . displayNocolor . ppStatements diff --git a/Puppet/NativeTypes/Helpers.hs b/Puppet/NativeTypes/Helpers.hs --- a/Puppet/NativeTypes/Helpers.hs +++ b/Puppet/NativeTypes/Helpers.hs @@ -41,6 +41,7 @@ import Control.Lens import qualified Data.Vector as V import Data.Aeson.Lens (_Number,_Integer) +import Data.Maybe (fromMaybe) type PuppetTypeName = T.Text @@ -118,9 +119,7 @@ -- | This fills the default values of unset parameters. defaultvalue :: T.Text -> T.Text -> PuppetTypeValidate -defaultvalue value param res = case res ^. rattributes . at param of - Just _ -> Right res - Nothing -> Right $ res & rattributes . at param ?~ PString value +defaultvalue value param = Right . over (rattributes . at param) (Just . fromMaybe (PString value)) -- | Checks that a given parameter, if set, is a 'ResolvedInt'. If it is a -- 'PString' it will attempt to parse it. diff --git a/Puppet/PP.hs b/Puppet/PP.hs --- a/Puppet/PP.hs +++ b/Puppet/PP.hs @@ -31,6 +31,6 @@ dropEffects (SLine l d) = SLine l (dropEffects d) dropEffects (SText v t d) = SText v t (dropEffects d) dropEffects (SChar c d) = SChar c (dropEffects d) - dropEffects SEmpty = SEmpty + dropEffects x = x diff --git a/Puppet/Parser.hs b/Puppet/Parser.hs --- a/Puppet/Parser.hs +++ b/Puppet/Parser.hs @@ -2,19 +2,24 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE FlexibleContexts #-} -module Puppet.Parser (puppetParser,expression,runMyParser) where +{-# LANGUAGE TupleSections #-} +module Puppet.Parser ( + expression + , puppetParser + , runPParser +) where 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) import Text.Regex.PCRE.ByteString.Utils import Data.Char import Control.Monad -import Control.Monad.IO.Class import Control.Applicative import Control.Lens hiding (noneOf) @@ -29,31 +34,27 @@ import Text.Parser.LookAhead import Text.Parser.Token.Highlight import Text.Parsec.Error (ParseError) -import Text.Parsec.Text () import qualified Text.Parsec.Prim as PP import Text.Parsec.Text () import Data.Scientific -newtype ParserT m a = ParserT { unParser :: m a } - deriving (Functor, Applicative, Alternative) - -deriving instance Monad m => Monad (ParserT m) -deriving instance MonadIO m => MonadIO (ParserT m) -deriving instance (Monad m, Parsing m) => Parsing (ParserT m) -deriving instance (Monad m, CharParsing m) => CharParsing (ParserT m) -deriving instance (Monad m, LookAheadParsing m) => LookAheadParsing (ParserT m) +newtype Parser a = ParserT { unParser :: PP.ParsecT T.Text () Identity a} + deriving (Functor, Applicative, Alternative) -type Parser = ParserT (PP.ParsecT T.Text () Identity) +deriving instance Monad Parser +deriving instance Parsing Parser +deriving instance CharParsing Parser +deriving instance LookAheadParsing Parser getPosition :: Parser SourcePos getPosition = ParserT PP.getPosition -runMyParser :: Parser a -> SourceName -> T.Text -> Either ParseError a -runMyParser (ParserT p) = PP.runP p () +runPParser :: Parser a -> SourceName -> T.Text -> Either ParseError a +runPParser (ParserT p) = PP.parse p type OP = PP.ParsecT T.Text () Identity -instance (CharParsing m, Monad m) => TokenParsing (ParserT m) where +instance TokenParsing Parser where someSpace = skipMany (simpleSpace <|> oneLineComment <|> multiLineComment) where simpleSpace = skipSome (satisfy isSpace) @@ -69,7 +70,7 @@ stringLiteral' :: Parser T.Text stringLiteral' = char '\'' *> interior <* symbolic '\'' where - interior = fmap (T.pack . concat) $ many (some (noneOf "'\\") <|> (char '\\' *> fmap escape anyChar)) + interior = T.pack . concat <$> many (some (noneOf "'\\") <|> (char '\\' *> fmap escape anyChar)) escape '\'' = "'" escape x = ['\\',x] @@ -92,23 +93,21 @@ variableName :: Parser T.Text variableName = do - let acceptablePart = fmap T.pack (ident identifierStyle) + let acceptablePart = T.pack <$> ident identifierStyle out <- qualif acceptablePart when (out == "string") (fail "The special variable $string should never be used") return out qualif :: Parser T.Text -> Parser T.Text qualif p = token $ do - header <- option "" (try (string "::")) - rest <- fmap (T.intercalate "::") (p `sepBy1` try (string "::")) - return (T.append (T.pack header) rest) + header <- T.pack <$> option "" (try (string "::")) + ( header <> ) . T.intercalate "::" <$> p `sepBy1` try (string "::") qualif1 :: Parser T.Text -> Parser T.Text qualif1 p = try $ do r <- qualif p - if "::" `T.isInfixOf` r - then return r - else fail "This parser is not qualified" + unless ("::" `T.isInfixOf` r) (fail "This parser is not qualified") + return r className :: Parser T.Text className = qualif moduleName @@ -136,7 +135,7 @@ -- this is not a token ! inBraces :: Parser T.Text -inBraces = between (char '{') (char '}') (fmap T.pack (some (satisfy (/= '}')))) +inBraces = between (char '{') (char '}') (T.pack <$> some (satisfy (/= '}'))) variableReference :: Parser T.Text variableReference = do @@ -148,10 +147,10 @@ return v interpolableString :: Parser (V.Vector UValue) -interpolableString = fmap V.fromList $ between (char '"') (symbolic '"') $ - many (fmap UVariableReference interpolableVariableReference <|> doubleQuotedStringContent <|> fmap (UString . T.singleton) (char '$')) +interpolableString = V.fromList <$> between (char '"') (symbolic '"') + ( many (fmap UVariableReference interpolableVariableReference <|> doubleQuotedStringContent <|> fmap (UString . T.singleton) (char '$')) ) where - doubleQuotedStringContent = fmap (UString . T.pack . concat) $ + doubleQuotedStringContent = UString . T.pack . concat <$> some ((char '\\' *> fmap stringEscape anyChar) <|> some (noneOf "\"\\$")) stringEscape :: Char -> String stringEscape 'n' = "\n" @@ -163,7 +162,7 @@ stringEscape x = ['\\',x] -- this is specialized because we can't be "tokenized" here variableAccept x = isAsciiLower x || isAsciiUpper x || isDigit x || x == '_' - interpolableVariableReference = do + interpolableVariableReference = try $ do void (char '$') v <- lookAhead anyChar >>= \case '{' -> inBraces @@ -171,16 +170,15 @@ -- implementation, but considerably shorter. -- -- This needs refactoring. - _ -> fmap (T.pack . concat) (some (string "::" <|> some (satisfy variableAccept))) + _ -> T.pack . concat <$> some (string "::" <|> some (satisfy variableAccept)) when (v == "string") (fail "The special variable $string must not be used") return v regexp :: Parser T.Text regexp = do void (char '/') - v <- many ( do { void (char '\\') ; x <- anyChar; return ['\\', x] } <|> some (noneOf "/\\") ) - void $ symbolic '/' - return $! T.pack $! concat v + T.pack . concat <$> many ( do { void (char '\\') ; x <- anyChar; return ['\\', x] } <|> some (noneOf "/\\") ) + <* symbolic '/' puppetArray :: Parser UValue puppetArray = fmap (UArray . V.fromList) (brackets (expression `sepEndBy` comma)) "Array" @@ -188,15 +186,13 @@ puppetHash :: Parser UValue puppetHash = fmap (UHash . V.fromList) (braces (hashPart `sepEndBy` comma)) "Hash" where - hashPart = do - -- a special case for "default" because of the ? selector ... - a <- expression - void $ operator "=>" - b <- expression - return (a :!: b) + hashPart = (:!:) <$> (expression <* operator "=>") + <*> expression puppetBool :: Parser Bool -puppetBool = (reserved "true" >> return True) <|> (reserved "false" >> return False) "Boolean" +puppetBool = (reserved "true" >> return True) + <|> (reserved "false" >> return False) + "Boolean" resourceReferenceRaw :: Parser (T.Text, [Expression]) resourceReferenceRaw = do @@ -207,9 +203,9 @@ resourceReference :: Parser UValue resourceReference = do (restype, resnames) <- resourceReferenceRaw - return $ case resnames of - [x] -> UResourceReference restype x - _ -> UResourceReference restype (PValue (array resnames)) + return $ UResourceReference restype $ case resnames of + [x] -> x + _ -> PValue (array resnames) bareword :: Parser T.Text bareword = identl (satisfy isAsciiLower) (satisfy acceptable) "Bare word" @@ -360,15 +356,14 @@ return [Node n st inheritance (p :!: pe) | n <- ns] puppetClassParameters :: Parser (V.Vector (Pair T.Text (S.Maybe Expression))) -puppetClassParameters = fmap V.fromList $ parens (var `sepEndBy` comma) +puppetClassParameters = V.fromList <$> parens (var `sepEndBy` comma) where toStrictMaybe (Just x) = S.Just x toStrictMaybe Nothing = S.Nothing var :: Parser (Pair T.Text (S.Maybe Expression)) - var = do - vname <- variableReference - value <- fmap toStrictMaybe $ optional (symbolic '=' *> expression) - return $ vname :!: value + var = (:!:) + <$> variableReference + <*> (toStrictMaybe <$> optional (symbolic '=' *> expression)) defineStmt :: Parser [Statement] defineStmt = do @@ -421,7 +416,7 @@ compares <- expression `sepBy1` comma void $ symbolic ':' stmts <- braces statementList - return [ (cmp, stmts) | cmp <- compares ] + return $ map (,stmts) compares condsToExpression e (x, stmts) = f x :!: stmts where f = case x of (PValue (UBoolean _)) -> id @@ -434,16 +429,63 @@ pe <- getPosition return [ ConditionalStatement (V.fromList (map (condsToExpression expr1) (concat condlist))) (p :!: pe) ] -resourceGroup :: Parser [Statement] -resourceGroup = do - groups <- resourceGroup' `sepBy1` operator "->" +data OperatorChain a = OperatorChain a LinkType (OperatorChain a) + | EndOfChain a + +instance F.Foldable OperatorChain where + foldMap f (EndOfChain x) = f x + foldMap f (OperatorChain a _ nx) = f a <> F.foldMap f nx + +operatorChainStatement :: OperatorChain a -> a +operatorChainStatement (OperatorChain a _ _) = a +operatorChainStatement (EndOfChain x) = x + +zipChain :: OperatorChain a -> [ ( a, a, LinkType ) ] +zipChain (OperatorChain a d nx) = (a, operatorChainStatement nx, d) : zipChain nx +zipChain (EndOfChain _) = [] + +depOperator :: Parser LinkType +depOperator = (operator "->" *> pure RBefore) + <|> (operator "~>" *> pure RNotify) + +-- | Used to parse chains of resource relations +parseRelationships :: Parser a -> Parser (OperatorChain a) +parseRelationships p = do + g <- p + o <- optional depOperator + case o of + Just o' -> OperatorChain g o' <$> parseRelationships p + Nothing -> pure (EndOfChain g) + +statementRelationships :: Parser [Statement] -> Parser [Statement] +statementRelationships p = do + rels <- parseRelationships p let relations = do - (g1, g2) <- zip groups (tail groups) - ResourceDeclaration rt1 rn1 _ _ (_ :!: pe1) <- g1 - ResourceDeclaration rt2 rn2 _ _ (ps2 :!: _) <- g2 - return (Dependency (rt1 :!: rn1) (rt2 :!: rn2) (pe1 :!: ps2)) - return $ concat groups ++ relations + (g1, g2, lt) <- zipChain rels + ResourceDeclaration rt1 rn1 _ _ (_ :!: pe1) <- g1 + ResourceDeclaration rt2 rn2 _ _ (ps2 :!: _) <- g2 + return (Dependency (rt1 :!: rn1) (rt2 :!: rn2) lt (pe1 :!: ps2)) + return $ mconcat (F.toList rels) <> relations +startDepChains :: Position -> T.Text -> [Expression] -> Parser [Statement] +startDepChains p restype resnames = do + d <- depOperator + groups <- zipChain . OperatorChain (restype, resnames) d <$> parseRelationships resourceReferenceRaw + pe <- getPosition + return $ do + ((rt, rns), (dt, dns), lt) <- groups + rn <- rns + dn <- dns + return (Dependency (rt :!: rn) (dt :!: dn) lt (p :!: pe)) + +rrGroupRef :: Position -> T.Text -> Parser [Statement] +rrGroupRef p restype = do + resnames <- brackets (expression `sepBy1` comma) "Resource reference values" + startDepChains p restype resnames <|> resourceOverride p restype resnames + +resourceGroup :: Parser [Statement] +resourceGroup = statementRelationships resourceGroup' + resourceGroup' :: Parser [Statement] resourceGroup' = do let resourceName = token stringExpression @@ -480,7 +522,7 @@ resourceOverride :: Position -> T.Text -> [Expression] -> Parser [Statement] resourceOverride p restype names = do - assignments <- fmap V.fromList $ braces (assignment `sepEndBy` comma) + assignments <- V.fromList <$> braces (assignment `sepEndBy` comma) pe <- getPosition return [ ResourceOverride restype n assignments (p :!: pe) | n <- names ] @@ -489,14 +531,14 @@ searchExpression = parens searchExpression <|> check <|> combine where combine = do - e1 <- parens searchExpression <|> check + e1 <- parens searchExpression <|> check opr <- (operator "and" *> return AndSearch) <|> (operator "or" *> return OrSearch) - e2 <- searchExpression + e2 <- searchExpression return (opr e1 e2) check = do attrib <- parameterName - opr <- (operator "==" *> return EqualitySearch) <|> (operator "!=" *> return NonEqualitySearch) - term <- stringExpression + opr <- (operator "==" *> return EqualitySearch) <|> (operator "!=" *> return NonEqualitySearch) + term <- stringExpression return (opr attrib term) resourceCollection :: Position -> T.Text -> Parser [Statement] @@ -519,12 +561,12 @@ classDefinition = do p <- getPosition reserved "class" - classname <- className - params <- option V.empty puppetClassParameters - inheritance <- option S.Nothing (fmap S.Just (reserved "inherits" *> className)) - st <- braces statementList - pe <- getPosition - return [ ClassDeclaration classname params inheritance st (p :!: pe) ] + x <- ClassDeclaration <$> className + <*> option V.empty puppetClassParameters + <*> option S.Nothing (fmap S.Just (reserved "inherits" *> className)) + <*> braces statementList + <*> ( (p :!:) <$> getPosition ) + return [x] mainFunctionCall :: Parser [Statement] mainFunctionCall = do @@ -533,20 +575,6 @@ pe <- getPosition return [ MainFunctionCall fname args (p :!: pe) ] -startDepChains :: Position -> T.Text -> [Expression] -> Parser [Statement] -startDepChains p restype resnames = do - operator "->" - -- FIXME positions - nxts <- resourceReferenceRaw `sepBy` operator "->" - pe <- getPosition - let refs = (restype, resnames) : nxts - return [ Dependency (rt :!: rn) (dt :!: dn) (p :!: pe) | ((rt, rns), (dt,dns)) <- zip refs (tail refs), rn <- rns, dn <- dns ] - -rrGroupRef :: Position -> T.Text -> Parser [Statement] -rrGroupRef p restype = do - resnames <- brackets (expression `sepBy1` comma) "Resource reference values" - startDepChains p restype resnames <|> resourceOverride p restype resnames - rrGroup :: Parser [Statement] rrGroup = do p <- getPosition @@ -615,7 +643,7 @@ parseHParams :: Parser BlockParameters parseHParams = between (symbolic '|') (symbolic '|') hp where - acceptablePart = fmap T.pack (ident identifierStyle) + acceptablePart = T.pack <$> ident identifierStyle hp = do vars <- (char '$' *> acceptablePart) `sepBy1` comma case vars of @@ -632,4 +660,3 @@ <*> parseHParams <*> (symbolic '{' *> fmap (V.fromList . concat) (many (try statement))) <*> fmap toStrict (optional expression) <* symbolic '}' - diff --git a/Puppet/Parser/PrettyPrinter.hs b/Puppet/Parser/PrettyPrinter.hs --- a/Puppet/Parser/PrettyPrinter.hs +++ b/Puppet/Parser/PrettyPrinter.hs @@ -111,6 +111,12 @@ pretty SelectorDefault = dullmagenta (text "default") pretty (SelectorValue v) = pretty v +instance Pretty LinkType where + pretty RNotify = "~>" + pretty RRequire = "<-" + pretty RBefore = "->" + pretty RSubscribe = "<~" + showPos :: Position -> Doc showPos p = green (char '#' <+> string (show p)) @@ -181,7 +187,7 @@ inheritance = case i of S.Nothing -> empty S.Just n -> empty <+> text "inherits" <+> pretty n - pretty (Dependency (st :!: sn) (dt :!: dn) p) = pretty (UResourceReference st sn) <+> text "->" <+> pretty (UResourceReference dt dn) <+> showPPos p + pretty (Dependency ( st :!: sn) (dt :!: dn) lt p) = pretty (UResourceReference st sn) <+> pretty lt <+> pretty (UResourceReference dt dn) <+> showPPos p pretty (TopContainer a b) = text "TopContainer:" <+> braces ( nest 2 (string "TOP" <$> braceStatements a <$> string "STATEMENT" <$> pretty b)) pretty (ResourceCollection coltype restype search overrides p) = capitalize restype <> enc (pretty search) <+> overs where diff --git a/Puppet/Parser/Types.hs b/Puppet/Parser/Types.hs --- a/Puppet/Parser/Types.hs +++ b/Puppet/Parser/Types.hs @@ -15,6 +15,7 @@ capitalizeRT, array, toBool, + rel2text, -- * Types -- ** Expressions Expression(..), @@ -27,6 +28,7 @@ CollectorType(..), Virtuality(..), NodeDesc(..), + LinkType(..), -- ** Search Expressions SearchExpression(..), -- ** Statements @@ -35,6 +37,7 @@ import qualified Data.Text as T import qualified Data.Vector as V +import Data.Hashable import Data.Tuple.Strict import qualified Data.Maybe.Strict as S import GHC.Generics @@ -43,6 +46,7 @@ import Control.Lens import Data.String import Data.Scientific +import Data.Aeson import Text.Parsec.Pos @@ -226,6 +230,27 @@ (==) (NodeMatch a _) (NodeMatch b _) = a == b (==) _ _ = False + +-- | Relationship link type. +data LinkType = RNotify | RRequire | RBefore | RSubscribe deriving(Show, Eq,Generic) +instance Hashable LinkType + +rel2text :: LinkType -> T.Text +rel2text RNotify = "notify" +rel2text RRequire = "require" +rel2text RBefore = "before" +rel2text RSubscribe = "subscribe" + +instance FromJSON LinkType where + parseJSON (String "require") = return RRequire + parseJSON (String "notify") = return RNotify + parseJSON (String "subscribe") = return RSubscribe + parseJSON (String "before") = return RBefore + parseJSON _ = fail "invalid linktype" + +instance ToJSON LinkType where + toJSON = String . rel2text + -- | All the possible statements data Statement = ResourceDeclaration !T.Text !Expression !(V.Vector (Pair T.Text Expression)) !Virtuality !PPosition @@ -239,7 +264,7 @@ | MainFunctionCall !T.Text !(V.Vector Expression) !PPosition | SHFunctionCall !HFunctionCall !PPosition -- ^ /Higher order function/ call. | ResourceCollection !CollectorType !T.Text !SearchExpression !(V.Vector (Pair T.Text Expression)) !PPosition -- ^ For all types of collectors. - | Dependency !(Pair T.Text Expression) !(Pair T.Text Expression) !PPosition + | Dependency !(Pair T.Text Expression) !(Pair T.Text Expression) !LinkType !PPosition | TopContainer !(V.Vector Statement) !Statement -- ^ This is a special statement that is used to include the expressions that are top level. This is certainly buggy, but probably just like the original implementation. deriving Eq diff --git a/Puppet/Stdlib.hs b/Puppet/Stdlib.hs --- a/Puppet/Stdlib.hs +++ b/Puppet/Stdlib.hs @@ -11,7 +11,9 @@ import Data.Char import Data.Monoid import Control.Monad +import Data.Vector.Lens import Text.Regex.PCRE.ByteString.Utils +import Data.Traversable (for) import qualified Data.Vector as V import qualified Data.HashMap.Strict as HM import qualified Data.Text as T @@ -34,9 +36,11 @@ , ("delete_at", deleteAt) , singleArgument "delete_undef_values" deleteUndefValues , ("downcase", stringArrayFunction T.toLower) + , singleArgument "empty" _empty , singleArgument "flatten" flatten , singleArgument "getvar" getvar , ("getparam", const $ throwPosError "The getparam function is uncool and shall not be implemented in language-puppet") + , ("grep", _grep) , singleArgument "is_array" isArray , singleArgument "is_domain_name" isDomainName , singleArgument "is_integer" isInteger @@ -85,8 +89,7 @@ matchRE :: Regex -> T.Text -> InterpreterMonad Bool matchRE r t = case execute' r (T.encodeUtf8 t) of Left rr -> throwPosError ("Could not match:" <+> string (show rr)) - Right Nothing -> return False - Right (Just _) -> return True + Right m -> return (has _Just m) puppetAbs :: PValue -> InterpreterMonad PValue puppetAbs y = case y ^? _Number of @@ -148,9 +151,7 @@ puppetCount _ = throwPosError "count(): expects 1 or 2 arguments" delete :: [PValue] -> InterpreterMonad PValue -delete [PString x, y] = do - ty <- resolvePValueString y - return $ PString $ T.concat $ T.splitOn ty x +delete [PString x, y] = fmap (PString . T.concat . (`T.splitOn` x)) (resolvePValueString y) delete [PArray r, z] = return $ PArray $ V.filter (/= z) r delete [PHash h, z] = do tz <- resolvePValueString z @@ -177,6 +178,9 @@ deleteUndefValues (PHash h) = return $ PHash $ HM.filter (/= PUndef) h deleteUndefValues x = throwPosError ("delete_undef_values(): Expects an Array or a Hash, not" <+> pretty x) +_empty :: PValue -> InterpreterMonad PValue +_empty = return . PBoolean . flip elem [PUndef, PString "", PString "undef", PArray V.empty, PHash HM.empty] + flatten :: PValue -> InterpreterMonad PValue flatten r@(PArray _) = return $ PArray (flatten' r) where @@ -188,9 +192,19 @@ getvar :: PValue -> InterpreterMonad PValue getvar = resolvePValueString >=> resolveVariable +_grep :: [PValue] -> InterpreterMonad PValue +_grep [PArray vls, rawre] = do + regexp <- resolvePValueString rawre >>= compileRE + rvls <- for vls $ \v -> do + r <- resolvePValueString v + ismatched <- matchRE regexp r + return (r, ismatched) + return $ PArray $ (V.map (PString . fst) (V.filter snd rvls)) +_grep [x,_] = throwPosError ("grep(): The first argument must be an Array, not" <+> pretty x) +_grep _ = throwPosError "grep(): Expected two arguments." + isArray :: PValue -> InterpreterMonad PValue -isArray (PArray _) = return (PBoolean True) -isArray _ = return (PBoolean False) +isArray = return . PBoolean . has _PArray isDomainName :: PValue -> InterpreterMonad PValue isDomainName s = do @@ -302,5 +316,5 @@ validateString x = mapM_ resolvePValueString x >> return PUndef pvalues :: PValue -> InterpreterMonad PValue -pvalues (PHash h) = return $ PArray (V.fromList (h ^.. traverse)) +pvalues (PHash h) = return $ PArray (toVectorOf traverse h) pvalues x = throwPosError ("values(): expected a hash, not" <+> pretty x) diff --git a/Puppet/Testing.hs b/Puppet/Testing.hs --- a/Puppet/Testing.hs +++ b/Puppet/Testing.hs @@ -21,6 +21,7 @@ , lPuppetdir , withResource , withParameter + , withParameters , withFileContent ) where @@ -140,6 +141,12 @@ case r ^. rattributes . at prm of Nothing -> H.expectationFailure ("Parameter " ++ T.unpack prm ++ " not found") Just v -> o v + +-- | Test a serie of parameters +withParameters :: [(T.Text, PValue)] -- ^ The parameter names and values + -> Resource -- ^ The resource to test + -> H.Expectation +withParameters prmlist r = forM_ prmlist $ \(nm, vl) -> withParameter nm r (`H.shouldBe` vl) -- | Retrieves a given file content, and runs a test on it. It works on the -- explicit "content" parameter, or can resolve the "source" parameter to 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: 0.14.0 +version: 1.0.0 synopsis: Tools to parse and evaluate the Puppet DSL. description: This is a set of tools that is supposed to fill all your Puppet needs : syntax checks, catalog compilation, PuppetDB queries, simulationg of complex interactions between nodes, Puppet master replacement, and more ! homepage: http://lpuppet.banquise.net/ @@ -24,9 +24,6 @@ location: git://github.com/bartavelle/language-puppet.git -Flag Hruby - Description: Using the hruby library to speed things up (if it is installed) - library exposed-modules: Puppet.Parser.Types , Puppet.Parser @@ -74,14 +71,11 @@ , Puppet.Plugins , Puppet.Interpreter.RubyRandom extensions: OverloadedStrings, BangPatterns - if flag(hruby) - Build-depends: hruby >= 0.2.5 && <0.3 - CPP-Options: -DHRUBY - ghc-options: -Wall -funbox-strict-fields ghc-prof-options: -auto-all -caf-all -- other-modules: build-depends: base >=4.6 && < 4.8 + , hruby >= 0.2.5 && <0.3 , bytestring , strict-base-types >= 0.2.2 , hashable == 1.2.* @@ -90,7 +84,7 @@ , vector == 0.10.* , parsec == 3.1.* , mtl == 2.1.* - , lens >= 4 && < 4.2 + , lens >= 4 && < 4.4 , parsers == 0.11.* , ansi-wl-pprint == 0.6.* , unix >= 2.6 && < 2.8 @@ -118,6 +112,7 @@ , stateWriter >= 0.2.1 && < 0.3 , split == 0.2.* , scientific >= 0.2 && < 0.4 + , directory == 1.2.* , operational Test-Suite test-evals diff --git a/progs/PuppetResources.hs b/progs/PuppetResources.hs --- a/progs/PuppetResources.hs +++ b/progs/PuppetResources.hs @@ -1,105 +1,4 @@ {-# LANGUAGE LambdaCase #-} -{-| - -Horrible and hackish ... but damn useful. This can be used as a standalone -executable or a ghci script for interactive usage. It comes with a sample Puppet -site (that I hope will gets more realistic later). - -When given a single argument, it will try to parse the given file, and will -print the parsed values : - -> $ puppetresources samplesite/manifests/site.pp -> node test.nod { -> apt::builddep { Interpolable [Literal "glusterfs-server"]: -> ; -> } -> ... - -With two arguments, it will try to compute the catalog for a given node. The -first argument must be the path to the Puppet directory and the second the -name of the node. Note that regexp node names do not work yet. - -> $ puppetresources samplesite test.nod -> The defined() function is not implemented for resource references. Returning true at "samplesite/modules/apt/manifests/ppa.pp" (line 20, column 3) -> The defined() function is not implemented for resource references. Returning true at "samplesite/modules/apt/manifests/key.pp" (line 38, column 7) -> The defined() function is not implemented for resource references. Returning true at "samplesite/modules/apt/manifests/key.pp" (line 42, column 7) -> anchor { -> "apt::builddep::glusterfs-server": #"samplesite/modules/apt/manifests/builddep.pp" (line 12, column 12) -> name => "apt::builddep::glusterfs-server"; -> "apt::key/Add key: 55BE302B from Apt::Source debian_unstable": #"samplesite/modules/apt/manifests/key.pp" (line 32, column 16) -> name => "apt::key/Add key: 55BE302B from Apt::Source debian_unstable"; -> ... - -When adding a file name as the third argument to the previous invocation, it -will display the value of the /content/ attribute of the named /file/ resource. - -> $ puppetresources samplesite test.nod karmic.pref -> The defined() function is not implemented for resource references. Returning true at "samplesite/modules/apt/manifests/ppa.pp" (line 20, column 3) -> The defined() function is not implemented for resource references. Returning true at "samplesite/modules/apt/manifests/key.pp" (line 38, column 7) -> The defined() function is not implemented for resource references. Returning true at "samplesite/modules/apt/manifests/key.pp" (line 42, column 7) -> # karmic -> Package: * -> Pin: release a=karmic -> Pin-Priority: 700 - -You can also just use a resource name : - -> $ puppetresources samplesite test.nod 'exec[apt_update]' -> exec { -> "apt_update": #"samplesite/modules/apt/manifests/update.pp" (line 4, column 10) -> command => "/usr/bin/apt-get update", -> logoutput => "false", -> refreshonly => "true", -> returns => 0, -> timeout => 300, -> tries => 1, -> try_sleep => 0; -> } - -With GHCI there are tons of things you can do. First initialize it - ->>> queryfunc <- initializedaemon "./samplesite/" - -You can now compute catalogs for various nodes. - ->>> c1 <- queryfunc "test.nod" -The defined() function is not implemented for resource references. Returning true at "./samplesite//modules/apt/manifests/ppa.pp" (line 20, column 3) -The defined() function is not implemented for resource references. Returning true at "./samplesite//modules/apt/manifests/key.pp" (line 38, column 7) -The defined() function is not implemented for resource references. Returning true at "./samplesite//modules/apt/manifests/key.pp" (line 42, column 7) ->>> c2 <- queryfunc "test2.nod" -The defined() function is not implemented for resource references. Returning true at "./samplesite//modules/apt/manifests/ppa.pp" (line 20, column 3) -The defined() function is not implemented for resource references. Returning true at "./samplesite//modules/apt/manifests/key.pp" (line 38, column 7) -The defined() function is not implemented for resource references. Returning true at "./samplesite//modules/apt/manifests/key.pp" (line 42, column 7) - -And you can check what the difference is between catalogs. - ->>> diff c1 c2 -file[karmic-updates.pref] { -# content - + Pin-Priority: 750 - - Pin-Priority: 700 -} - -You also can manipulate catalogs. - ->>> Map.size c1 -25 ->>> mapM_ print $ Map.toList $ Map.map (length . lines . (\x -> case x of (PString n) -> n) .fromJust . Map.lookup "content" . rrattributes) $ Map.filter (Map.member "content" . rrattributes) c1 -(("file","debian_unstable.list"),3) -(("file","debian_unstable.pref"),4) -(("file","karmic-security.pref"),4) -(("file","karmic-updates.pref"),4) -(("file","karmic.pref"),4) - -A typical usage of this tool is to compute a reference catalog, and then check the differences as you alter it. This can be done this way : - ->>> reference <- queryfunc "test.nod" - -And then run the following command every time you need to verify your changes are correct : - ->>> queryfunc "test.nod" >>= diff reference - --} module Main where import System.IO @@ -171,7 +70,7 @@ return (f, _dParserStats q, _dCatalogStats q, _dTemplateStats q) parseFile :: FilePath -> IO (Either P.ParseError (V.Vector Statement)) -parseFile fp = fmap (runMyParser puppetParser fp) (T.readFile fp) +parseFile fp = fmap (runPParser puppetParser fp) (T.readFile fp) printContent :: T.Text -> FinalCatalog -> IO () printContent filename catalog = diff --git a/tests/evals.hs b/tests/evals.hs --- a/tests/evals.hs +++ b/tests/evals.hs @@ -25,7 +25,7 @@ main :: IO () main = do let check :: T.Text -> Either String () - check t = case runMyParser (expression <* eof) "dummy" t of + check t = case runPParser (expression <* eof) "dummy" t of Left rr -> Left (T.unpack t ++ " -> " ++ show rr) Right e -> case dummyEval (resolveExpression e) of Right (PBoolean True) -> Right () diff --git a/tests/expr.hs b/tests/expr.hs --- a/tests/expr.hs +++ b/tests/expr.hs @@ -21,7 +21,7 @@ main :: IO () main = do - let testres = map (\(a,b) -> (runMyParser (expression <* eof) "tests" a, b)) testcases + let testres = map (\(a,b) -> (runPParser (expression <* eof) "tests" a, b)) 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 @@ -25,7 +25,7 @@ -- returns errors testparser :: FilePath -> IO (String, Bool) testparser fp = do - fmap (runMyParser puppetParser fp) (T.readFile fp) >>= \case + fmap (runPParser puppetParser fp) (T.readFile fp) >>= \case Right _ -> return ("PASS", True) Left rr -> return (show rr, False) @@ -33,7 +33,7 @@ check fname = do putStr fname putStr ": " - res <- fmap (runMyParser puppetParser fname) (T.readFile fname) + res <- fmap (runPParser puppetParser fname) (T.readFile fname) is <- queryTerminal (Fd 1) let rfunc = if is then renderPretty 0.2 200