language-puppet 0.4.0 → 0.4.2
raw patch · 8 files changed
+418/−244 lines, 8 filesdep +hrubydep +lens
Dependencies added: hruby, lens
Files
- Erb/Compute.hs +80/−21
- Erb/Evaluate.hs +1/−1
- Puppet/Interpreter/Catalog.hs +181/−173
- Puppet/Interpreter/Functions.hs +3/−2
- Puppet/Interpreter/RubyRandom.hs +1/−1
- Puppet/Interpreter/Types.hs +80/−43
- language-puppet.cabal +10/−3
- ruby/hrubyerb.rb +62/−0
Erb/Compute.hs view
@@ -1,13 +1,11 @@+{-# LANGUAGE CPP, ForeignFunctionInterface #-} module Erb.Compute(computeTemplate, getTemplateFile, initTemplateDaemon) where import Puppet.Interpreter.Types import Puppet.Init import Puppet.Stats import Puppet.Utils-import SafeProcess -import Data.List-import System.IO import Control.Monad.Error import Control.Concurrent import System.Posix.Files@@ -18,20 +16,46 @@ import Debug.Trace import qualified System.Log.Logger as LOG import qualified Data.Text as T+import Text.Parsec++#ifdef HRUBY+import Foreign+import Foreign.Ruby++type RegisteredGetvariable = RValue -> RValue -> RValue -> RValue -> IO RValue+foreign import ccall "wrapper" mkRegisteredGetvariable :: RegisteredGetvariable -> IO (FunPtr RegisteredGetvariable)++#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.Text.Lazy.Builder.Int as T-import Text.Parsec import qualified Data.Foldable as F+#endif type TemplateQuery = (Chan TemplateAnswer, Either T.Text T.Text, T.Text, Map.Map T.Text GeneralValue) type TemplateAnswer = Either String T.Text ++ initTemplateDaemon :: Prefs -> MStats -> IO (Either T.Text T.Text -> T.Text -> Map.Map T.Text GeneralValue -> IO (Either String T.Text)) initTemplateDaemon (Prefs _ modpath templatepath _ _ ps _ _) mvstats = do controlchan <- newChan+#ifdef HRUBY+ initialize+ s <- (getRubyScriptPath "hrubyerb.rb" >>= \p -> rb_load_protect p 0)+ unless (s == 0) $ do+ msg <- showErrorStack+ error msg+ rubyResolveFunction <- mkRegisteredGetvariable hrresolveVariable+ rb_define_global_function "varlookup" rubyResolveFunction 3+ forkIO (templateDaemon modpath templatepath controlchan mvstats)+#else replicateM_ ps (forkIO (templateDaemon modpath templatepath controlchan mvstats))+#endif return (templateQuery controlchan) templateQuery :: Chan TemplateQuery -> Either T.Text T.Text -> T.Text -> Map.Map T.Text GeneralValue -> IO (Either String T.Text)@@ -77,14 +101,62 @@ LOG.debugM "Erb.Compute" msg measure mstats ("ruby efail - " <> filename) $ computeTemplateWRuby fileinfo curcontext variables +getTemplateFile :: T.Text -> CatalogMonad T.Text+getTemplateFile = throwError++getRubyScriptPath :: String -> IO String+getRubyScriptPath rubybin = do+ cabalPath <- getDataFileName $ "ruby/" ++ rubybin :: IO FilePath+ exists <- fileExist cabalPath+ if exists+ then return cabalPath+ else do+ path <- fmap (T.unpack . takeDirectory . T.pack) mGetExecutablePath+ let fullpath = path <> "/" <> rubybin+ lexists <- fileExist cabalPath+ return $ if lexists+ then fullpath+ else rubybin++#ifdef HRUBY+hrresolveVariable :: RValue -> RValue -> RValue -> RValue -> IO RValue+-- T.Text -> Map.Map T.Text GeneralValue -> RValue -> RValue -> IO RValue+hrresolveVariable _ rscope rvariables rtoresolve = do+ scope <- extractHaskellValue rscope+ variables <- extractHaskellValue rvariables+ toresolve <- fromRuby rtoresolve+ let answer = case toresolve of+ Just t -> getVariable variables scope t+ _ -> Left "The variable name is not a string"+ case answer of+ Left _ -> getSymbol "undef"+ Right r -> toRuby r++computeTemplateWRuby :: Either T.Text T.Text -> T.Text -> Map.Map T.Text GeneralValue -> IO TemplateAnswer+computeTemplateWRuby fileinfo curcontext variables = freezeGC $ do+ rscope <- embedHaskellValue curcontext+ rvariables <- embedHaskellValue variables+ o <- case fileinfo of+ Right fname -> do+ rfname <- toRuby fname+ safeMethodCall "Controller" "runFromFile" [rfname,rscope,rvariables]+ Left content -> toRuby content >>= safeMethodCall "Controller" "runFromContent" . (:[])+ freeHaskellValue rvariables+ freeHaskellValue rscope+ case o of+ Left (rr, _) -> return (Left rr)+ Right r -> fromRuby r >>= \x -> case x of+ Just result -> return (Right result)+ Nothing -> return (Left "Could not deserialiaze ruby output")++#else saveTmpContent :: T.Text -> IO FilePath saveTmpContent cnt = do (name, h) <- openTempFile "/tmp" "inline_template.erb"- T.putStrLn cnt hClose h return name -computeTemplateWRuby :: Either T.Text T.Text -> T.Text -> Map.Map T.Text GeneralValue -> IO TemplateAnswer+computeTemplateWRuby :: Either T.Text T.Text -> T.Text -> Map.Map T.Text GeneralValue -> Maybe (FunPtr RegisteredGetvariable) -> IO TemplateAnswer computeTemplateWRuby fileinfo curcontext variables = do (temp, filename) <- case fileinfo of Right x -> return (Nothing, x)@@ -94,19 +166,7 @@ let rubyvars = "{\n" <> mconcat (intersperse ",\n" (concatMap toRuby (Map.toList variables))) <> "\n}\n" :: T.Builder input = T.fromText curcontext <> "\n" <> T.fromText filename <> "\n" <> rubyvars :: T.Builder ufilename = T.unpack filename- rubyscriptpath <- do- let rubybin = "calcerb.rb"- cabalPath <- getDataFileName $ "ruby/" ++ T.unpack rubybin- exists <- fileExist cabalPath- if exists- then return cabalPath- else do- path <- fmap (takeDirectory . T.pack) mGetExecutablePath- let fullpath = path <> "/" <> rubybin- lexists <- fileExist cabalPath- return $ T.unpack $ if lexists- then fullpath- else rubybin+ rubyscriptpath <- getRubyScriptPath "calcerb.rb" traceEventIO ("start running ruby" ++ ufilename) !ret <- safeReadProcessTimeout "ruby" [rubyscriptpath] (T.toLazyText input) 1000 traceEventIO ("finished running ruby" ++ ufilename)@@ -127,8 +187,6 @@ where minterc' !curbuilder !b = curbuilder <> sep <> b -getTemplateFile :: T.Text -> CatalogMonad T.Text-getTemplateFile = throwError renderString :: T.Text -> T.Builder renderString x = let !y = T.fromString (show x) in y @@ -145,3 +203,4 @@ toRuby' ResolvedUndefined = ":undef" toRuby' (ResolvedRReference rtype (ResolvedString rname)) = renderString ( rtype <> "[" <> rname <> "]" ) toRuby' x = T.fromString $ show x+#endif
Erb/Evaluate.hs view
@@ -1,4 +1,4 @@-module Erb.Evaluate (rubyEvaluate) where+module Erb.Evaluate (rubyEvaluate, getVariable) where import qualified Data.Map as Map import Puppet.Interpreter.Types
Puppet/Interpreter/Catalog.hs view
@@ -45,7 +45,7 @@ import Control.Arrow (first,(***)) import Data.List import Data.Char (isAlpha, isAlphaNum)-import Data.Maybe (isJust, fromJust, catMaybes, isNothing, mapMaybe)+import Data.Maybe (isJust, fromJust, catMaybes, isNothing, fromMaybe) import Data.Either (lefts, rights, partitionEithers) import Data.Ord (comparing) import Text.Parsec.Pos@@ -57,6 +57,7 @@ import qualified Data.Graph as Graph import qualified Data.Tree as Tree import qualified Data.Text as T+import Control.Lens qualified :: T.Text -> Bool qualified = T.isInfixOf "::"@@ -94,31 +95,31 @@ Nothing -> return (Nothing, []) (!output, !finalstate) <- runStateT ( runErrorT ( computeCatalog getstatements nodename ) ) ScopeState- { curScope = [["::"]]- , curVariables = convertedfacts- , curClasses = Map.empty- , curDefaults = Map.empty- , curResId = 1- , curPos = (initialPos "dummy")- , nestedtoplevels = Map.empty- , getStatementsFunction = getstatements- , getWarnings = []- , curCollect = []- , unresolvedRels = []- , computeTemplateFunction = gettemplate- , puppetDBFunction = puppetdb- , luaState = luastate- , userFunctions = Set.fromList userfunctions- , nativeTypes = ntypes- , definedResources = Map.singleton ("node",nodename) (newPos "site.pp" 0 0)- , currentDependencyStack = [("node",nodename)]+ { _curScope = [["::"]]+ , _curVariables = convertedfacts+ , _curClasses = Map.empty+ , _curDefaults = Map.empty+ , _curResId = 1+ , _curPos = (initialPos "dummy")+ , _nestedtoplevels = Map.empty+ , _getStatementsFunction = getstatements+ , _getWarnings = []+ , _curCollect = []+ , _unresolvedRels = []+ , _computeTemplateFunction = gettemplate+ , _puppetDBFunction = puppetdb+ , _luaState = luastate+ , _userFunctions = Set.fromList userfunctions+ , _nativeTypes = ntypes+ , _definedResources = Map.singleton ("node",nodename) (newPos "site.pp" 0 0)+ , _currentDependencyStack = [("node",nodename)] } case luastate of Just l -> closeLua l Nothing -> return () case output of- Left x -> return (Left (T.unpack x), getWarnings finalstate)- Right x -> return (Right x, getWarnings finalstate)+ Left x -> return (Left (T.unpack x), finalstate ^. getWarnings)+ Right x -> return (Right x, finalstate ^. getWarnings) computeCatalog :: (TopLevelType -> T.Text -> IO (Either String Statement)) -> T.Text -> CatalogMonad (FinalCatalog, EdgeMap, FinalCatalog) computeCatalog getstatements nodename = do@@ -129,7 +130,7 @@ resolveResource :: CResource -> CatalogMonad (ResIdentifier, RResource) resolveResource cr@(CResource cid cname ctype cparams _ scopes cpos) = do- setPos cpos+ curPos .= cpos rname <- resolveGeneralString cname rparams <- mapM (\(a,b) -> do { ra <- resolveGeneralString a; rb <- resolveGeneralValue b; return (ra,rb); }) (Map.toList cparams) nparams <- processOverride cr (Map.fromList rparams)@@ -148,8 +149,8 @@ saveAlias (ResolvedString al) | al == rname = return () | otherwise = addDefinedResource (ctype, al) cpos saveAlias x = throwPosError ("This alias is not a string:" <> tshow x)- setPos cpos- ntypes <- fmap nativeTypes get+ curPos .= cpos+ ntypes <- use nativeTypes unless (Map.member ctype ntypes) $ throwPosError $ "Can't find native type " <> ctype -- now run the collection checks for overrides let validatefunction = puppetvalidate (ntypes Map.! ctype)@@ -169,25 +170,25 @@ -- for exported resources (so that they can still be found as collected) collectionChecks :: CResource -> CatalogMonad [CResource] collectionChecks res =- if crvirtuality res == Normal+ if res ^. crvirtuality == Normal then return [res] else do -- Note that amending attributes with a collector does collect virtual -- values. Hence no filtering on the collectors is done here.- isCollected <- liftM curCollect get >>= mapM (\(x, _, _) -> x res)- case (or isCollected, crvirtuality res) of- (True, Exported) -> return [res { crvirtuality = Normal }, res]- (True, _) -> return [res { crvirtuality = Normal } ]- (False, _) -> return [res ]+ isCollected <- use curCollect >>= mapM (`_colFunction` res)+ case (or isCollected, res ^. crvirtuality) of+ (True, Exported) -> return [res & crvirtuality .~ Normal, res]+ (True, _) -> return [res & crvirtuality .~ Normal ]+ (False, _) -> return [res ] processOverride :: CResource -> Map.Map T.Text ResolvedValue -> CatalogMonad (Map.Map T.Text ResolvedValue) processOverride cr prms =- let applyOverride :: CResource -> Map.Map T.Text ResolvedValue -> (CResource -> CatalogMonad Bool, Map.Map GeneralString GeneralValue, Maybe PDB.Query) -> CatalogMonad (Map.Map T.Text ResolvedValue)+ let applyOverride :: CResource -> Map.Map T.Text ResolvedValue -> CollectionFunction -> CatalogMonad (Map.Map T.Text ResolvedValue) -- this checks if the collection function matches- applyOverride c prm (func, overs, _) = do- check <- func c+ applyOverride c prm colf = do+ check <- (colf ^. colFunction) c if check- then foldM tryReplace prm (Map.toList overs)+ then foldM tryReplace prm (Map.toList (colf^.colOverrides)) else return prm tryReplace :: Map.Map T.Text ResolvedValue -> (GeneralString, GeneralValue) -> CatalogMonad (Map.Map T.Text ResolvedValue) -- if it does, this resolves the override and applies it@@ -197,7 +198,7 @@ rv <- resolveGeneralValue gv return $ Map.insert rs rv curmap -- Collectors are filtered so that only those with overrides are passed to the fold.- in liftM (filter (\(_, x, _) -> not $ Map.null x) . curCollect) get >>= foldM (applyOverride cr) prms+ in use curCollect >>= foldlMOf (traversed.filtered (has (colOverrides.each))) (applyOverride cr) prms retrieveRemoteResources :: (PDB.Query -> IO (Either String [CResource])) -> PDB.Query -> CatalogMonad [CResource] retrieveRemoteResources f q = do@@ -208,10 +209,10 @@ extractRelations :: CResource -> CatalogMonad CResource extractRelations cr = do- setPos (pos cr)- (params, relations) <- partitionParamsRelations (crparams cr)- addUnresRel (relations, (crtype cr, crname cr), UNormal, pos cr, crscope cr)- return cr { crparams = params }+ curPos .= cr ^. pos+ (params, relations) <- partitionParamsRelations (cr ^. crparams)+ addUnresRel (relations, (cr ^. crtype, cr ^. crname), UNormal, cr ^. pos, cr ^. crscope)+ return (cr & crparams .~ params) -- resolves a single relationship resolveRelationship :: ([(LinkType, GeneralValue, GeneralValue)], (T.Text, GeneralString), RelUpdateType, SourcePos, [[ScopeName]])@@ -227,8 +228,8 @@ -- this does all the relation stuff finalizeRelations :: FinalCatalog -> FinalCatalog -> CatalogMonad (FinalCatalog, EdgeMap) finalizeRelations exported cat = do- grels <- fmap unresolvedRels get >>= mapM resolveRelationship- drs <- fmap definedResources get+ grels <- use unresolvedRels >>= mapM resolveRelationship+ drs <- use definedResources let extr :: ([(LinkType, ResIdentifier)], ResIdentifier, RelUpdateType, SourcePos, [[ScopeName]]) -> [(ResIdentifier, ResIdentifier, LinkInfo)] extr (dsts, src, rutype, spos, scp) = do@@ -267,16 +268,16 @@ finalResolution :: Catalog -> CatalogMonad (FinalCatalog, EdgeMap, FinalCatalog) finalResolution cat = do- pdbfunction <- fmap puppetDBFunction get+ pdbfunction <- use puppetDBFunction fqdnr <- getVariable "::fqdn" collectedRemote <- do fqdn <- case fqdnr of Just (Right (ResolvedString f'), _) -> return f' _ -> throwError "Could not get FQDN during final resolution"- remoteCollects <- fmap (mapMaybe (\(_,_,x) -> x) . curCollect) get+ remoteCollects <- fmap (toListOf (traversed . colQuery . _Just)) (use curCollect) let isNotLocal :: CResource -> Bool- isNotLocal cr = case Map.lookup (Right "EXPORTEDSOURCE") (crparams cr) of+ isNotLocal cr = case cr ^. crparams . at (Right "EXPORTEDSOURCE") of Just (Right (ResolvedString x)) -> x /= fqdn _ -> True toCR :: Either String JSON.Value -> Either String [CResource]@@ -287,11 +288,11 @@ fmap concat (mapM (retrieveRemoteResources (fmap toCR . pdbfunction "resources")) remoteCollects) let -- this adds the collected remote defines to the index of know resources, so that the dependencies check addCollectedDefines cr = do- let rtype = crtype cr- rname <- resolveGeneralString (crname cr)+ let rtype = cr ^. crtype+ rname <- resolveGeneralString (cr ^. crname) isdef <- checkDefine rtype case isdef of- Just _ -> addDefinedResource (rtype, rname) (pos cr)+ Just _ -> addDefinedResource (rtype, rname) (cr ^. pos) Nothing -> return () collectedRemote' <- mapM extractRelations collectedRemote mapM_ addCollectedDefines collectedRemote'@@ -305,18 +306,19 @@ addDefinedResource (ct, cn) cp case Map.lookup (Right "alias") prms of Just (Right (ResolvedString s)) -> addDefinedResource (ct, s) cp+ Just (Right (ResolvedArray [ResolvedString s])) -> addDefinedResource (ct, s) cp Just x -> throwPosError ("Alias must be a single string, not " <> tshow x) _ -> return ()- addCollectedRemoteResource x = throwPosError $ "finalResolution/addCollectedRemoteResource the remote resource name was not properly defined: " <> tshow (crname x)+ addCollectedRemoteResource x = throwPosError $ "finalResolution/addCollectedRemoteResource the remote resource name was not properly defined: " <> tshow (x ^. crname) mapM_ addCollectedRemoteResource collectedRemoteD let collected = collectedLocalD ++ collectedRemoteD- (real, allvirtual) = partition (\x -> crvirtuality x == Normal) collected- (_, exported) = partition (\x -> crvirtuality x == Virtual) allvirtual+ (real, allvirtual) = partition (( == Normal) . _crvirtuality) collected+ (_, exported) = partition (( == Virtual) . _crvirtuality) allvirtual rexported <- mapM resolveResource exported let !exportMap = Map.fromList rexported -- TODO --export stuff- --liftIO $ putStrLn "EXPORTED:"+ --liftIO $ putStrLn "EXPORTED:" --liftIO $ mapM print exported --get >>= return . unresolvedRels >>= liftIO . (mapM print) (fc, em) <- mapM finalizeResource real >>= createResourceMap >>= finalizeRelations exportMap@@ -338,8 +340,7 @@ getstatement :: TopLevelType -> T.Text -> CatalogMonad Statement getstatement qtype name = do- curcontext <- get- let stmtsfunc = getStatementsFunction curcontext+ stmtsfunc <- use getStatementsFunction estatement <- liftIO $ stmtsfunc qtype name case estatement of Left x -> throwPosError (T.pack x)@@ -349,59 +350,59 @@ pushDefaults :: ResDefaults -> CatalogMonad () pushDefaults d = do- curstate <- get- let curscope = (head . curScope) curstate- curdefaults = curDefaults curstate- newdefaults = Map.insertWith (++) curscope [d] curdefaults- put (curstate { curDefaults = newdefaults })+ curscope <- use ( curScope . _head )+ curDefaults %= Map.insertWith (++) curscope [d] emptyDefaults :: CatalogMonad () emptyDefaults = do- curstate <- get- let curscope = (head . curScope) curstate- curdefaults = curDefaults curstate- newdefaults = Map.delete curscope curdefaults- put (curstate { curDefaults = newdefaults })+ curscope <- use ( curScope . _head )+ curDefaults %= Map.delete curscope getCurDefaults :: CatalogMonad [ResDefaults] getCurDefaults = do- curstate <- get- let curscope = (head . curScope) curstate- curdefaults = curDefaults curstate- case Map.lookup curscope curdefaults of- Nothing -> return []- Just x -> return x+ curscope <- use ( curScope . _head )+ use ( curDefaults . at curscope . each ) pushDependency :: ResIdentifier -> CatalogMonad ()-pushDependency = modify . modifyDeps . (:)+pushDependency x = currentDependencyStack %= cons x+ popDependency :: CatalogMonad ()-popDependency = modify (modifyDeps tail)+popDependency = currentDependencyStack %= tail+ pushScope :: [ScopeName] -> CatalogMonad ()-pushScope = modify . modifyScope . (:)+pushScope x = curScope %= cons x+ popScope :: CatalogMonad ()-popScope = modify (modifyScope tail)+popScope = curScope %= tail+ getScope :: CatalogMonad [T.Text]-getScope = do- scope <- liftM curScope get+getScope = do+ scope <- use curScope if null scope then throwError "empty scope, shouldn't happen" else return $ head scope addLoaded :: T.Text -> SourcePos -> CatalogMonad ()-addLoaded name = modify . modifyClasses . Map.insert name+addLoaded name p = curClasses.at name ?= p+getNextId :: CatalogMonad Int getNextId = do- curscope <- get- put $ incrementResId curscope- return (curResId curscope)-setPos = modify . setStatePos+ curResId += 1+ use curResId -- qualifies a variable k depending on the context cs+qualify :: T.Text -> T.Text -> T.Text qualify k cs | qualified k || (cs == "::") = cs <> k | otherwise = cs <> "::" <> k --- This is a bit convoluted and misses a critical feature. -- It adds the variable to all the scopes that are currently active.--- BUG TODO : check that a variable is not already defined.-putVariable k v = getScope >>= mapM_ (\x -> modify (modifyVariables (Map.insert (qualify k x) v)))+putVariable :: T.Text -> (GeneralValue, SourcePos) -> CatalogMonad ()+putVariable k v = getScope+ >>= mapM_ (\x -> do+ let q = qualify k x+ defined <- use (curVariables.at q)+ case defined of+ Just nv -> throwPosError ("Variable $" <> k <> " already defined at " <> tshow nv)+ Nothing -> curVariables.at (qualify k x) ?= v+ ) -- Saves the current module name setModuleName :: T.Text -> CatalogMonad ()@@ -410,51 +411,49 @@ modulename = if T.null remain then "topmodule" else amodulename- cpos <- getPos- vars <- fmap curVariables get- let nvars = Map.insert "::caller_module_name" (Right (ResolvedString modulename), cpos) vars- saveVariables nvars+ cpos <- use curPos+ curVariables.at "::caller_module_name" ?= (Right (ResolvedString modulename), cpos) -getVariable vname = liftM (Map.lookup vname . curVariables) get+getVariable :: T.Text -> CatalogMonad (Maybe (GeneralValue, SourcePos))+getVariable vname = use (curVariables . at vname) -- BUG TODO : top levels are qualified only with the head of the scopes+addNestedTopLevel :: TopLevelType -> T.Text -> Statement -> CatalogMonad () addNestedTopLevel rtype rname rstatement = do- curstate <- get- let ctop = nestedtoplevels curstate- curscope = head $ head (curScope curstate)- nname = qualify rname curscope+ curscope <- use (curScope . _head . _head)+ let nname = qualify rname curscope nstatement = case rstatement of DefineDeclaration _ prms stms cpos -> DefineDeclaration nname prms stms cpos ClassDeclaration _ inhe prms stms cpos -> ClassDeclaration nname inhe prms stms cpos x -> x- ntop = Map.insert (rtype, nname) nstatement ctop- nstate = curstate { nestedtoplevels = ntop }- put nstate+ nestedtoplevels . at (rtype, nname) ?= nstatement+ addWarning :: T.Text -> CatalogMonad ()-addWarning = modify . pushWarning-addCollect ((func, query), overrides) = modify $ pushCollect (func, overrides, query)+addWarning x = getWarnings %= cons x++addCollect :: ((CResource -> CatalogMonad Bool, Maybe PDB.Query), Map.Map GeneralString GeneralValue) -> CatalogMonad ()+addCollect ((func, query), overrides) = curCollect %= cons (CollectionFunction func overrides query)+ -- this pushes the relations only if they exist -- the parameter is of the form -- ( [dstrelations], srcresource, type, pos ) addUnresRel :: ([(LinkType, GeneralValue, GeneralValue)], (T.Text, GeneralString), RelUpdateType, SourcePos, [[ScopeName]]) -> CatalogMonad ()-addUnresRel ncol@(rels, _, _, _, _) = unless (null rels) (modify (pushUnresRel ncol))+addUnresRel ncol@(rels, _, _, _, _) = unless (null rels) (unresolvedRels %= cons ncol) -- finds out if a resource name refers to a define checkDefine :: T.Text -> CatalogMonad (Maybe Statement)-checkDefine dname = fmap nativeTypes get >>= \nt -> if Map.member dname nt+checkDefine dname = use (nativeTypes . contains dname) >>= \nt -> if nt then return Nothing else do- curstate <- get- let ntop = nestedtoplevels curstate- getsmts = getStatementsFunction curstate- check = Map.lookup (TopDefine, dname) ntop+ check <- use (nestedtoplevels . at (TopDefine, dname))+ getsmts <- use getStatementsFunction case check of- Just x -> return $ Just x Nothing -> do def1 <- liftIO $ getsmts TopDefine dname case def1 of Left err -> throwPosError ("Could not find the definition of " <> dname <> " err = " <> T.pack err) Right s -> return $ Just s+ x -> return x {- Partition parameters between those that are actual parameters and those that define relationships.@@ -480,11 +479,7 @@ -- TODO check whether parameters changed checkLoaded :: T.Text -> CatalogMonad Bool-checkLoaded name = do- curscope <- get- case Map.lookup name (curClasses curscope) of- Nothing -> return False- Just _ -> return True+checkLoaded name = fmap isJust (use (curClasses . at name)) -- function that takes a pair of Expressions and try to resolve the first as a string, the second as a generalvalue resolveParams :: (Expression, Expression) -> CatalogMonad (GeneralString, GeneralValue)@@ -550,7 +545,7 @@ putVariable "name" (expr, rpos) mapM_ (loadClassVariable rpos mparams) args - setPos dpos+ curPos .= dpos setModuleName dtype -- parse statements res <- mapM evaluateStatements dstmts@@ -559,7 +554,7 @@ popScope return nres in do- setPos rpos+ curPos .= rpos isdef <- checkDefine rtype case (rvirtuality, isdef) of (Normal, Just (TopContainer topstmts (DefineDeclaration dtype args dstmts dpos))) -> do@@ -583,15 +578,15 @@ case grname of Right e -> do rse <- rstring e- curpos <- getPos+ curpos <- use curPos addDefinedResource (rtype, rse) curpos case Map.lookup (Right "alias") rparameters of Just (Right (ResolvedString s)) -> addDefinedResource (rtype, s) curpos Just x -> throwPosError ("Alias must be a single string, not " <> tshow x) _ -> return ()- (curdeptype, curdepname) <- fmap (head . currentDependencyStack) get+ (curdeptype, curdepname) <- gets (head . _currentDependencyStack) -- LIENS let defaultdependency = (RRequire, Right (ResolvedString curdeptype), Right (ResolvedString curdepname))- scopes <- fmap curScope get+ scopes <- use curScope addUnresRel ([defaultdependency], (rtype, Right rse), UNormal, position, scopes) return [CResource resid (Right rse) rtype rparameters virtuality scopes position] Left r -> throwPosError ("Could not determine the current resource name: " <> tshow r)@@ -599,12 +594,12 @@ -- node evaluateStatements :: Statement -> CatalogMonad Catalog evaluateStatements (Node _ stmts position) = do- setPos position+ curPos .= position res <- mapM evaluateStatements stmts handleDelayedActions (concat res) -- include-evaluateStatements (Include includename position) = setPos position >> resolveExpressionString includename >>= getstatement TopClass >>= \st -> evaluateClass st Map.empty Nothing+evaluateStatements (Include includename position) = curPos .= position >> resolveExpressionString includename >>= getstatement TopClass >>= \st -> evaluateClass st Map.empty Nothing evaluateStatements x@(ClassDeclaration cname _ _ _ _) = do addNestedTopLevel TopClass cname x return []@@ -612,14 +607,14 @@ addNestedTopLevel TopDefine dtype n return [] evaluateStatements (ConditionalStatement exprs position) = do- setPos position+ curPos .= position trues <- filterM (\(expr, _) -> resolveBoolean (Left expr)) exprs case trues of ((_,stmts):_) -> liftM concat (mapM evaluateStatements stmts) _ -> return [] evaluateStatements (Resource rtype rname parameters virtuality position) = do- setPos position+ curPos .= position case rtype of -- checks whether we are handling a parametrized class "class" -> do@@ -644,37 +639,37 @@ pushDefaults $ ROverride rotype rroname rroparams ropos return [] evaluateStatements (DependenceChain (srctype, srcname) (dsttype, dstname) position) = do- setPos position+ curPos .= position gdstname <- tryResolveExpression dstname gsrcname <- tryResolveExpressionString srcname- scp <- fmap curScope get+ scp <- use curScope addUnresRel ( [(RRequire, Right $ ResolvedString dsttype, gdstname)], (srctype, gsrcname), UPlus, position, scp) return [] -- <<| |>> evaluateStatements (ResourceCollection rtype expr overrides position) = do- setPos position+ curPos .= position unless (null overrides) $ throwPosError "Amending attributes with a Collector only works with <| |>, not <<| |>>."- func <- collectionFunction Exported rtype expr+ func <- collectFunction Exported rtype expr addCollect (func, Map.empty) return [] -- <| |> -- TODO : check that this is a native type when overrides are defined. -- The behaviour is not explained in the documentation, so I won't support it. evaluateStatements (VirtualResourceCollection rtype expr overrides position) = do- setPos position- func <- collectionFunction Virtual rtype expr+ curPos .= position+ func <- collectFunction Virtual rtype expr prms <- addParameters Map.empty overrides addCollect (func, prms) return [] evaluateStatements (VariableAssignment vname vexpr position) = do- setPos position+ curPos .= position rvexpr <- tryResolveExpression vexpr putVariable vname (rvexpr, position) return [] evaluateStatements (MainFunctionCall fname fargs position) = do- setPos position+ curPos .= position rargs <- mapM resolveExpression fargs executeFunction fname rargs @@ -701,13 +696,11 @@ -- nom, heritage, parametres, contenu evaluateClass :: Statement -> Map.Map T.Text (GeneralValue, SourcePos) -> Maybe T.Text -> CatalogMonad Catalog evaluateClass (ClassDeclaration classname inherits parameters statements position) inputparams actualname = do- isloaded <- case actualname of- Nothing -> checkLoaded classname- Just x -> checkLoaded x+ isloaded <- checkLoaded (fromMaybe classname actualname) if isloaded then return [] else do- oldpos <- getPos -- saves where we were at class declaration so that we known were the class was included+ oldpos <- use curPos -- saves where we were at class declaration so that we known were the class was included addDefinedResource ("class", classname) oldpos -- detection of spurious parameters let classparamset = Set.fromList $ map fst parameters@@ -722,7 +715,7 @@ Nothing -> pushScope [classname] -- sets the scope Just ac -> pushScope [classname, ac] mparameters <- mapM (loadClassVariable position inputparams) parameters -- add variables for parametrized classes- setPos position -- the setPos is that late so that the error message about missing parameters is about the calling site+ curPos .= position -- the setPos is that late so that the error message about missing parameters is about the calling site pushDependency ("class", classname) setModuleName classname @@ -734,9 +727,7 @@ ClassDeclaration _ ni np ns no -> evaluateClass (ClassDeclaration classname ni np ns no) Map.empty (Just parentclass) _ -> throwError "Should not happen : TopClass return something else than a ClassDeclaration in evaluateClass" Nothing -> return []- case actualname of- Nothing -> addLoaded classname oldpos- Just x -> addLoaded x oldpos+ addLoaded (fromMaybe classname actualname) oldpos -- parse statements res <- mapM evaluateStatements statements@@ -745,7 +736,7 @@ -- for all resources that do not already depend on a class -- this is probably not puppet perfect with resources that -- depend explicitely on a class- scopes <- fmap curScope get+ scopes <- use curScope popScope popDependency return $@@ -838,11 +829,13 @@ then throwPosError ("Invalid array index " <> num <> " " <> tshow ar) else return $ Right (ar !! nnum) (Right (ResolvedHash ar), Right idx) -> do- let filtered = filter (\(x,_) -> x == idx) ar- case filtered of- [] -> return $ Right ResolvedUndefined+ let filterd = filter (\(x,_) -> x == idx) ar+ case filterd of+ [] -> do+ getWarnings <>= ["Cannot find index " <> tshow rb <> " in " <> tshow ra]+ return $ Right ResolvedUndefined [(_,x)] -> return $ Right x- x -> throwPosError ("Hum, WTF tryResolveGeneralValue " <> tshow x)+ x -> return $ Right $ snd $ last x (_, Left y) -> throwPosError ("Could not resolve index " <> tshow y) (Left x, _) -> throwPosError ("Could not resolve lookup " <> tshow x) (Right x, _) -> throwPosError ("Could not resolve something that is not an array nor a hash, but " <> tshow x)@@ -853,11 +846,11 @@ rb <- tryResolveExpressionString b case (ra, rb) of (Right (ResolvedArray ar), Right idx) ->- let filtered = filter (compareRValues (ResolvedString idx)) ar- in return $! Right $! ResolvedBool $! not $! null filtered+ let filterd = filter (compareRValues (ResolvedString idx)) ar+ in return $! Right $! ResolvedBool $! not $! null filterd (Right (ResolvedHash h), Right idx) ->- let filtered = filter (\(fa,_) -> fa == idx) h- in return $! Right $! ResolvedBool $! not $! null filtered+ let filterd = filter (\(fa,_) -> fa == idx) h+ in return $! Right $! ResolvedBool $! not $! null filterd (Right (ResolvedString _), Right _) -> throwPosError "in operator not yet implemented for substrings" (Right ba, Right bb) -> throwPosError $ "Expected a string and a hash, array or string for the in operator, not " <> tshow (ba,bb) _ -> return o@@ -902,7 +895,7 @@ case resolved of Right r -> return r Left x -> do- p <- getPos+ p <- use curPos throwError ("Can't resolve expression '" <> tshow x <> "' at " <> tshow p <> " was '" <> tshow e <> "'") resolveExpressionString :: Expression -> CatalogMonad T.Text@@ -912,7 +905,7 @@ ResolvedString s -> return s ResolvedInt i -> return (tshow i) e -> do- p <- getPos+ p <- use curPos throwError ("Can't resolve expression '" <> tshow e <> "' to a string at " <> tshow p) tryResolveValue :: Value -> CatalogMonad GeneralValue@@ -945,7 +938,7 @@ matching <- liftM catMaybes (mapM getVariable varnames) if null matching then do- position <- getPos+ position <- use curPos addWarning ("Could not resolveValue variables " <> tshow varnames <> " at " <> tshow position) return $ Left $ Value $ VariableReference (head varnames) else return $ case head matching of@@ -984,6 +977,21 @@ Just w -> return $ Right $ ResolvedString w Nothing -> throwPosError $ "Function call generate for command " <> cmdname <> " (" <> tshow cmdargs <> ") failed" +tryResolveValue (FunctionCall "values" [x]) = do+ rx <- tryResolveExpression x+ case rx of+ Right (ResolvedHash h) -> return (Right (ResolvedArray (map snd h)))+ Right z -> throwPosError ("The values function works on arrays, not " <> tshow z)+ Left l -> return (Left (Value (FunctionCall "values" [l])))+tryResolveValue (FunctionCall "values" args) = throwPosError ("The values function online takes a single argument, not " <> tshow (length args))+tryResolveValue (FunctionCall "keys" [x]) = do+ rx <- tryResolveExpression x+ case rx of+ Right (ResolvedHash h) -> return (Right (ResolvedArray (map (ResolvedString . fst) h)))+ Right z -> throwPosError ("The keys function works on arrays, not " <> tshow z)+ Left l -> return (Left (Value (FunctionCall "keys" [l])))+tryResolveValue (FunctionCall "keys" args) = throwPosError ("The keys function online takes a single argument, not " <> tshow (length args))+ tryResolveValue n@(FunctionCall "pdbresourcequery" (query:xs)) = do let rvalue2query :: ResolvedValue -> Either String PDB.Query@@ -991,7 +999,7 @@ Just PDB.OAnd -> fmap (PDB.Query PDB.OAnd) (mapM rvalue2query nxs) Just PDB.OOr -> fmap (PDB.Query PDB.OOr) (mapM rvalue2query nxs) Just PDB.ONot -> fmap (PDB.Query PDB.ONot) (mapM rvalue2query nxs)- Just op -> fmap (PDB.Query op) (mapM rvalue2query' nxs)+ Just opr -> fmap (PDB.Query opr) (mapM rvalue2query' nxs) Nothing -> Left $ "Can't resolve operator " ++ T.unpack o rvalue2query x = Left $ "Don't know what to do with " ++ T.unpack (showValue x) @@ -1062,10 +1070,10 @@ case fname of Left x -> throwPosError $ "Can't resolve template path " <> tshow x Right filename -> do- vars <- fmap curVariables get >>= DT.mapM (\(v,p) -> fmap (\x -> (x,p)) (tryResolveGeneralValue v))- saveVariables vars- scp <- liftM head getScope -- TODO check if that sucks- templatefunc <- liftM computeTemplateFunction get+ vars <- use curVariables >>= DT.mapM (\(v,p) -> fmap (\x -> (x,p)) (tryResolveGeneralValue v))+ curVariables .= vars+ scp <- fmap head getScope -- TODO check if that sucks+ templatefunc <- use computeTemplateFunction out <- liftIO (templatefunc (Right filename) scp (Map.map fst vars)) case out of Right x -> return $ Right $ ResolvedString x@@ -1075,10 +1083,10 @@ case rcnt of Left x -> throwPosError $ "Can't resolve inline_template content " <> tshow x Right content -> do- vars <- fmap curVariables get >>= DT.mapM (\(v,p) -> fmap (\x -> (x,p)) (tryResolveGeneralValue v))- saveVariables vars- scp <- liftM head getScope -- TODO check if that sucks- templatefunc <- liftM computeTemplateFunction get+ vars <- use curVariables >>= DT.mapM (\(v,p) -> fmap (\x -> (x,p)) (tryResolveGeneralValue v))+ curVariables .= vars+ scp <- fmap head getScope -- TODO check if that sucks+ templatefunc <- use computeTemplateFunction out <- liftIO (templatefunc (Left content) scp (Map.map fst vars)) case out of Right x -> return $ Right $ ResolvedString x@@ -1089,7 +1097,7 @@ Left n -> return $ Left n -- TODO BUG Right (ResolvedString typeorclass) -> do- ntypes <- fmap nativeTypes get+ ntypes <- use nativeTypes -- is it a loaded class or a define ? if Map.member typeorclass ntypes then return $ Right $ ResolvedBool True@@ -1097,9 +1105,9 @@ isdefine <- checkDefine typeorclass case isdefine of Just _ -> return $ Right $ ResolvedBool True- Nothing -> liftM (Right . ResolvedBool . Map.member typeorclass . curClasses) get+ Nothing -> gets (Right . ResolvedBool . Map.member typeorclass . _curClasses) Right (ResolvedRReference rtype (ResolvedString rname)) -> do- defset <- fmap definedResources get+ defset <- use definedResources return $ Right $ ResolvedBool (Map.member (rtype, rname) defset) Right x -> throwPosError $ "Can't know if this could be defined : " <> tshow x tryResolveValue n@(FunctionCall "regsubst" [str, src, dst, flags]) = do@@ -1168,8 +1176,8 @@ Right _ -> return $ Right $ ResolvedBool False Left _ -> return $ Left $ Value n tryResolveValue n@(FunctionCall fname args) = do- ufunctions <- fmap userFunctions get- l <- fmap luaState get+ ufunctions <- use userFunctions+ l <- use luaState case (l, Set.member fname ufunctions) of (Just ls, True) -> do rargs <- mapM tryResolveExpression args@@ -1219,7 +1227,7 @@ executeFunction "fail" args = throwPosError ("Error: " <> tshow args) executeFunction "realize" rlist = mapM_ pushRealize rlist >> return [] executeFunction "dumpvariables" _ = do- vars <- fmap curVariables get+ vars <- use curVariables mapM_ (liftIO . print) (Map.toList vars) return [] executeFunction "create_resources" (mrtype:rdefs:rest) = do@@ -1233,7 +1241,7 @@ arghash <- case rdefs of ResolvedHash x -> return x _ -> throwPosError $ "Resource definition must be a hash, and not " <> tshow rdefs- position <- getPos+ position <- use curPos defaults <- case rest of [ResolvedHash h] -> return $ RDefaults mrrtype (Map.fromList $ map (Right *** Right) h) position [] -> return $ RDefaults mrrtype Map.empty position@@ -1256,7 +1264,7 @@ executeFunction "validate_string" [x] = case x of ResolvedString _ -> return [] y -> throwPosError $ tshow y <> " is not an string"-executeFunction "validate_re" [x,re] = case (x,re) of+executeFunction "validate_re" [x,reg] = case (x,reg) of (ResolvedString z, ResolvedString rre) -> do m <- liftIO $ regmatch z rre case m of@@ -1268,8 +1276,8 @@ ResolvedBool _ -> return [] y -> throwPosError $ tshow y <> " is not a boolean" executeFunction fname args = do- ufunctions <- fmap userFunctions get- l <- fmap luaState get+ ufunctions <- use userFunctions+ l <- use luaState case (l, Set.member fname ufunctions) of (Just ls, True) -> do o <- puppetFunc ls fname args@@ -1278,7 +1286,7 @@ ResolvedBool False -> throwPosError ("Function " <> fname <> "(" <> tshow args <> ") returned false") x -> throwPosError ("Function " <> fname <> "(" <> tshow args <> ") did not return a bool: " <> tshow x) _ -> do- position <- getPos+ position <- use curPos addWarning $ "Function " <> fname <> "(" <> tshow args <> ") not handled at " <> tshow position return [] @@ -1352,8 +1360,8 @@ resolveGeneralString (Right x) = return x resolveGeneralString (Left y) = resolveExpressionString y -collectionFunction :: Virtuality -> T.Text -> Expression -> CatalogMonad (CResource -> CatalogMonad Bool, Maybe PDB.Query)-collectionFunction virt mrtype exprs = do+collectFunction :: Virtuality -> T.Text -> Expression -> CatalogMonad (CResource -> CatalogMonad Bool, Maybe PDB.Query)+collectFunction virt mrtype exprs = do (finalfunc, pdbquery) <- case exprs of BTrue -> return (\_ -> return True, Just (PDB.collectAll mrtype)) EqualOperation a b -> do@@ -1364,7 +1372,7 @@ _ -> throwPosError "We only support collection of the form 'parameter == value'" defstatement <- checkDefine mrtype paramset <- case defstatement of- Nothing -> fmap nativeTypes get >>= \nt -> case Map.lookup mrtype nt of+ Nothing -> use nativeTypes >>= \nt -> case Map.lookup mrtype nt of Just (PuppetTypeMethods _ ps) -> return ps Nothing -> throwPosError $ "Unknown type " <> mrtype <> " when trying to collect" Just (DefineDeclaration _ params _ _) -> return $ Set.fromList $ map fst params@@ -1372,14 +1380,14 @@ when (Set.notMember paramname paramset && not (Set.member paramname metaparameters)) $ throwPosError $ "Parameter " <> paramname <> " is not a valid parameter. It should be in : " <> tshow (Set.toList paramset) return (\r ->- case Map.lookup (Right paramname) (crparams r) of+ case r ^. crparams . at (Right paramname) of Nothing -> return False Just prmmatch -> do cmp <- resolveGeneralValue prmmatch case (paramname, cmp) of ("tag", ResolvedArray xs) ->- let filtered = filter (compareRValues rb) xs- in return $ not $ null filtered+ let filterd = filter (compareRValues rb) xs+ in return $ not $ null filterd _ -> return $ compareRValues cmp rb , case (paramname, rb) of ("tag", ResolvedString tagval) -> Just (PDB.collectTag mrtype tagval)@@ -1389,7 +1397,7 @@ x -> throwPosError $ "TODO : implement collection function for " <> tshow x return (\res -> -- <| |> matches Normal resources- if (crtype res == mrtype) && ( ((virt == Virtual) && (crvirtuality res == Normal)) || (crvirtuality res == virt))+ if (_crtype res == mrtype) && ( ((virt == Virtual) && (_crvirtuality res == Normal)) || (_crvirtuality res == virt)) then finalfunc res else return False , if virt == Exported
Puppet/Interpreter/Functions.hs view
@@ -29,12 +29,13 @@ import qualified Data.ByteString.Base16 as B16 import SafeProcess import Data.Either (lefts, rights)-import Data.List (intercalate,foldl')+import Data.List (intercalate) import qualified Data.Text as T import qualified Data.Text.IO as T import qualified Data.Text.Encoding as T import qualified Data.Text.Lazy as TL import Data.Bits+import Control.Lens puppetMD5 :: T.Text -> T.Text puppetMD5 = T.decodeUtf8 . B16.encode . MD5.hash . T.encodeUtf8@@ -115,7 +116,7 @@ [] -> Left "Key not found" _ -> Left "More than one result, this is extremely bad." extractSubHash' _ x = Left $ "Expected a hash, not " ++ T.unpack (showValue x)- qf <- fmap puppetDBFunction get+ qf <- use puppetDBFunction v <- liftIO (qf "resources" query) >>= \r -> case r of Left rr -> throwPosError (T.pack rr) Right x -> return x
Puppet/Interpreter/RubyRandom.hs view
@@ -113,6 +113,6 @@ limitedRand' s' = let (rval, ns) = rbGenrandInt32 s' val = rval .&. mask- in if n < val+ in if n <= val then limitedRand' ns else (val, ns)
Puppet/Interpreter/Types.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE TemplateHaskell, CPP #-}+ module Puppet.Interpreter.Types where import Puppet.DSL.Types hiding (Value) -- conflicts with aeson@@ -20,16 +22,16 @@ import qualified Data.Vector as V import Control.Arrow ( (***) ) import Data.Maybe (fromMaybe)+import Control.Lens hiding ((.=)) +#ifdef HRUBY+import Foreign.Ruby+#endif++type ScopeName = T.Text+ -- | Types for the native type system. type PuppetTypeName = T.Text--- |This is a function type than can be bound. It is the type of all subsequent--- validators.-type PuppetTypeValidate = RResource -> Either String RResource-data PuppetTypeMethods = PuppetTypeMethods {- puppetvalidate :: PuppetTypeValidate,- puppetfields :: Set.Set T.Text- } -- | This is the potentially unsolved list of resources in the catalog. type Catalog =[CResource]@@ -37,6 +39,12 @@ -- | Relationship link type. data LinkType = RNotify | RRequire | RBefore | RSubscribe deriving(Show, Ord, Eq)++-- | Type of update\/override, so they can be applied in the correct order. This+-- part is probably not behaving like vanilla puppet, as it turns out this are+-- many fairly acceptable behaviours and the correct one is not documented.+data RelUpdateType = UNormal | UOverride | UDefault | UPlus deriving (Show, Ord, Eq)+ type LinkInfo = (LinkType, RelUpdateType, SourcePos, [[ScopeName]]) -- | The list of resolved values that are used to define everything in a@@ -91,6 +99,19 @@ parseJSON (Bool b) = return $ ResolvedBool b +#ifdef HRUBY+instance ToRuby ResolvedValue where+ toRuby = toRuby . toJSON+instance FromRuby ResolvedValue where+ fromRuby v = do+ j <- fromRuby v+ case j of+ Nothing -> return Nothing+ Just x -> case fromJSON x of+ Error _ -> return Nothing+ Success v -> return (Just v)+#endif+ -- | This type holds a value that is either from the ASL or fully resolved. type GeneralValue = Either Expression ResolvedValue @@ -108,13 +129,13 @@ data structure by the interpreter. -} data CResource = CResource {- crid :: !Int, -- ^ Resource ID, used in the Puppet YAML.- crname :: !GeneralString, -- ^ Resource name.- crtype :: !T.Text, -- ^ Resource type.- crparams :: !(Map.Map GeneralString GeneralValue), -- ^ Resource parameters.- crvirtuality :: !Virtuality, -- ^ Resource virtuality.- crscope :: ![[ScopeName]], -- ^ Resource scope when it was defined- pos :: !SourcePos -- ^ Source code position of the resource definition.+ _crid :: !Int, -- ^ Resource ID, used in the Puppet YAML.+ _crname :: !GeneralString, -- ^ Resource name.+ _crtype :: !T.Text, -- ^ Resource type.+ _crparams :: !(Map.Map GeneralString GeneralValue), -- ^ Resource parameters.+ _crvirtuality :: !Virtuality, -- ^ Resource virtuality.+ _crscope :: ![[ScopeName]], -- ^ Resource scope when it was defined+ _pos :: !SourcePos -- ^ Source code position of the resource definition. } deriving(Show) instance FromJSON CResource where@@ -138,7 +159,6 @@ <*> pure position parseJSON _ = mzero - -- | Used for puppetDB queries, converting values to CResources json2puppet :: (FromJSON a) => Value -> Either String a json2puppet x = case fromJSON x of@@ -163,6 +183,14 @@ rrpos :: !SourcePos -- ^ Source code position of the resource definition. } deriving(Show, Ord, Eq) +-- |This is a function type than can be bound. It is the type of all subsequent+-- validators.+type PuppetTypeValidate = RResource -> Either String RResource+data PuppetTypeMethods = PuppetTypeMethods {+ puppetvalidate :: PuppetTypeValidate,+ puppetfields :: Set.Set T.Text+ }+ rr2json :: T.Text -> RResource -> Value rr2json hostname rr = let sourcefile = sourceName (rrpos rr)@@ -178,77 +206,81 @@ type FinalCatalog = Map.Map ResIdentifier RResource -type ScopeName = T.Text---- | Type of update\/override, so they can be applied in the correct order. This--- part is probably not behaving like vanilla puppet, as it turns out this are--- many fairly acceptable behaviours and the correct one is not documented.-data RelUpdateType = UNormal | UOverride | UDefault | UPlus deriving (Show, Ord, Eq)- {-| A data type to hold defaults values -} data ResDefaults = RDefaults T.Text (Map.Map GeneralString GeneralValue) SourcePos | ROverride T.Text GeneralString (Map.Map GeneralString GeneralValue) SourcePos deriving (Show, Ord, Eq) +-- | The monad all the interpreter lives in. It is 'ErrorT' with a state.+type CatalogMonad = ErrorT T.Text (StateT ScopeState IO)++-- | The type of collection functions+data CollectionFunction = CollectionFunction { _colFunction :: CResource -> CatalogMonad Bool -- ^ the actual collection function, telling you whether something should be collected+ , _colOverrides :: Map.Map GeneralString GeneralValue -- ^ The list of overrides+ , _colQuery :: Maybe PDB.Query -- ^ The puppetDB query+ }+ {-| The most important data structure for the interpreter. It stores its internal state. -} data ScopeState = ScopeState {- curScope :: ![[ScopeName]],+ _curScope :: ![[ScopeName]], -- ^ The list of scopes. It works like a stack, and its initial value must -- be @[[\"::\"]]@. It is a stack of lists of strings. These lists can be -- one element wide (usual case), or two elements (inheritance), so that -- variables could be assigned to both scopes.- curVariables :: !(Map.Map T.Text (GeneralValue, SourcePos)),+ _curVariables :: !(Map.Map T.Text (GeneralValue, SourcePos)), -- ^ The list of known variables. It should be noted that the interpreter -- tries to resolve them as soon as it can, so that it can store their -- current scope.- curClasses :: !(Map.Map T.Text SourcePos),+ _curClasses :: !(Map.Map T.Text SourcePos), -- ^ The list of classes that have already been included, along with the -- place where this happened.- curDefaults :: !(Map.Map [ScopeName] [ResDefaults]),+ _curDefaults :: !(Map.Map [ScopeName] [ResDefaults]), -- ^ List of defaults to apply. All defaults are applied at the end of the -- interpretation of each top level statement.- curResId :: !Int, -- ^ Stores the value of the current 'crid'.- curPos :: !SourcePos,+ _curResId :: !Int, -- ^ Stores the value of the current 'crid'.+ _curPos :: !SourcePos, -- ^ Current position of the evaluated statement. This is mostly used to -- give useful error messages.- nestedtoplevels :: !(Map.Map (TopLevelType, T.Text) Statement),+ _nestedtoplevels :: !(Map.Map (TopLevelType, T.Text) Statement), -- ^ List of \"top levels\" that have been parsed inside another top level. -- Their behaviour is curently non canonical as the scoping rules are -- unclear.- getStatementsFunction :: TopLevelType -> T.Text -> IO (Either String Statement),+ _getStatementsFunction :: TopLevelType -> T.Text -> IO (Either String Statement), -- ^ This is a function that, given the type of a top level statement and -- its name, should return it.- getWarnings :: ![T.Text], -- ^ List of warnings.- curCollect :: ![(CResource -> CatalogMonad Bool, Map.Map GeneralString GeneralValue, Maybe PDB.Query)],+ _getWarnings :: ![T.Text], -- ^ List of warnings.+ _curCollect :: ![CollectionFunction], -- ^ A bit complicated, this stores the collection functions. These are -- functions that determine whether a resource should be collected or not. -- It can optionally store overrides, which will be applied in the end on -- all resources. It can also store a PuppetDB query.- unresolvedRels :: ![([(LinkType, GeneralValue, GeneralValue)], (T.Text, GeneralString), RelUpdateType, SourcePos, [[ScopeName]])],+ _unresolvedRels :: ![([(LinkType, GeneralValue, GeneralValue)], (T.Text, GeneralString), RelUpdateType, SourcePos, [[ScopeName]])], -- ^ This stores unresolved relationships, because the original string name -- can't be resolved. Fieds are [ ( [dstrelations], srcresource, type, pos ) ]- computeTemplateFunction :: Either T.Text T.Text -> T.Text -> Map.Map T.Text GeneralValue -> IO (Either String T.Text),+ _computeTemplateFunction :: Either T.Text T.Text -> T.Text -> Map.Map T.Text GeneralValue -> IO (Either String T.Text), -- ^ Function that takes either a text content or a filename, the current scope and a list of -- variables. It returns an error or the computed template.- puppetDBFunction :: T.Text -> PDB.Query -> IO (Either String Value),+ _puppetDBFunction :: T.Text -> PDB.Query -> IO (Either String Value), -- ^ Function that takes a request type (resources, nodes, facts, ..), -- a query, and returns a resolved value from puppetDB.- luaState :: Maybe Lua.LuaState,+ _luaState :: Maybe Lua.LuaState, -- ^ The Lua state, used for user supplied content.- userFunctions :: !(Set.Set T.Text),+ _userFunctions :: !(Set.Set T.Text), -- ^ The list of registered user functions- nativeTypes :: !(Map.Map PuppetTypeName PuppetTypeMethods),+ _nativeTypes :: !(Map.Map PuppetTypeName PuppetTypeMethods), -- ^ The list of native types.- definedResources :: !(Map.Map ResIdentifier SourcePos),+ _definedResources :: !(Map.Map ResIdentifier SourcePos), -- ^ Horrible hack to kind of support the "defined" function- currentDependencyStack :: [ResIdentifier]+ _currentDependencyStack :: [ResIdentifier] } --- | The monad all the interpreter lives in. It is 'ErrorT' with a state.-type CatalogMonad = ErrorT T.Text (StateT ScopeState IO)+makeClassy ''ScopeState+makeClassy ''CollectionFunction+makeClassy ''RResource+makeClassy ''CResource instance Error T.Text where noMsg = ""@@ -271,6 +303,7 @@ metaparameters :: Set.Set T.Text metaparameters = Set.fromList ["tag","stage","name","title","alias","audit","check","loglevel","noop","schedule", "EXPORTEDSOURCE", "require", "before", "register", "notify"] :: Set.Set T.Text +{- getPos = liftM curPos get modifyScope f sc = sc { curScope = f $ curScope sc } modifyDeps f sc = sc { currentDependencyStack = f $ currentDependencyStack sc }@@ -283,13 +316,17 @@ pushUnresRel r sc = sc { unresolvedRels = r : unresolvedRels sc } addDefinedResource r p = modify (\st -> st { definedResources = Map.insert r p (definedResources st) } ) saveVariables vars = modify (\st -> st { curVariables = vars })+-} +addDefinedResource :: ResIdentifier -> SourcePos -> CatalogMonad ()+addDefinedResource r p = definedResources.at r ?= p+ showScope :: [[ScopeName]] -> T.Text showScope = tshow . reverse . concatMap (take 1) throwPosError :: T.Text -> CatalogMonad a throwPosError msg = do- p <- getPos+ p <- use curPos st <- fmap (map T.pack) (liftIO currentCallStack) throwError (msg <> " at " <> tshow p <> "\n\t" <> T.intercalate "\n\t" st)
language-puppet.cabal view
@@ -7,7 +7,7 @@ -- The package version. See the Haskell package versioning policy -- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for -- standards guiding when and how versions should be incremented.-Version: 0.4.0+Version: 0.4.2 -- A short (one-line) description of the package. Synopsis: Tools to parse and evaluate the Puppet DSL.@@ -46,7 +46,11 @@ Data-Files: ruby/calcerb.rb+ ruby/hrubyerb.rb +Flag Hruby+ Description: Using the hruby library to speed things up (if it is installed)+ source-repository head type: git location: git://github.com/bartavelle/language-puppet.git@@ -61,12 +65,15 @@ -- Packages needed in order to build this package. Build-depends: base >=3 && <5,parsec,containers,pretty,mtl,unix,hslogger,Glob,process,bytestring>=0.10.0.0,cryptohash,base16-bytestring,regex-pcre-builtin, iconv, text, unordered-containers, aeson, http-types, http-conduit, attoparsec, failure, hslua, vector, luautils >= 0.1.1.0, transformers, time,- pcre-utils-+ pcre-utils, lens -- Modules not exported by this package. Other-modules: Puppet.Interpreter.Functions, Puppet.NativeTypes.File, Erb.Compute, SafeProcess, Paths_language_puppet, Erb.Parser, Erb.Ruby, Erb.Evaluate Puppet.NativeTypes.ZoneRecord, Puppet.NativeTypes.Cron, Puppet.NativeTypes.Exec, Puppet.NativeTypes.Group, Puppet.NativeTypes.Host, Puppet.NativeTypes.User Puppet.NativeTypes.Mount, Puppet.Utils, Puppet.NativeTypes.Package, Puppet.NativeTypes.SshSecure, Puppet.Interpreter.RubyRandom++ if flag(hruby)+ Build-depends: hruby+ CPP-Options: -DHRUBY -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source. -- Build-tools:
+ ruby/hrubyerb.rb view
@@ -0,0 +1,62 @@+require 'erb'+require 'digest/md5'++class Scope+ def initialize(context,variables)+ @context = context+ @variables = variables+ end++ def lookupvar(name)+ if name.start_with?("::")+ name = name[2..-1]+ end+ x = varlookup(@context,@variables,name)+ if x == :undef+ throw("Unknown variable " + name + " error: " + x.to_s)+ else+ x+ end+ end++ def has_variable?(name)+ x = varlookup(@context,@variables,name)+ if x == :undef+ false+ else+ true+ end+ end+end++class ErbBinding+ def initialize(context,variables)+ @scope = Scope.new(context,variables)+ end+ def get_binding+ return binding()+ end+ def has_variable?(name)+ @scope.has_variable?(name.to_s)+ end+ def method_missing(sname)+ name = sname.to_s+ if name == 'scope'+ @scope+ else+ @scope.lookupvar(name)+ end+ end+end++class Controller+ def self.runFromFile(filename,context,variables)+ self.runFromContent(IO.read(filename),context,variables)+ end+ def self.runFromContent(content,context,variables)+ nerb = ERB.new(content, nil, "-")+ binding = ErbBinding.new(context,variables).get_binding+ nerb.result(binding)+ end+end+