diff --git a/Erb/Compute.hs b/Erb/Compute.hs --- a/Erb/Compute.hs +++ b/Erb/Compute.hs @@ -18,7 +18,7 @@ type TemplateAnswer = Either String String initTemplateDaemon :: Prefs -> IO (String -> String -> [(String, GeneralValue)] -> IO (Either String String)) -initTemplateDaemon (Prefs _ modpath templatepath _ _ _) = do +initTemplateDaemon (Prefs _ modpath templatepath _ _ _ _) = do controlchan <- newChan forkIO (templateDaemon modpath templatepath controlchan) return (templateQuery controlchan) @@ -52,7 +52,12 @@ computeTemplateWRuby filename curcontext variables = do let rubyvars = "{\n" ++ intercalate ",\n" (concatMap toRuby variables ) ++ "\n}\n" input = curcontext ++ "\n" ++ filename ++ "\n" ++ rubyvars - rubyscriptpath <- getDataFileName "ruby/calcerb.rb" + rubyscriptpath <- do + cabalPath <- getDataFileName "ruby/calcerb.rb" + exists <- fileExist cabalPath + case exists of + True -> return cabalPath + False -> return "calcerb.rb" ret <- safeReadProcessTimeout "ruby" [rubyscriptpath] input 1000 case ret of Just (Right x) -> return $ Right x diff --git a/Puppet/DSL/Parser.hs b/Puppet/DSL/Parser.hs --- a/Puppet/DSL/Parser.hs +++ b/Puppet/DSL/Parser.hs @@ -350,7 +350,7 @@ puppetResourceDefaults = do { pos <- getPosition ; rtype <- puppetQualifiedReference ; symbol "{" - ; e <- puppetAssignment `sepBy` symbol "," + ; e <- puppetAssignment `sepEndBy` symbol "," ; symbol "}" ; return [ResourceDefault rtype e pos] } @@ -390,7 +390,7 @@ symbol "{" st <- many stmtparser symbol "}" - case Map.lookup cname nativeTypes of + case Map.lookup cname baseNativeTypes of Just _ -> unexpected "Can't use a native type name for a define." Nothing -> return [DefineDeclaration cname params (concat st) pos] diff --git a/Puppet/Daemon.hs b/Puppet/Daemon.hs --- a/Puppet/Daemon.hs +++ b/Puppet/Daemon.hs @@ -5,6 +5,8 @@ import Puppet.Interpreter.Catalog import Puppet.DSL.Types import Puppet.DSL.Loader +import PuppetDB.Rest + import Erb.Compute import Control.Concurrent import System.Posix.Files @@ -19,7 +21,6 @@ import qualified Data.List.Utils as DLU import qualified Data.Map as Map import Text.Parsec.Pos (initialPos) -import PuppetDB.Rest -- this daemon returns a catalog when asked for a node and facts data DaemonMessage @@ -96,7 +97,7 @@ let pdbfunc = case (puppetDBurl prefs) of Just x -> Just (pdbResRequest x) Nothing -> Nothing - (stmts, warnings) <- getCatalog getstmts gettemplate pdbfunc nodename facts + (stmts, warnings) <- getCatalog getstmts gettemplate pdbfunc nodename facts (Just $ modules prefs) (natTypes prefs) mapM_ logWarning warnings case stmts of Left x -> writeChan respchan (RCatalog $ Left x) diff --git a/Puppet/Init.hs b/Puppet/Init.hs --- a/Puppet/Init.hs +++ b/Puppet/Init.hs @@ -2,6 +2,10 @@ module Puppet.Init where import Puppet.Interpreter.Types +import Puppet.NativeTypes +import Puppet.NativeTypes.Helpers +import Puppet.Plugins + import qualified Data.Map as Map data Prefs = Prefs { @@ -10,14 +14,21 @@ templates :: FilePath, -- ^ The path to the template. compilepoolsize :: Int, -- ^ Size of the compiler pool. parsepoolsize :: Int, -- ^ Size of the parser pool. - puppetDBurl :: Maybe String -- ^ Url of the PuppetDB connector (must be cleartext). -} deriving (Show) + puppetDBurl :: Maybe String, -- ^ Url of the PuppetDB connector (must be cleartext). + natTypes :: Map.Map PuppetTypeName PuppetTypeMethods -- ^ The list of native types. +} -- | Generates the 'Prefs' structure from a single path. -- -- > genPrefs "/etc/puppet" -genPrefs :: String -> Prefs -genPrefs basedir = Prefs (basedir ++ "/manifests") (basedir ++ "/modules") (basedir ++ "/templates") 1 1 Nothing +genPrefs :: String -> IO Prefs +genPrefs basedir = do + let manifestdir = basedir ++ "/manifests" + modulesdir = basedir ++ "/modules" + templatedir = basedir ++ "/templates" + typenames <- fmap (map getBasename) (getFiles modulesdir "lib/puppet/type" ".rb") + let loadedTypes = Map.fromList (map defaulttype typenames) + return $ Prefs manifestdir modulesdir templatedir 1 1 Nothing (Map.union baseNativeTypes loadedTypes) -- | Generates 'Facts' from pairs of strings. -- diff --git a/Puppet/Interpreter/Catalog.hs b/Puppet/Interpreter/Catalog.hs --- a/Puppet/Interpreter/Catalog.hs +++ b/Puppet/Interpreter/Catalog.hs @@ -33,11 +33,10 @@ ) where import Puppet.DSL.Types -import Puppet.NativeTypes -import Puppet.NativeTypes.Helpers import Puppet.Interpreter.Functions import Puppet.Interpreter.Types import Puppet.Printers +import Puppet.Plugins import qualified PuppetDB.Query as PDB import System.IO.Unsafe @@ -85,11 +84,16 @@ -- ResolvedValue, or some error. -> String -- ^ Name of the node. -> Facts -- ^ Facts of this node. + -> Maybe String -- ^ Path to the modules, for user plugins. If set to Nothing, plugins are disabled. + -> Map.Map PuppetTypeName PuppetTypeMethods -- ^ The list of native types -> IO (Either String FinalCatalog, [String]) -getCatalog getstatements gettemplate puppetdb nodename facts = do +getCatalog getstatements gettemplate puppetdb nodename facts modules ntypes = do let convertedfacts = Map.map (\fval -> (Right fval, initialPos "FACTS")) facts + (luastate, userfunctions) <- case modules of + Just m -> fmap (\(a,b) -> (Just a, b)) (initLua m) + Nothing -> return (Nothing, []) (output, finalstate) <- runStateT ( runErrorT ( computeCatalog getstatements nodename ) ) (ScopeState { curScope = [["::"]] @@ -105,7 +109,13 @@ , unresolvedRels = [] , computeTemplateFunction = gettemplate , puppetDBFunction = puppetdb + , luaState = luastate + , userFunctions = Set.fromList userfunctions + , nativeTypes = ntypes } ) + case luastate of + Just l -> closeLua l + Nothing -> return () case output of Left x -> return (Left x, getWarnings finalstate) Right _ -> return (output, getWarnings finalstate) @@ -128,12 +138,13 @@ checkDuplicateFirst rparams -- add collected relations -- TODO - unless (Map.member ctype nativeTypes) $ throwPosError $ "Can't find native type " ++ ctype + ntypes <- fmap nativeTypes get + unless (Map.member ctype ntypes) $ throwPosError $ "Can't find native type " ++ ctype -- now run the collection checks for overrides nparams <- processOverride cr (Map.fromList rparams) let mrrelations = [] prefinalresource = RResource cid rname ctype nparams mrrelations cpos - validatefunction = puppetvalidate (nativeTypes Map.! ctype) + validatefunction = puppetvalidate (ntypes Map.! ctype) validated = validatefunction prefinalresource case validated of Left err -> throwError (err ++ " for resource " ++ ctype ++ "[" ++ rname ++ "] at " ++ show cpos) @@ -191,12 +202,12 @@ finalResolution :: Catalog -> CatalogMonad FinalCatalog finalResolution cat = do - pdbfunction <- fmap puppetDBFunction get - fqdnr <- getVariable "::fqdn" + pdbfunction <- fmap puppetDBFunction get + fqdnr <- getVariable "::fqdn" collectedRemote <- case pdbfunction of Just f -> do fqdn <- case fqdnr of - Just (Right (ResolvedString f), _) -> return f + Just (Right (ResolvedString f'), _) -> return f' _ -> throwError "Could not get FQDN during final resolution" remoteCollects <- fmap (catMaybes . map (\(_,_,x) -> x) . curCollect) get fmap concat (mapM (retrieveRemoteResources (f fqdn)) remoteCollects) @@ -206,6 +217,7 @@ collected <- mapM evaluateDefine (collectedLocal ++ collectedRemote') let (real, allvirtual) = partition (\x -> crvirtuality x == Normal) (concat collected) (_, exported) = partition (\x -> crvirtuality x == Virtual) allvirtual + -- TODO --export stuff --liftIO $ putStrLn "EXPORTED:" --liftIO $ mapM print exported @@ -283,7 +295,7 @@ -- finds out if a resource name refers to a define checkDefine :: String -> CatalogMonad (Maybe Statement) -checkDefine dname = if Map.member dname nativeTypes +checkDefine dname = fmap nativeTypes get >>= \nt -> if Map.member dname nt then return Nothing else do curstate <- get @@ -705,6 +717,7 @@ p <- getPos throwError ("'" ++ show e ++ "' will not resolve to a string at " ++ show p) + resolveExpression :: Expression -> CatalogMonad ResolvedValue resolveExpression e = do resolved <- tryResolveExpression e @@ -727,6 +740,7 @@ tryResolveValue :: Value -> CatalogMonad GeneralValue tryResolveValue (Literal x) = return $ Right $ ResolvedString x tryResolveValue (Integer x) = return $ Right $ ResolvedInt x +tryResolveValue (Double x) = return $ Right $ ResolvedDouble x tryResolveValue n@(ResourceReference rtype vals) = do rvals <- tryResolveExpression vals @@ -836,7 +850,6 @@ case es of Right s -> liftM (Right . ResolvedString) (mysql_password s) Left u -> return $ Left u -tryResolveValue (FunctionCall "jbossmem" _) = return $ Right $ ResolvedString "512" tryResolveValue (FunctionCall "template" [name]) = do fname <- tryResolveExpressionString name case fname of @@ -855,9 +868,10 @@ case rv of Left n -> return $ Left n -- TODO BUG - Right (ResolvedString typeorclass) -> + Right (ResolvedString typeorclass) -> do + ntypes <- fmap nativeTypes get -- is it a loaded class or a define ? - if Map.member typeorclass nativeTypes + if Map.member typeorclass ntypes then return $ Right $ ResolvedBool True else do isdefine <- checkDefine typeorclass @@ -924,7 +938,16 @@ Just x -> return $ Right $ ResolvedString x else return $ Left $ Value n -tryResolveValue (FunctionCall fname _) = throwPosError ("FunctionCall " ++ fname ++ " not implemented") +tryResolveValue n@(FunctionCall fname args) = do + ufunctions <- fmap userFunctions get + l <- fmap luaState get + case (l, Set.member fname ufunctions) of + (Just ls, True) -> do + rargs <- mapM tryResolveExpression args + if null (lefts rargs) + then fmap Right (puppetFunc ls fname (rights rargs)) + else return $ Left $ Value n + _ -> throwPosError ("FunctionCall " ++ fname ++ " not implemented") tryResolveValue Undefined = return $ Right ResolvedUndefined tryResolveValue (PuppetRegexp x) = return $ Right $ ResolvedRegexp x @@ -937,6 +960,7 @@ case r of Right (ResolvedString v) -> return $ Right v Right (ResolvedInt i) -> return $ Right (show i) + Right (ResolvedDouble i) -> return $ Right (show i) Right v -> throwPosError ("Can't resolve valuestring for " ++ show v) Left v -> return $ Left v @@ -1085,7 +1109,7 @@ _ -> throwPosError "We only support collection of the form 'parameter == value'" defstatement <- checkDefine mrtype paramset <- case defstatement of - Nothing -> case Map.lookup mrtype nativeTypes of + Nothing -> fmap nativeTypes get >>= \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 diff --git a/Puppet/Interpreter/Types.hs b/Puppet/Interpreter/Types.hs --- a/Puppet/Interpreter/Types.hs +++ b/Puppet/Interpreter/Types.hs @@ -1,7 +1,9 @@ module Puppet.Interpreter.Types where import Puppet.DSL.Types + import qualified PuppetDB.Query as PDB +import qualified Scripting.Lua as Lua import Text.Parsec.Pos import Control.Monad.State import Control.Monad.Error @@ -10,6 +12,16 @@ import GHC.Exts import Data.List +-- | Types for the native type system. +type PuppetTypeName = String +-- |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 String + } + -- | This is the potentially unsolved list of resources in the catalog. type Catalog =[CResource] type Facts = Map.Map String ResolvedValue @@ -130,9 +142,15 @@ computeTemplateFunction :: String -> String -> [(String, GeneralValue)] -> IO (Either String String), -- ^ Function that takes a filename, the current scope and a list of -- variables. It returns an error or the computed template. - puppetDBFunction :: Maybe (String -> PDB.Query -> IO (Either String [CResource])) - -- ^ Function that takes a fqdn, request type (resources, nodes, facts, ..) - -- and a query, and returns a resolved value from puppetDB. + puppetDBFunction :: Maybe (String -> PDB.Query -> IO (Either String [CResource])), + -- ^ Function that takes a request type (resources, nodes, facts, ..), + -- a query, and returns a resolved value from puppetDB. + luaState :: Maybe Lua.LuaState, + -- ^ The Lua state, used for user supplied content. + userFunctions :: Set.Set String, + -- ^ The list of registered user functions + nativeTypes :: Map.Map PuppetTypeName PuppetTypeMethods + -- ^ The list of native types. } -- | The monad all the interpreter lives in. It is 'ErrorT' with a state. diff --git a/Puppet/NativeTypes.hs b/Puppet/NativeTypes.hs --- a/Puppet/NativeTypes.hs +++ b/Puppet/NativeTypes.hs @@ -1,5 +1,5 @@ {-| This module holds the /native/ Puppet resource types. -} -module Puppet.NativeTypes (nativeTypes) where +module Puppet.NativeTypes (baseNativeTypes) where import Puppet.NativeTypes.Helpers import Puppet.NativeTypes.File @@ -9,15 +9,16 @@ import Puppet.NativeTypes.Host import Puppet.NativeTypes.Mount import Puppet.NativeTypes.ZoneRecord +import Puppet.Interpreter.Types import qualified Data.Map as Map fakeTypes = map faketype ["class", "ssh_authorized_key_secure"] -defaultTypes = map defaulttype ["augeas","computer","filebucket","interface","k5login","macauthorization","mailalias","maillist","mcx","nagios_command","nagios_contact","nagios_contactgroup","nagios_host","nagios_hostdependency","nagios_hostescalation","nagios_hostextinfo","nagios_hostgroup","nagios_service","nagios_servicedependency","nagios_serviceescalation","nagios_serviceextinfo","nagios_servicegroup","nagios_timeperiod","notify","package","resources","router","schedule","scheduledtask","selboolean","selmodule","service","sshauthorizedkey","sshkey","stage","tidy","user","vlan","yumrepo","zfs","zone","zpool","mysql_database","mysql_user","mysql_grant","anchor"] +defaultTypes = map defaulttype ["augeas","computer","filebucket","interface","k5login","macauthorization","mailalias","maillist","mcx","nagios_command","nagios_contact","nagios_contactgroup","nagios_host","nagios_hostdependency","nagios_hostescalation","nagios_hostextinfo","nagios_hostgroup","nagios_service","nagios_servicedependency","nagios_serviceescalation","nagios_serviceextinfo","nagios_servicegroup","nagios_timeperiod","notify","package","resources","router","schedule","scheduledtask","selboolean","selmodule","service","sshauthorizedkey","sshkey","stage","tidy","user","vlan","yumrepo","zfs","zone","zpool"] -- | The map of native types. They are described in "Puppet.NativeTypes.Helpers". -nativeTypes :: Map.Map PuppetTypeName PuppetTypeMethods -nativeTypes = Map.fromList +baseNativeTypes :: Map.Map PuppetTypeName PuppetTypeMethods +baseNativeTypes = Map.fromList ( nativeHost : nativeMount : nativeGroup diff --git a/Puppet/NativeTypes/Exec.hs b/Puppet/NativeTypes/Exec.hs --- a/Puppet/NativeTypes/Exec.hs +++ b/Puppet/NativeTypes/Exec.hs @@ -1,6 +1,7 @@ module Puppet.NativeTypes.Exec (nativeExec) where import Puppet.NativeTypes.Helpers +import Puppet.Interpreter.Types import Control.Monad.Error import qualified Data.Set as Set diff --git a/Puppet/NativeTypes/Group.hs b/Puppet/NativeTypes/Group.hs --- a/Puppet/NativeTypes/Group.hs +++ b/Puppet/NativeTypes/Group.hs @@ -1,6 +1,7 @@ module Puppet.NativeTypes.Group (nativeGroup) where import Puppet.NativeTypes.Helpers +import Puppet.Interpreter.Types import Control.Monad.Error import qualified Data.Set as Set diff --git a/Puppet/NativeTypes/Helpers.hs b/Puppet/NativeTypes/Helpers.hs --- a/Puppet/NativeTypes/Helpers.hs +++ b/Puppet/NativeTypes/Helpers.hs @@ -9,15 +9,6 @@ import Data.Char (isDigit) import Control.Monad -type PuppetTypeName = String --- |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 String - } - faketype :: PuppetTypeName -> (PuppetTypeName, PuppetTypeMethods) faketype tname = (tname, PuppetTypeMethods Right Set.empty) diff --git a/Puppet/NativeTypes/Mount.hs b/Puppet/NativeTypes/Mount.hs --- a/Puppet/NativeTypes/Mount.hs +++ b/Puppet/NativeTypes/Mount.hs @@ -1,6 +1,7 @@ module Puppet.NativeTypes.Mount (nativeMount) where import Puppet.NativeTypes.Helpers +import Puppet.Interpreter.Types import Control.Monad.Error import qualified Data.Set as Set diff --git a/Puppet/NativeTypes/ZoneRecord.hs b/Puppet/NativeTypes/ZoneRecord.hs --- a/Puppet/NativeTypes/ZoneRecord.hs +++ b/Puppet/NativeTypes/ZoneRecord.hs @@ -1,8 +1,8 @@ module Puppet.NativeTypes.ZoneRecord (nativeZoneRecord) where import Puppet.NativeTypes.Helpers -import Control.Monad.Error import Puppet.Interpreter.Types +import Control.Monad.Error import qualified Data.Map as Map import qualified Data.Set as Set diff --git a/Puppet/Plugins.hs b/Puppet/Plugins.hs new file mode 100644 --- /dev/null +++ b/Puppet/Plugins.hs @@ -0,0 +1,155 @@ +{-| This module is used for user plugins. It exports three functions that should +be easy to use: 'initLua', 'puppetFunc' and 'closeLua'. Right now it is used by +the "Puppet.Daemon" by initializing and destroying the Lua context for each +catalog computation. Obviously such plugins will be implemented in Lua. + +Users plugins are right now limited to custom functions. The user must put them +at the exact same place as their Ruby counterparts, except the extension must be +lua instead of rb. In the file, a function called by the same name that takes a +single argument must be defined. This argument will be an array made of all the +functions arguments. If the file doesn't parse, it will be silently ignored. + +Here are the things that must be kept in mind: + +* Lua doesn't have integers. All numbers are double. + +* All Lua associative arrays that are returned must have a "simple" type for all +the keys, as it will be converted to a string. Numbers will be directly +converted and other types will produce strange results. + +* This currently only works for functions that must return a value. They will +have no access to the manifests data. +-} +module Puppet.Plugins (initLua, puppetFunc, closeLua, getFiles, getBasename) where + +import Prelude hiding (catch) +import qualified Scripting.Lua as Lua +import Scripting.LuaUtils() +import System.Directory +import Control.Exception +import Data.String.Utils (endswith) +import qualified Data.Map as Map +import Control.Monad +import Data.Maybe (fromJust) +import Control.Monad.Loops (whileM) +import Control.Monad.IO.Class + +import Puppet.Interpreter.Types +import Puppet.Printers + +instance Lua.StackValue ResolvedValue + where + push l (ResolvedString s) = Lua.push l s + push l (ResolvedRegexp s) = Lua.push l s + push l (ResolvedInt i) = Lua.push l (fromIntegral i :: Int) + push l (ResolvedDouble d) = Lua.push l d + push l (ResolvedBool b) = Lua.push l b + push l (ResolvedRReference rr _) = Lua.push l rr + push l (ResolvedArray arr) = Lua.push l arr + push l (ResolvedHash h) = Lua.push l (Map.fromList h) + push l (ResolvedUndefined) = Lua.push l "undefined" + + peek l n = do + t <- Lua.ltype l n + case t of + Lua.TBOOLEAN -> fmap (fmap ResolvedBool) (Lua.peek l n) + Lua.TSTRING -> fmap (fmap ResolvedString) (Lua.peek l n) + Lua.TNUMBER -> fmap (fmap ResolvedDouble) (Lua.peek l n) + Lua.TNIL -> return (Just ResolvedUndefined) + Lua.TNONE -> return (Just ResolvedUndefined) + Lua.TTABLE -> do + p <- Lua.peek l n :: IO (Maybe (Map.Map ResolvedValue ResolvedValue)) + case p of + Just kp -> let ks = Map.keys kp + cp = map (\(a,b) -> (showValue a, b)) $ Map.toList kp + in if (all (\(a,b) -> a == ResolvedDouble b) (zip ks [1.0..])) + -- horrible trick to check whether we are being returned a list or a hash + -- this will probably fail somehow + then return $ Just (ResolvedArray (map snd cp)) + else return $ Just (ResolvedHash cp) + _ -> return Nothing + _ -> return Nothing + + valuetype _ = Lua.TUSERDATA + +instance (Lua.StackValue a, Lua.StackValue b, Ord a) => Lua.StackValue (Map.Map a b) + where + push l mp = do + let llen = Map.size mp + 1 + Lua.createtable l llen 0 + forM_ (Map.toList mp) $ \(key, val) -> do + Lua.push l key + Lua.push l val + Lua.rawset l (-3) + peek l i = do + top <- Lua.gettop l + let ix = if (i < 0) then top + i + 1 else i + Lua.pushnil l + arr <- whileM (Lua.next l ix) $ do + xk <- Lua.peek l (-2) + xv <- Lua.peek l (-1) + Lua.pop l 1 + return (fromJust xk, fromJust xv) + return $ Just (Map.fromList arr) + valuetype _ = Lua.TTABLE + + +getDirContents :: FilePath -> IO [FilePath] +getDirContents x = fmap (filter (not . all (=='.'))) (getDirectoryContents x) + +-- find files in subdirectories +checkForSubFiles :: String -> String -> IO [String] +checkForSubFiles extension dir = do + content <- catch (fmap Right (getDirContents dir)) (\e -> return $ Left (e :: IOException)) + case content of + Right o -> do + return ((map (\x -> dir ++ "/" ++ x) . filter (endswith extension)) o ) + Left _ -> return [] + +-- Find files in the module directory that are in a module subdirectory and +-- finish with a specific extension +getFiles :: String -> String -> String -> IO [String] +getFiles moduledir subdir extension = + getDirContents moduledir + >>= mapM ( (checkForSubFiles extension) . (\x -> moduledir ++ "/" ++ x ++ "/" ++ subdir)) + >>= return . concat + +getLuaFiles :: String -> IO [String] +getLuaFiles moduledir = getFiles moduledir "lib/puppet/parser/functions" ".lua" + +-- retrieves the base name of a file (very slow and naïve implementation). +getBasename :: String -> String +getBasename fullname = + let lastpart = reverse $ fst $ break (=='/') $ reverse fullname + in fst $ break (=='.') lastpart + +loadLuaFile :: Lua.LuaState -> String -> IO [String] +loadLuaFile l file = do + r <- Lua.loadfile l file + case r of + 0 -> Lua.call l 0 0 >> return [getBasename file] + _ -> return [] +{-| Runs a puppet function in the 'CatalogMonad' monad. It takes a state, +function name and list of arguments. It returns a valid Puppet value. +-} +puppetFunc :: Lua.LuaState -> String -> [ResolvedValue] -> CatalogMonad ResolvedValue +puppetFunc l fn args = do + content <- liftIO $ catch (fmap Right (Lua.callfunc l fn args)) (\e -> return $ Left $ show (e :: SomeException)) + case content of + Right x -> return x + Left y -> throwPosError y + +-- | Initializes the Lua state. The argument is the modules directory. Each +-- subdirectory will be traversed for functions. +-- The default location is @\/lib\/puppet\/parser\/functions@. +initLua :: String -> IO (Lua.LuaState, [String]) +initLua moduledir = do + funcfiles <- getLuaFiles moduledir + l <- Lua.newstate + Lua.openlibs l + luafuncs <- fmap concat $ mapM (loadLuaFile l) funcfiles + return (l , luafuncs) + +-- | Obviously releases the Lua state. +closeLua :: Lua.LuaState -> IO () +closeLua = Lua.close 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.1.8.0 +Version: 0.2.0 -- A short (one-line) description of the package. Synopsis: Tools to parse and evaluate the Puppet DSL. @@ -47,16 +47,15 @@ Data-Files: ruby/calcerb.rb - Library ghc-options: -Wall -fno-warn-missing-signatures -fno-warn-unused-do-bind -funbox-strict-fields -- Modules exported by the library. Exposed-modules: Puppet.DSL.Parser, Puppet.DSL.Printer, Puppet.Daemon, Puppet.Init, Puppet.DSL.Loader, Puppet.Printers, Puppet.NativeTypes, Puppet.DSL.Types, - Puppet.Interpreter.Types, Puppet.Interpreter.Catalog, Puppet.NativeTypes.Helpers, PuppetDB.Rest, PuppetDB.Query + Puppet.Interpreter.Types, Puppet.Interpreter.Catalog, Puppet.NativeTypes.Helpers, PuppetDB.Rest, PuppetDB.Query, Puppet.Plugins -- Packages needed in order to build this package. Build-depends: base >=3 && <5,parsec,MissingH,containers,pretty,mtl,unix,hslogger,filepath,Glob,regexpr,process,bytestring,cryptohash,base16-bytestring,regex-pcre-builtin, - iconv, text, unordered-containers, aeson, vector, http-types, http-conduit, attoparsec, failure + iconv, text, unordered-containers, aeson, vector, http-types, http-conduit, attoparsec, failure, hslua, monad-loops, directory, luautils, transformers -- 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 diff --git a/test/interpreter.hs b/test/interpreter.hs --- a/test/interpreter.hs +++ b/test/interpreter.hs @@ -44,7 +44,7 @@ topclass = ClassDeclaration "::" Nothing [] othertoplevels (initialPos fp) stmtpmap :: Map.Map (TopLevelType, String) Statement stmtpmap = foldl' (\mp (ttype,tname,ts) -> Map.insert (ttype,tname) (TopContainer [(fp, topclass)] ts) mp) Map.empty oktoplevels - ctlg <- getCatalog (getstatement stmtpmap) gettemplate "test" facts + ctlg <- getCatalog (getstatement stmtpmap) gettemplate Nothing "test" facts (Just "test/modules") print ctlg case ctlg of (Right _, _) -> return ("PASS", True)