language-puppet 0.14.0 → 1.0.0
raw patch · 20 files changed
+352/−467 lines, 20 filesdep +directorydep ~lens
Dependencies added: directory
Dependency ranges changed: lens
Files
- Erb/Compute.hs +1/−87
- Facter.hs +35/−0
- Puppet/Daemon.hs +1/−10
- Puppet/Interpreter.hs +104/−108
- Puppet/Interpreter/PrettyPrinter.hs +1/−7
- Puppet/Interpreter/Resolve.hs +19/−12
- Puppet/Interpreter/Types.hs +6/−30
- Puppet/Lens.hs +1/−1
- Puppet/NativeTypes/Helpers.hs +2/−3
- Puppet/PP.hs +1/−1
- Puppet/Parser.hs +110/−83
- Puppet/Parser/PrettyPrinter.hs +7/−1
- Puppet/Parser/Types.hs +26/−1
- Puppet/Stdlib.hs +22/−8
- Puppet/Testing.hs +7/−0
- language-puppet.cabal +4/−9
- progs/PuppetResources.hs +1/−102
- tests/evals.hs +1/−1
- tests/expr.hs +1/−1
- tests/lexer.hs +2/−2
Erb/Compute.hs view
@@ -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
Facter.hs view
@@ -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
Puppet/Daemon.hs view
@@ -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--
Puppet/Interpreter.hs view
@@ -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
Puppet/Interpreter/PrettyPrinter.hs view
@@ -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
Puppet/Interpreter/Resolve.hs view
@@ -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
Puppet/Interpreter/Types.hs view
@@ -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"
Puppet/Lens.hs view
@@ -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
Puppet/NativeTypes/Helpers.hs view
@@ -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.
Puppet/PP.hs view
@@ -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
Puppet/Parser.hs view
@@ -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 '}'-
Puppet/Parser/PrettyPrinter.hs view
@@ -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
Puppet/Parser/Types.hs view
@@ -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
Puppet/Stdlib.hs view
@@ -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)
Puppet/Testing.hs view
@@ -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
language-puppet.cabal view
@@ -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
progs/PuppetResources.hs view
@@ -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 =
tests/evals.hs view
@@ -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 ()
tests/expr.hs view
@@ -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
tests/lexer.hs view
@@ -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