diff --git a/Erb/Compute.hs b/Erb/Compute.hs --- a/Erb/Compute.hs +++ b/Erb/Compute.hs @@ -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 diff --git a/Erb/Evaluate.hs b/Erb/Evaluate.hs --- a/Erb/Evaluate.hs +++ b/Erb/Evaluate.hs @@ -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 diff --git a/Puppet/Interpreter/Catalog.hs b/Puppet/Interpreter/Catalog.hs --- a/Puppet/Interpreter/Catalog.hs +++ b/Puppet/Interpreter/Catalog.hs @@ -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 diff --git a/Puppet/Interpreter/Functions.hs b/Puppet/Interpreter/Functions.hs --- a/Puppet/Interpreter/Functions.hs +++ b/Puppet/Interpreter/Functions.hs @@ -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 diff --git a/Puppet/Interpreter/RubyRandom.hs b/Puppet/Interpreter/RubyRandom.hs --- a/Puppet/Interpreter/RubyRandom.hs +++ b/Puppet/Interpreter/RubyRandom.hs @@ -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) diff --git a/Puppet/Interpreter/Types.hs b/Puppet/Interpreter/Types.hs --- a/Puppet/Interpreter/Types.hs +++ b/Puppet/Interpreter/Types.hs @@ -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) diff --git a/language-puppet.cabal b/language-puppet.cabal --- a/language-puppet.cabal +++ b/language-puppet.cabal @@ -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: diff --git a/ruby/hrubyerb.rb b/ruby/hrubyerb.rb new file mode 100644 --- /dev/null +++ b/ruby/hrubyerb.rb @@ -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 +