diff --git a/Erb/Compute.hs b/Erb/Compute.hs --- a/Erb/Compute.hs +++ b/Erb/Compute.hs @@ -10,6 +10,9 @@ import Control.Concurrent import System.Posix.Files import Paths_language_puppet (getDataFileName) +import Erb.Parser +import Erb.Evaluate +import qualified Data.Map as Map type TemplateQuery = (Chan TemplateAnswer, String, String, [(String, GeneralValue)]) type TemplateAnswer = Either String String @@ -40,6 +43,13 @@ computeTemplate :: String -> String -> [(String, GeneralValue)] -> IO TemplateAnswer computeTemplate filename curcontext variables = do + parsed <- parseErbFile filename + case parsed of + Left _ -> computeTemplateWRuby filename curcontext variables + Right ast -> return $ rubyEvaluate (Map.fromList variables) curcontext ast + +computeTemplateWRuby :: String -> String -> [(String, GeneralValue)] -> IO TemplateAnswer +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" diff --git a/Erb/Evaluate.hs b/Erb/Evaluate.hs new file mode 100644 --- /dev/null +++ b/Erb/Evaluate.hs @@ -0,0 +1,60 @@ +module Erb.Evaluate (rubyEvaluate) where + +import qualified Data.Map as Map +import Puppet.Interpreter.Types +import Erb.Ruby +import Data.Maybe (catMaybes) +import Data.Either (rights) +import Control.Monad.Error +import Data.Char + +rubyEvaluate :: Map.Map String GeneralValue -> String -> [RubyStatement] -> Either String String +rubyEvaluate vars ctx = foldl (evalruby vars ctx) (Right "") + +evalruby :: Map.Map String GeneralValue -> String -> Either String String -> RubyStatement -> Either String String +evalruby _ _ (Left err) _ = Left err +evalruby mp ctx (Right curstr) (Puts e) = case evalExpression mp ctx e of + Left err -> Left err + Right ex -> Right (curstr ++ ex) + +evalExpression :: Map.Map String GeneralValue -> String -> Expression -> Either String String +evalExpression mp ctx (LookupOperation varname varindex) = do + rvname <- evalExpression mp ctx varname + rvindx <- evalExpression mp ctx varindex + varvalue <- getVariable mp ctx rvname + case varvalue of + ResolvedArray arr -> do + case (a2i rvindx) of + Nothing -> throwError $ "Can't convert index to integer when resolving " ++ rvname ++ "[" ++ rvindx ++ "]" + Just i -> if length arr <= i + then throwError $ "Array out of bound " ++ rvname ++ "[" ++ rvindx ++ "]" + else return $ arr !! i + return "x" + ResolvedHash hs -> case (filter (\(a,_) -> a == rvindx) hs) of + [] -> throwError $ "No index " ++ rvindx ++ " for variable " ++ show varname + (_,x):_ -> evalValue $ Right x + x -> throwError $ "Can't index variable " ++ show varname ++ ", it is " ++ show x +evalExpression _ _ (Value (Literal x)) = Right x +evalExpression mp ctx (Object (Value (Literal x))) = getVariable mp ctx x >>= evalValue . Right +evalExpression _ _ x = Left $ "Can't evaluate " ++ show x + +getVariable :: Map.Map String GeneralValue -> String -> String -> Either String ResolvedValue +getVariable mp ctx rvname = + let vars = map (\x -> Map.lookup x mp) [rvname, ctx ++ "::" ++ rvname, "::" ++ rvname] + jsts = catMaybes vars + rghts = rights jsts + in do + when (null jsts) (throwError $ "Can't resolve variable " ++ rvname) + when (null rghts) (throwError $ "Variable " ++ rvname ++ " value is not resolved") + return (head rghts) + + +evalValue :: GeneralValue -> Either String String +evalValue (Left _) = Left $ "Can't evaluate a value" +evalValue (Right (ResolvedString x)) = Right x +evalValue (Right (ResolvedInt x)) = Right $ show x +evalValue (Right x) = Right $ show x + +a2i :: String -> Maybe Int +a2i x | all isDigit x = read x + | otherwise = Nothing diff --git a/Puppet/DSL/Parser.hs b/Puppet/DSL/Parser.hs --- a/Puppet/DSL/Parser.hs +++ b/Puppet/DSL/Parser.hs @@ -238,7 +238,7 @@ puppetRegexpExpr = puppetRegexp >>= return . Value . PuppetRegexp singleQuotedString = do { char '\'' - ; v <- many ( do { char '\\' ; x <- anyChar; return [x] } <|> many1 (noneOf "'\\") ) + ; v <- many ( do { char '\\' ; x <- anyChar; if x=='\'' then return "'" else return ['\\',x] } <|> many1 (noneOf "'\\") ) ; char '\'' ; whiteSpace ; return $ concat v diff --git a/Puppet/Daemon.hs b/Puppet/Daemon.hs --- a/Puppet/Daemon.hs +++ b/Puppet/Daemon.hs @@ -87,7 +87,7 @@ QCatalog (nodename, facts, respchan) -> do logDebug ("Received query for node " ++ nodename) (stmts, warnings) <- getCatalog getstmts gettemplate nodename facts - mapM logWarning warnings + mapM_ logWarning warnings case stmts of Left x -> writeChan respchan (RCatalog $ Left x) Right x -> writeChan respchan (RCatalog $ Right x) @@ -115,7 +115,7 @@ logDebug "initParserDaemon" controlChan <- newChan getparsed <- initParsedDaemon prefs - forkIO (pmaster prefs controlChan (getparsed)) + forkIO (pmaster prefs controlChan getparsed) return (getStatements controlChan) -- extracts data from a filestatus @@ -151,20 +151,20 @@ compilefilelist prefs _ name = moduleInfo where moduleInfo | length nameparts == 1 = [modules prefs ++ "/" ++ name ++ "/manifests/init.pp"] - | otherwise = [modules prefs ++ "/" ++ (head nameparts) ++ "/manifests/" ++ (DLU.join "/" (tail nameparts)) ++ ".pp"] + | otherwise = [modules prefs ++ "/" ++ head nameparts ++ "/manifests/" ++ DLU.join "/" (tail nameparts) ++ ".pp"] nameparts = DLU.split "::" name findFile :: Prefs -> TopLevelType -> String -> ErrorT String IO (FilePath, FileStatus) findFile prefs qtype resname = do let filelist = compilefilelist prefs qtype resname - fileinfo <- liftIO $ foldlM (getFirstFileInfo) Nothing filelist + fileinfo <- liftIO $ foldlM getFirstFileInfo Nothing filelist case fileinfo of Just x -> return x - Nothing -> throwError ("Could not find file for " ++ show qtype ++ " " ++ resname ++ " when looking in " ++ (show filelist)) + Nothing -> throwError ("Could not find file for " ++ show qtype ++ " " ++ resname ++ " when looking in " ++ show filelist) globImport :: FilePath -> Statement -> ErrorT String IO [FilePath] globImport origfile (Import importname ipos) = do - importedfiles <- liftIO $ globDir [compile importname] (takeDirectory origfile) >>= return . concat . fst + importedfiles <- liftM (concat . fst) (liftIO $ globDir [compile importname] (takeDirectory origfile)) if null importedfiles then throwError $ "Could not import " ++ importname ++ " at " ++ show ipos else return importedfiles @@ -175,7 +175,7 @@ it must also parse all required files and store everything about them before returning -} -loadUpdateFile :: FilePath -> FileStatus -> (TopLevelType -> String -> CacheEntry -> IO ( ParsedCacheResponse ) ) -> ErrorT String IO ([Statement], [(TopLevelType, String, Statement)]) +loadUpdateFile :: FilePath -> FileStatus -> (TopLevelType -> String -> CacheEntry -> IO ParsedCacheResponse ) -> ErrorT String IO ([Statement], [(TopLevelType, String, Statement)]) loadUpdateFile fname fstatus updatepinfo = do liftIO $ logDebug ("Loading file " ++ fname) parsed <- parseFile fname @@ -185,34 +185,32 @@ (imports, spurioustoplevels) = partition isImport othertoplevels isImport (Import _ _) = True isImport _ = False - relatedtops <- mapM (globImport fname) imports >>= return . concat + relatedtops <- liftM concat (mapM (globImport fname) imports) -- save this spurious top levels - if null spurioustoplevels - then return () - else do - liftIO ( updatepinfo TopSpurious fname (ClassDeclaration "::" Nothing [] spurioustoplevels (initialPos fname), fname, fstatus, relatedtops) >> return () ) + unless (null spurioustoplevels) $ do + liftIO $ void ( updatepinfo TopSpurious fname (ClassDeclaration "::" Nothing [] spurioustoplevels (initialPos fname), fname, fstatus, relatedtops) ) liftIO $ logWarning ("Spurious top level statement in file " ++ fname ++ ", expect bugs in case you modify them" ) -- saves all good top levels liftIO $ mapM (\(rtype, resname, resstatement) -> updatepinfo rtype resname (resstatement, fname, fstatus, relatedtops)) oktoplevels return (imports, oktoplevels) -reparseStatements :: Prefs -> (TopLevelType -> String -> CacheEntry -> IO ( ParsedCacheResponse ) ) -> TopLevelType -> String -> ErrorT String IO Statement +reparseStatements :: Prefs -> (TopLevelType -> String -> CacheEntry -> IO ParsedCacheResponse ) -> TopLevelType -> String -> ErrorT String IO Statement reparseStatements prefs updatepinfo qtype nodename = do (fname, fstatus) <- findFile prefs qtype nodename reparseFile fname fstatus updatepinfo qtype nodename -reparseFile :: FilePath -> FileStatus -> (TopLevelType -> String -> CacheEntry -> IO ( ParsedCacheResponse ) ) -> TopLevelType -> String -> ErrorT String IO Statement +reparseFile :: FilePath -> FileStatus -> (TopLevelType -> String -> CacheEntry -> IO ParsedCacheResponse ) -> TopLevelType -> String -> ErrorT String IO Statement reparseFile fname fstatus updatepinfo qtype nodename = do (imports, oktoplevels) <- loadUpdateFile fname fstatus updatepinfo - imported <- mapM (loadImport updatepinfo fname) imports >>= return . concat + imported <- liftM concat (mapM (loadImport updatepinfo fname) imports) let searchstatement = find (\(qt,nm,_) -> (qt == qtype) && (nm == nodename)) (oktoplevels ++ imported) case searchstatement of Just (_,_,x) -> return x - Nothing -> throwError ("Could not find correct top level statement for " ++ (show qtype) ++ " " ++ nodename) + Nothing -> throwError ("Could not find correct top level statement for " ++ show qtype ++ " " ++ nodename) -loadImport :: (TopLevelType -> String -> CacheEntry -> IO ( ParsedCacheResponse ) ) -> FilePath -> Statement -> ErrorT String IO [(TopLevelType, String, Statement)] +loadImport :: (TopLevelType -> String -> CacheEntry -> IO ParsedCacheResponse ) -> FilePath -> Statement -> ErrorT String IO [(TopLevelType, String, Statement)] loadImport updatepinfo fdir mimport = do matched <- globImport fdir mimport -- globDir [compile importstring] fdir >>= return . concat . fst @@ -221,7 +219,7 @@ goodpathinfos = concatMap unjust fpathinfos unjust (a, Just b) = [(a,b)] unjust _ = [] - mapM (\(fname, finfo) -> loadUpdateFile fname finfo updatepinfo) goodpathinfos >>= return . concatMap snd + liftM (concatMap snd) (mapM (\(fname, finfo) -> loadUpdateFile fname finfo updatepinfo) goodpathinfos) loadRelated :: ( TopLevelType -> String -> ErrorT String IO (Maybe CacheEntry) ) @@ -232,13 +230,13 @@ case res of Nothing -> return [] Just (stmts, _, _, related) -> do - relstatements <- mapM (loadRelated getpinfo) related >>= return . concat + relstatements <- liftM concat (mapM (loadRelated getpinfo) related) return $ (filename,stmts):relstatements handlePRequest :: Prefs -> ( TopLevelType -> String -> ErrorT String IO (Maybe CacheEntry) - , TopLevelType -> String -> CacheEntry -> IO ( ParsedCacheResponse ) - , String -> IO ( ParsedCacheResponse ) + , TopLevelType -> String -> CacheEntry -> IO ParsedCacheResponse + , String -> IO ParsedCacheResponse ) -> TopLevelType -> String -> ErrorT String IO Statement handlePRequest prefs (getpinfo, updatepinfo, invalidateinfo) qtype nodename = do res <- getpinfo qtype nodename @@ -246,7 +244,7 @@ Just (stmts, fpath, fstatus, related) -> do -- for this to work, everything must be cached -- this is buggy as the required stuff will not be invalidated properly - relstatements <- mapM (loadRelated getpinfo) (fpath:related) >>= return . concat + relstatements <- liftM concat (mapM (loadRelated getpinfo) (fpath:related)) isfileinfoaccurate <- checkFileInfo fpath fstatus statements <- if isfileinfoaccurate then return stmts @@ -263,8 +261,8 @@ pmaster :: Prefs -> Chan ParserMessage -> ( TopLevelType -> String -> ErrorT String IO (Maybe CacheEntry) - , TopLevelType -> String -> CacheEntry -> IO ( ParsedCacheResponse ) - , String -> IO ( ParsedCacheResponse ) + , TopLevelType -> String -> CacheEntry -> IO ParsedCacheResponse + , String -> IO ParsedCacheResponse ) -> IO () pmaster prefs chan cachefuncs = do pmessage <- readChan chan @@ -303,8 +301,8 @@ -- this one is singleton, and is used to cache de parsed values, along with the file names they depend on initParsedDaemon :: Prefs -> IO ( TopLevelType -> String -> ErrorT String IO (Maybe CacheEntry) - , TopLevelType -> String -> CacheEntry -> IO ( ParsedCacheResponse ) - , String -> IO ( ParsedCacheResponse ) + , TopLevelType -> String -> CacheEntry -> IO ParsedCacheResponse + , String -> IO ParsedCacheResponse ) initParsedDaemon prefs = do logDebug "initParsedDaemon" @@ -323,13 +321,13 @@ CacheError x -> throwError x _ -> throwError "Unknown cache response type" -updateParsedInformation :: Chan ParsedCacheQuery -> TopLevelType -> String -> CacheEntry -> IO (ParsedCacheResponse) +updateParsedInformation :: Chan ParsedCacheQuery -> TopLevelType -> String -> CacheEntry -> IO ParsedCacheResponse updateParsedInformation pchannel qtype name centry = do respchan <- newChan writeChan pchannel $ UpdateParsedData qtype name centry respchan readChan respchan -invalidateCachedFile :: Chan ParsedCacheQuery -> String -> IO (ParsedCacheResponse) +invalidateCachedFile :: Chan ParsedCacheQuery -> String -> IO ParsedCacheResponse invalidateCachedFile pchannel name = do respchan <- newChan writeChan pchannel $ InvalidateCacheFile name respchan @@ -350,7 +348,7 @@ GetParsedData qtype name respchan -> do (curmap, _, _) <- get modify (\(mp, fm, rq) -> (mp, fm, rq + 1)) - case (Map.lookup (qtype, name) curmap) of + case Map.lookup (qtype, name) curmap of Just x -> liftIO $ writeChan respchan (RCacheEntry x) Nothing -> liftIO $ writeChan respchan NoCacheEntry UpdateParsedData qtype name val@(_, filepath, filestatus, _) respchan -> do @@ -374,8 +372,8 @@ (mp, fm, rq) <- get let nfm = Map.delete fname fm - nmp = case (Map.lookup fname fm) of - Just (_, remlist) -> foldl' (\mp' el -> Map.delete el mp') mp remlist + nmp = case Map.lookup fname fm of + Just (_, remlist) -> foldl' (flip Map.delete) mp remlist Nothing -> mp put (nmp, nfm, rq) liftIO $ writeChan respchan CacheUpdated diff --git a/Puppet/Interpreter/Catalog.hs b/Puppet/Interpreter/Catalog.hs --- a/Puppet/Interpreter/Catalog.hs +++ b/Puppet/Interpreter/Catalog.hs @@ -22,9 +22,10 @@ import Puppet.Interpreter.Types import Data.List -import Data.Char (isDigit) +import Data.Char (isDigit,toLower,toUpper) import Data.Maybe (isJust, fromJust, catMaybes) import Data.Either (lefts, rights, partitionEithers) +import Data.Ord (comparing) import Text.Parsec.Pos import Control.Monad.State import Control.Monad.Error @@ -32,9 +33,7 @@ import qualified Data.Set as Set qualified [] = False -qualified str = case isPrefixOf "::" str of - False -> qualified (tail str) - True -> True +qualified str = isPrefixOf "::" str || qualified (tail str) throwPosError msg = do p <- getPos @@ -42,9 +41,9 @@ -- Int handling stuff isInt :: String -> Bool -isInt = and . map isDigit +isInt = all isDigit readint :: String -> CatalogMonad Integer -readint x = if (isInt x) +readint x = if isInt x then return (read x) else throwPosError $ "Expected an integer instead of '" ++ x @@ -52,12 +51,12 @@ modifyVariables f sc = sc { curVariables = f $ curVariables sc } modifyClasses f sc = sc { curClasses = f $ curClasses sc } modifyDefaults f sc = sc { curDefaults = f $ curDefaults sc } -incrementResId sc = sc { curResId = (curResId sc) + 1 } +incrementResId sc = sc { curResId = curResId sc + 1 } setStatePos npos sc = sc { curPos = npos } emptyDefaults sc = sc { curDefaults = [] } -pushWarning t sc = sc { getWarnings = (getWarnings sc) ++ [t] } -pushCollect r sc = sc { curCollect = r : (curCollect sc) } -pushUnresRel r sc = sc { unresolvedRels = r : (unresolvedRels sc) } +pushWarning t sc = sc { getWarnings = getWarnings sc ++ [t] } +pushCollect r sc = sc { curCollect = r : curCollect sc } +pushUnresRel r sc = sc { unresolvedRels = r : unresolvedRels sc } getCatalog :: (TopLevelType -> String -> IO (Either String Statement)) -- ^ The \"get statements\" function. Given a top level type and its name it @@ -72,7 +71,7 @@ let convertedfacts = Map.map (\fval -> (Right fval, initialPos "FACTS")) facts - (output, finalstate) <- runStateT ( runErrorT ( computeCatalog getstatements nodename ) ) (ScopeState ["::"] convertedfacts Map.empty [] 1 (initialPos "dummy") Map.empty getstatements [] [] [] gettemplate) + (output, finalstate) <- runStateT ( runErrorT ( computeCatalog getstatements nodename ) ) (ScopeState [["::"]] convertedfacts Map.empty [] 1 (initialPos "dummy") Map.empty getstatements [] [] [] gettemplate) case output of Left x -> return (Left x, getWarnings finalstate) Right _ -> return (output, getWarnings finalstate) @@ -94,27 +93,25 @@ rparams <- mapM (\(a,b) -> do { ra <- resolveGeneralString a; rb <- resolveGeneralValue b; return (ra,rb); }) cparams -- add collected relations -- TODO - if Map.member ctype nativeTypes == False - then throwPosError $ "Can't find native type " ++ ctype - else return () + unless (Map.member ctype nativeTypes) $ throwPosError $ "Can't find native type " ++ ctype let mrrelations = [] prefinalresource = RResource cid rname ctype (Map.fromList rparams) mrrelations cpos validatefunction = puppetvalidate (nativeTypes Map.! ctype) validated = validatefunction prefinalresource case validated of Left err -> throwError (err ++ " for resource " ++ ctype ++ "[" ++ rname ++ "] at " ++ show cpos) - Right finalresource -> return $ ((ctype, rname), finalresource) + Right finalresource -> return ((ctype, rname), finalresource) -- This checks if a resource is to be collected. -- This returns a list as it can either return the original -- resource, the resource with a "normal" virtuality, or both, -- for exported resources (so that they can still be found as collected) collectionChecks :: CResource -> CatalogMonad [CResource] -collectionChecks res = do - if (crvirtuality res == Normal) +collectionChecks res = + if crvirtuality res == Normal then return [res] else do - isCollected <- get >>= return . curCollect >>= mapM (\x -> x res) + 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 } ] @@ -129,9 +126,8 @@ --export stuff --liftIO $ putStrLn "EXPORTED:" --liftIO $ mapM print exported - resolved <- mapM finalizeResource real >>= createResourceMap --get >>= return . unresolvedRels >>= liftIO . (mapM print) - return resolved + mapM finalizeResource real >>= createResourceMap createResourceMap :: [(ResIdentifier, RResource)] -> CatalogMonad FinalCatalog createResourceMap = foldM insertres Map.empty @@ -142,8 +138,8 @@ in case (rrtype res, oldres) of ("class", _) -> return newmap (_, Just r ) -> throwError $ "Resource already defined:" - ++ "\n\t" ++ (rrtype r) ++ "[" ++ (rrname r) ++ "] at " ++ show (rrpos r) - ++ "\n\t" ++ (rrtype res) ++ "[" ++ (rrname res) ++ "] at " ++ show (rrpos res) + ++ "\n\t" ++ rrtype r ++ "[" ++ rrname r ++ "] at " ++ show (rrpos r) + ++ "\n\t" ++ rrtype res ++ "[" ++ rrname res ++ "] at " ++ show (rrpos res) (_, Nothing) -> return newmap getstatement :: TopLevelType -> String -> CatalogMonad Statement @@ -156,49 +152,51 @@ Right y -> return y -- State alteration functions -pushScope name = modify (modifyScope (\x -> [name] ++ x)) -pushDefaults name = modify (modifyDefaults (\x -> [name] ++ x)) +pushScope = modify . modifyScope . (:) +pushDefaults = modify . modifyDefaults . (:) popScope = modify (modifyScope tail) getScope = do - scope <- get >>= return . curScope - if (null scope) + scope <- liftM curScope get + if null scope then throwError "empty scope, shouldn't happen" else return $ head scope -addLoaded name position = modify (modifyClasses (Map.insert name position)) +addLoaded name = modify . modifyClasses . Map.insert name getNextId = do curscope <- get put $ incrementResId curscope return (curResId curscope) -setPos p = modify (setStatePos p) -getPos = get >>= return . curPos -putVariable k v = do - curscope <- getScope - let qual = qualified k - kk | qual || (curscope == "::") = k - | otherwise = "::" ++ k - modify (modifyVariables (Map.insert (curscope ++ kk) v)) -getVariable vname = get >>= return . Map.lookup vname . curVariables +setPos = modify . setStatePos +getPos = liftM curPos get + +-- qualifies a variable k depending on the context cs +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))) + +getVariable vname = liftM (Map.lookup vname . curVariables) get + +-- BUG TODO : top levels are qualified only with the head of the scopes addNestedTopLevel rtype rname rstatement = do curstate <- get let ctop = nestedtoplevels curstate - curscope = head (curScope curstate) - nname | curscope == "::" = rname - | otherwise = curscope ++ "::" ++ rname + curscope = head $ head (curScope curstate) + nname = qualify rname curscope nstatement = case rstatement of DefineDeclaration _ prms stms cpos -> DefineDeclaration nname prms stms cpos x -> x ntop = Map.insert (rtype, nname) nstatement ctop nstate = curstate { nestedtoplevels = ntop } put nstate -addWarning nwrn = modify (pushWarning nwrn) -addCollect ncol = modify (pushCollect ncol) +addWarning = modify . pushWarning +addCollect = modify . pushCollect -- this pushes the relations only if they exist -- the parameter is of the form -- ( [dstrelations], srcresource, type, pos ) -addUnresRel ncol@(rels, _, _, _) = do - if null rels - then return () - else modify (pushUnresRel ncol) +addUnresRel ncol@(rels, _, _, _) = unless (null rels) (modify (pushUnresRel ncol)) -- finds out if a resource name refers to a define checkDefine :: String -> CatalogMonad (Maybe Statement) @@ -238,22 +236,27 @@ -- TODO check whether parameters changed checkLoaded name = do curscope <- get - case (Map.lookup name (curClasses curscope)) of + case Map.lookup name (curClasses curscope) of Nothing -> return False Just _ -> return True +-- 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) +resolveParams (a,b) = do + ra <- tryResolveExpressionString a + rb <- tryResolveExpression b + return (ra, rb) + -- apply default values to a resource applyDefaults :: CResource -> CatalogMonad CResource -applyDefaults res = do - defs <- get >>= return . curDefaults - foldM applyDefaults' res defs +applyDefaults res = liftM curDefaults get >>= foldM applyDefaults' res applyDefaults' :: CResource -> Statement -> CatalogMonad CResource applyDefaults' r@(CResource i rname rtype rparams rvirtuality rpos) (ResourceDefault dtype defs dpos) = do srname <- resolveGeneralString rname - rdefs <- mapM (\(a,b) -> do { ra <- tryResolveExpressionString a; rb <- tryResolveExpression b; return (ra, rb); }) defs + rdefs <- mapM resolveParams defs let (nparams, nrelations) = mergeParams rparams rdefs False - if (dtype == rtype) + if dtype == rtype then do addUnresRel (nrelations, (rtype, Right srname), UDefault, dpos) return $ CResource i rname rtype nparams rvirtuality rpos @@ -261,9 +264,9 @@ applyDefaults' r@(CResource i rname rtype rparams rvirtuality rpos) (ResourceOverride dtype dname defs dpos) = do srname <- resolveGeneralString rname sdname <- resolveExpressionString dname - rdefs <- mapM (\(a,b) -> do { ra <- tryResolveExpressionString a; rb <- tryResolveExpression b; return (ra, rb); }) defs + rdefs <- mapM resolveParams defs let (nparams, nrelations) = mergeParams rparams rdefs True - if ((dtype == rtype) && (srname == sdname)) + if (dtype == rtype) && (srname == sdname) then do addUnresRel (nrelations, (rtype, Right srname), UDefault, dpos) return $ CResource i rname rtype nparams rvirtuality rpos @@ -285,22 +288,23 @@ evaluateDefine :: CResource -> CatalogMonad [CResource] evaluateDefine r@(CResource _ rname rtype rparams rvirtuality rpos) = do + setPos rpos isdef <- checkDefine rtype case (rvirtuality, isdef) of (Normal, Just (DefineDeclaration dtype args dstmts dpos)) -> do --oldpos <- getPos setPos dpos - pushScope $ "#DEFINE#" ++ dtype + pushScope ["#DEFINE#" ++ dtype] -- add variables mrrparams <- mapM (\(gs, gv) -> do { rgs <- resolveGeneralString gs; rgv <- tryResolveGeneralValue gv; return (rgs, (rgv, dpos)); }) rparams let expr = gs2gv rname mparams = Map.fromList mrrparams putVariable "title" (expr, rpos) putVariable "name" (expr, rpos) - mapM (loadClassVariable rpos mparams) args + mapM_ (loadClassVariable rpos mparams) args -- parse statements - res <- mapM (evaluateStatements) dstmts + res <- mapM evaluateStatements dstmts nres <- handleDelayedActions (concat res) popScope return nres @@ -310,21 +314,33 @@ -- handling delayed actions (such as defaults) handleDelayedActions :: Catalog -> CatalogMonad Catalog handleDelayedActions res = do - dres <- mapM applyDefaults res >>= mapM evaluateDefine >>= return . concat + dres <- liftM concat (mapM applyDefaults res >>= mapM evaluateDefine) modify emptyDefaults return dres +addResource :: String -> [(Expression, Expression)] -> Virtuality -> SourcePos -> GeneralValue -> CatalogMonad [CResource] +addResource rtype parameters virtuality position grname = do + resid <- getNextId + rparameters <- mapM resolveParams parameters + -- il faut transformer grname qui est une generalvalue en generalstring + srname <- case grname of + Right e -> liftM Right (rstring e) + Left e -> return $ Left e + let (realparams, relations) = partitionParamsRelations rparameters + -- push all the relations + addUnresRel (relations, (rtype, srname), UNormal, position) + return [CResource resid srname rtype realparams virtuality position] + -- node evaluateStatements :: Statement -> CatalogMonad Catalog evaluateStatements (Node _ stmts position) = do setPos position - res <- mapM (evaluateStatements) stmts - nres <- handleDelayedActions (concat res) - return nres + res <- mapM evaluateStatements stmts + handleDelayedActions (concat res) -- include evaluateStatements (Include includename position) = setPos position >> getstatement TopClass includename >>= evaluateStatements -evaluateStatements x@(ClassDeclaration _ _ _ _ _) = evaluateClass x Map.empty Nothing +evaluateStatements x@(ClassDeclaration{}) = evaluateClass x Map.empty Nothing evaluateStatements n@(DefineDeclaration dtype _ _ _) = do addNestedTopLevel TopDefine dtype n return [] @@ -332,7 +348,7 @@ setPos position trues <- filterM (\(expr, _) -> resolveBoolean (Left expr)) exprs case trues of - ((_,stmts):_) -> mapM evaluateStatements stmts >>= return . concat + ((_,stmts):_) -> liftM concat (mapM evaluateStatements stmts) _ -> return [] evaluateStatements (Resource rtype rname parameters virtuality position) = do @@ -346,18 +362,15 @@ let classparameters = Map.fromList $ map (\(pname, pvalue) -> (pname, (pvalue, position))) rparameters evaluateClass topstatement classparameters Nothing _ -> do - resid <- getNextId - rparameters <- mapM (\(a,b) -> do { pa <- tryResolveExpressionString a; pb <- tryResolveExpression b; return (pa, pb) } ) parameters - srname <- tryResolveExpressionString rname - let (realparams, relations) = partitionParamsRelations rparameters - -- push all the relations - addUnresRel (relations, (rtype, srname), UNormal, position) - return [CResource resid srname rtype realparams virtuality position] + srname <- tryResolveExpression rname + case srname of + (Right (ResolvedArray arr)) -> fmap concat (mapM (addResource rtype parameters virtuality position . Right) arr) + _ -> addResource rtype parameters virtuality position srname -evaluateStatements x@(ResourceDefault _ _ _ ) = do +evaluateStatements x@(ResourceDefault{}) = do pushDefaults x return [] -evaluateStatements x@(ResourceOverride _ _ _ _) = do +evaluateStatements x@(ResourceOverride{}) = do pushDefaults x return [] evaluateStatements (DependenceChain (srctype, srcname) (dsttype, dstname) position) = do @@ -369,18 +382,14 @@ -- <<| |>> evaluateStatements (ResourceCollection rtype expr overrides position) = do setPos position - if null overrides - then return () - else throwPosError "Collection overrides not handled" + unless (null overrides) (throwPosError "Collection overrides not handled") func <- collectionFunction Exported rtype expr addCollect func return [] -- <| |> evaluateStatements (VirtualResourceCollection rtype expr overrides position) = do setPos position - if null overrides - then return () - else throwPosError "Collection overrides not handled" + unless (null overrides) (throwPosError "Collection overrides not handled") func <- collectionFunction Virtual rtype expr addCollect func return [] @@ -397,10 +406,10 @@ executeFunction fname rargs evaluateStatements (TopContainer toplevels curstatement) = do - mapM (\(fname, stmt) -> evaluateClass stmt Map.empty (Just fname)) toplevels + mapM_ (\(fname, stmt) -> evaluateClass stmt Map.empty (Just fname)) toplevels evaluateStatements curstatement -evaluateStatements x = throwError ("Can't evaluate " ++ (show x)) +evaluateStatements x = throwError ("Can't evaluate " ++ show x) -- function used to load defines / class variables into the global context loadClassVariable :: SourcePos -> Map.Map String (GeneralValue, SourcePos) -> (String, Maybe Expression) -> CatalogMonad () @@ -409,7 +418,7 @@ (v, vpos) <- case (inputvalue, defvalue) of (Just x , _ ) -> return x (Nothing, Just y ) -> return (Left y, position) - (Nothing, Nothing) -> throwError $ "Must define parameter " ++ paramname ++ " at " ++ (show position) + (Nothing, Nothing) -> throwError $ "Must define parameter " ++ paramname ++ " at " ++ show position rv <- tryResolveGeneralValue v putVariable paramname (rv, vpos) return () @@ -427,9 +436,11 @@ else do resid <- getNextId -- get this resource id, for the dummy class that will be used to handle relations oldpos <- getPos -- saves where we were at class declaration so that we known were the class was included - setPos position - pushScope classname -- sets the scope - mapM (loadClassVariable position inputparams) parameters -- add variables for parametrized classes + setPos position + case actualname of + Nothing -> pushScope [classname] -- sets the scope + Just ac -> pushScope [classname, ac] + mapM_ (loadClassVariable position inputparams) parameters -- add variables for parametrized classes -- load inherited classes inherited <- case inherits of @@ -444,9 +455,9 @@ Just x -> addLoaded x oldpos -- parse statements - res <- mapM (evaluateStatements) statements + res <- mapM evaluateStatements statements nres <- handleDelayedActions (concat res) - mapM (addClassDependency classname) nres -- this adds a dummy dependency to this class + mapM_ (addClassDependency classname) nres -- this adds a dummy dependency to this class -- 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 @@ -457,7 +468,7 @@ ++ nres evaluateClass (TopContainer topstmts myclass) inputparams actualname = do - mapM (\(n,x) -> evaluateClass x Map.empty (Just n)) topstmts + mapM_ (\(n,x) -> evaluateClass x Map.empty (Just n)) topstmts evaluateClass myclass inputparams actualname evaluateClass x _ _ = throwError ("Someone managed to run evaluateClass against " ++ show x) @@ -469,7 +480,7 @@ , UPlus, position) tryResolveExpression :: Expression -> CatalogMonad GeneralValue -tryResolveExpression e = tryResolveGeneralValue (Left e) +tryResolveExpression = tryResolveGeneralValue . Left tryResolveGeneralValue :: GeneralValue -> CatalogMonad GeneralValue tryResolveGeneralValue n@(Right _) = return n @@ -481,7 +492,7 @@ tryResolveGeneralValue (Left (ConditionalValue checkedvalue (Value (PuppetHash (Parameters hash))))) = do rcheck <- resolveExpression checkedvalue rhash <- mapM (\(vn, vv) -> do { rvn <- resolveExpression vn; return (rvn, vv) }) hash - case (filter (\(a,_) -> (a == ResolvedString "default") || (compareRValues a rcheck)) rhash) of + case filter (\(a,_) -> (a == ResolvedString "default") || compareRValues a rcheck) rhash of [] -> throwPosError ("No value could be selected when comparing to " ++ show rcheck) ((_,x):_) -> tryResolveExpression x tryResolveGeneralValue n@(Left (EqualOperation a b)) = compareGeneralValue n a b [EQ] @@ -490,7 +501,6 @@ tryResolveGeneralValue n@(Left (UnderEqualOperation a b)) = compareGeneralValue n a b [LT,EQ] tryResolveGeneralValue n@(Left (UnderOperation a b)) = compareGeneralValue n a b [LT] tryResolveGeneralValue n@(Left (DifferentOperation a b)) = compareGeneralValue n a b [LT,GT] - tryResolveGeneralValue n@(Left (OrOperation a b)) = do ra <- tryResolveBoolean $ Left a rb <- tryResolveBoolean $ Left b @@ -506,7 +516,7 @@ tryResolveGeneralValue (Left (NotOperation x)) = do rx <- tryResolveBoolean $ Left x case rx of - Right (ResolvedBool b) -> return $ Right $ ResolvedBool $ (not b) + Right (ResolvedBool b) -> return $ Right $ ResolvedBool $ not b _ -> return rx tryResolveGeneralValue (Left (LookupOperation a b)) = do ra <- tryResolveExpression a @@ -515,14 +525,14 @@ (Right (ResolvedArray ar), Right num) -> do bnum <- readint num let nnum = fromIntegral bnum - if(length ar >= nnum) - then throwPosError ("Invalid array index " ++ num) + if length ar <= nnum + then throwPosError ("Invalid array index " ++ num ++ " " ++ show ar) else return $ Right (ar !! nnum) (Right (ResolvedHash ar), Right idx) -> do let filtered = filter (\(x,_) -> x == idx) ar case filtered of [] -> throwError "TODO empty filtered" - [(_,x)] -> return $ Right $ x + [(_,x)] -> return $ Right x x -> throwPosError ("Hum, WTF tryResolveGeneralValue " ++ show x) (_, Left y) -> throwPosError ("Could not resolve index " ++ show y) (Left x, _) -> throwPosError ("Could not resolve lookup " ++ show x) @@ -537,6 +547,11 @@ then return $ Right $ ResolvedBool False else return $ Right $ ResolvedBool True _ -> return o +-- horrible hack, because I do not know how to supply a single operator for Int and Float +tryResolveGeneralValue o@(Left (PlusOperation a b)) = arithmeticOperation a b (+) (+) o +tryResolveGeneralValue o@(Left (MinusOperation a b)) = arithmeticOperation a b (-) (-) o +tryResolveGeneralValue o@(Left (DivOperation a b)) = arithmeticOperation a b div (/) o +tryResolveGeneralValue o@(Left (MultiplyOperation a b)) = arithmeticOperation a b (*) (*) o tryResolveGeneralValue e = throwPosError ("tryResolveGeneralValue not implemented for " ++ show e) @@ -551,7 +566,7 @@ tryResolveExpressionString s = do resolved <- tryResolveExpression s case resolved of - Right e -> rstring e >>= return . Right + Right e -> liftM Right (rstring e) Left e -> return $ Left e rstring :: ResolvedValue -> CatalogMonad String @@ -590,56 +605,62 @@ case rvals of Right resolved -> return $ Right $ ResolvedRReference rtype resolved _ -> return $ Left $ Value n - +-- special variables first +tryResolveValue (VariableReference "module_name") = liftM (\x -> + case (takeWhile (/= ':') . head) x of + '#':'D':'E':'F':'I':'N':'E':'#':xs -> Right $ ResolvedString xs + r -> Right $ ResolvedString r + ) getScope tryResolveValue (VariableReference vname) = do -- TODO check scopes !!! curscp <- getScope - let varnames | qualified vname = [vname] ++ remtopscope vname -- scope is explicit - | curscp == "::" = ["::" ++ vname] -- we are toplevel - | otherwise = [curscp ++ "::" ++ vname, "::" ++ vname] -- check for local scope, then global + let gvarnm sc | qualified vname = vname : remtopscope vname -- scope is explicit + | sc == "::" = ["::" ++ vname] -- we are toplevel + | otherwise = [sc ++ "::" ++ vname, "::" ++ vname] -- check for local scope, then global + varnames = concatMap gvarnm curscp remtopscope (':':':':xs) = [xs] remtopscope _ = [] - matching <- mapM getVariable varnames >>= return . catMaybes + matching <- liftM catMaybes (mapM getVariable varnames) if null matching then do position <- getPos addWarning ("Could not resolveValue " ++ show varnames ++ " at " ++ show position) return $ Left $ Value $ VariableReference (head varnames) - else return $ case (head matching) of + else return $ case head matching of (x,_) -> x tryResolveValue n@(Interpolable x) = do resolved <- mapM tryResolveValueString x - if (null $ lefts resolved) + if null $ lefts resolved then return $ Right $ ResolvedString $ concat $ rights resolved else return $ Left $ Value n tryResolveValue n@(PuppetHash (Parameters x)) = do resolvedKeys <- mapM (tryResolveExpressionString . fst) x resolvedValues <- mapM (tryResolveExpression . snd) x - if ((null $ lefts resolvedKeys) && (null $ lefts resolvedValues)) + if null (lefts resolvedKeys) && null (lefts resolvedValues) then return $ Right $ ResolvedHash $ zip (rights resolvedKeys) (rights resolvedValues) else return $ Left $ Value n tryResolveValue n@(PuppetArray expressions) = do resolvedExpressions <- mapM tryResolveExpression expressions - if (null $ lefts resolvedExpressions) + if null $ lefts resolvedExpressions then return $ Right $ ResolvedArray $ rights resolvedExpressions else return $ Left $ Value n -- TODO -tryResolveValue (FunctionCall "fqdn_rand" args) = if (null args) +tryResolveValue (FunctionCall "fqdn_rand" args) = if null args then throwPosError "Empty argument list in fqdn_rand call" else do nargs <- mapM resolveExpressionString args curmax <- readint (head nargs) - fqdn_rand curmax (tail nargs) >>= return . Right . ResolvedInt -tryResolveValue (FunctionCall "mysql_password" args) = if (length args /= 1) + liftM (Right . ResolvedInt) (fqdn_rand curmax (tail nargs)) +tryResolveValue (FunctionCall "mysql_password" args) = if length args /= 1 then throwPosError "mysql_password takes a single argument" else do es <- tryResolveExpressionString (head args) case es of - Right s -> mysql_password s >>= return . Right . ResolvedString + 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 @@ -648,24 +669,55 @@ Left x -> throwPosError $ "Can't resolve template path " ++ show x Right filename -> do vars <- get >>= mapM (\(varname, (varval, _)) -> do { rvarval <- tryResolveGeneralValue varval; return (varname, rvarval) }) . Map.toList . curVariables - scp <- getScope - templatefunc <- get >>= return . computeTemplateFunction + scp <- liftM head getScope -- TODO check if that sucks + templatefunc <- liftM computeTemplateFunction get out <- liftIO (templatefunc filename scp vars) case out of Right x -> return $ Right $ ResolvedString x Left err -> throwPosError err tryResolveValue (FunctionCall "inline_template" _) = return $ Right $ ResolvedString "TODO" -tryResolveValue (FunctionCall "regsubst" [str, src, dst, flags]) = do +tryResolveValue (FunctionCall "defined" [v]) = do + rv <- tryResolveExpression v + case rv of + Left n -> return $ Left n + -- TODO BUG + Right (ResolvedString typeorclass) -> + -- is it a loaded class or a define ? + if Map.member typeorclass nativeTypes + then return $ Right $ ResolvedBool True + else do + isdefine <- checkDefine typeorclass + case isdefine of + Just _ -> return $ Right $ ResolvedBool True + Nothing -> liftM (Right . ResolvedBool . Map.member typeorclass . curClasses) get + Right (ResolvedRReference _ (ResolvedString _)) -> do + position <- getPos + addWarning $ "The defined() function is not implemented for resource references. Returning true at " ++ show position + return $ Right $ ResolvedBool True + Right x -> throwPosError $ "Can't know if this could be defined : " ++ show x +tryResolveValue n@(FunctionCall "regsubst" [str, src, dst, flags]) = do rstr <- tryResolveExpressionString str rsrc <- tryResolveExpressionString src rdst <- tryResolveExpressionString dst rflags <- tryResolveExpressionString flags case (rstr, rsrc, rdst, rflags) of - (Right sstr, Right ssrc, Right sdst, Right sflags) -> regsubst sstr ssrc sdst sflags >>= return . Right . ResolvedString - x -> throwPosError ("Could not run regsubst because something here could not be resolved: " ++ show x) + (Right sstr, Right ssrc, Right sdst, Right sflags) -> liftM (Right . ResolvedString) (regsubst sstr ssrc sdst sflags) + _ -> return $ Left $ Value n tryResolveValue (FunctionCall "regsubst" [str, src, dst]) = tryResolveValue (FunctionCall "regsubst" [str, src, dst, Value $ Literal ""]) tryResolveValue (FunctionCall "regsubst" args) = throwPosError ("Bad argument count for regsubst " ++ show args) - + +tryResolveValue n@(FunctionCall "split" [str, reg]) = do + rstr <- tryResolveExpressionString str + rreg <- tryResolveExpressionString reg + case (rstr, rreg) of + (Right sstr, Right sreg) -> return $ Right $ ResolvedArray $ map ResolvedString $ puppetSplit sstr sreg + _ -> return $ Left $ Value n +tryResolveValue (FunctionCall "split" _) = throwPosError "Bad argument count for function split" +tryResolveValue n@(FunctionCall "upcase" args) = stringTransform args n (map toUpper) +tryResolveValue n@(FunctionCall "lowcase" args) = stringTransform args n (map toLower) +tryResolveValue n@(FunctionCall "sha1" args) = stringTransform args n puppetSHA1 +tryResolveValue n@(FunctionCall "md5" args) = stringTransform args n puppetMD5 + tryResolveValue n@(FunctionCall "versioncmp" [a,b]) = do ra <- tryResolveExpressionString a rb <- tryResolveExpressionString b @@ -680,16 +732,13 @@ then do content <- liftIO $ file rf case content of - Nothing -> do - position <- getPos - addWarning $ "Files " ++ show rf ++ " could not be found at " ++ show position - return $ Right $ ResolvedString "" + Nothing -> throwPosError $ "Files " ++ show rf ++ " could not be found" Just x -> return $ Right $ ResolvedString x else return $ Left $ Value n - + tryResolveValue (FunctionCall fname _) = throwPosError ("FunctionCall " ++ fname ++ " not implemented") -tryResolveValue Undefined = return $ Right $ ResolvedUndefined +tryResolveValue Undefined = return $ Right ResolvedUndefined tryResolveValue (PuppetRegexp x) = return $ Right $ ResolvedRegexp x tryResolveValue x = throwPosError ("tryResolveValue not implemented for " ++ show x) @@ -714,10 +763,9 @@ pushRealize :: ResolvedValue -> CatalogMonad () pushRealize (ResolvedRReference rtype (ResolvedString rname)) = do let myfunction :: CResource -> CatalogMonad Bool - myfunction = (\(CResource _ mcrname mcrtype _ _ _) -> do + myfunction (CResource _ mcrname mcrtype _ _ _) = do srname <- resolveGeneralString mcrname return ((srname == rname) && (mcrtype == rtype)) - ) addCollect myfunction return () pushRealize (ResolvedRReference _ x) = throwPosError (show x ++ " was not resolved to a string") @@ -726,7 +774,7 @@ executeFunction :: String -> [ResolvedValue] -> CatalogMonad Catalog executeFunction "fail" [ResolvedString errmsg] = throwPosError ("Error: " ++ errmsg) executeFunction "fail" args = throwPosError ("Error: " ++ show args) -executeFunction "realize" rlist = mapM pushRealize rlist >> return [] +executeFunction "realize" rlist = mapM_ pushRealize rlist >> return [] executeFunction "create_resources" [mrtype, rdefs] = do mrrtype <- case mrtype of ResolvedString x -> return x @@ -742,7 +790,7 @@ _ -> throwPosError "This should not happen, create_resources argument is not a hash" return $ Resource mrrtype resname realargs Normal position ) prestatements - mapM evaluateStatements resources >>= return . concat + liftM concat (mapM evaluateStatements resources) executeFunction "create_resources" x = throwPosError ("Bad arguments to create_resources: " ++ show x) executeFunction a b = do position <- getPos @@ -769,16 +817,17 @@ cmp <- compareExpression a b case cmp of Nothing -> return n - Just x -> return $ Right $ ResolvedBool (elem x acceptable) + Just x -> return $ Right $ ResolvedBool (x `elem` acceptable) compareValues :: ResolvedValue -> ResolvedValue -> Ordering compareValues a@(ResolvedString _) b@(ResolvedInt _) = compareValues b a compareValues (ResolvedInt a) (ResolvedString b) | isInt b = compare a (read b) | otherwise = LT -compareValues (ResolvedString a) (ResolvedRegexp b) = if (regmatch a b) then EQ else LT +compareValues (ResolvedString a) (ResolvedRegexp b) = if regmatch a b then EQ else LT +compareValues (ResolvedString a) (ResolvedString b) = comparing (map toLower) a b compareValues x y = compare x y compareRValues :: ResolvedValue -> ResolvedValue -> Bool -compareRValues a b = (compareValues a b) == EQ +compareRValues a b = compareValues a b == EQ -- used to handle the special cases when we know it is a boolean context tryResolveBoolean :: GeneralValue -> CatalogMonad GeneralValue @@ -789,7 +838,7 @@ Right (ResolvedString _) -> return $ Right $ ResolvedBool True Right (ResolvedInt 0) -> return $ Right $ ResolvedBool False Right (ResolvedInt _) -> return $ Right $ ResolvedBool True - Right (ResolvedUndefined) -> return $ Right $ ResolvedBool False + Right ResolvedUndefined -> return $ Right $ ResolvedBool False Left (Value (VariableReference _)) -> return $ Right $ ResolvedBool False Left (EqualOperation (Value (VariableReference _)) (Value (Literal ""))) -> return $ Right $ ResolvedBool True -- case where a variable was not resolved and compared to the empty string Left (EqualOperation (Value (VariableReference _)) (Value (Literal "true"))) -> return $ Right $ ResolvedBool False -- case where a variable was not resolved and compared to the string "true" @@ -820,20 +869,19 @@ rb <- resolveExpression b paramname <- case ra of ResolvedString pname -> return pname - _ -> throwPosError $ "We only support collection of the form 'parameter == value'" + _ -> 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 -> case Map.lookup mrtype nativeTypes of Just (PuppetTypeMethods _ ps) -> return ps Nothing -> throwPosError $ "Unknown type " ++ mrtype ++ " when trying to collect" Just (DefineDeclaration _ params _ _) -> return $ Set.fromList $ map fst params Just x -> throwPosError $ "Expected a DefineDeclaration here instead of " ++ show x - if (Set.notMember paramname paramset) && (paramname /= "tag") - then throwPosError $ "Parameter " ++ paramname ++ " is not a valid parameter. It should be in : " ++ show (Set.toList paramset) - else return () + when (Set.notMember paramname paramset && (paramname /= "tag")) $ + throwPosError $ "Parameter " ++ paramname ++ " is not a valid parameter. It should be in : " ++ show (Set.toList paramset) return (\r -> do let param = filter (\x -> fst x == Right paramname) (crparams r) - if length param == 0 + if null param then return False else do cmp <- resolveGeneralValue $ snd (head param) @@ -841,7 +889,7 @@ ) x -> throwPosError $ "TODO : implement collection function for " ++ show x return (\res -> - if ((crtype res == mrtype) && (crvirtuality res == virt)) + if (crtype res == mrtype) && (crvirtuality res == virt) then finalfunc res else return False ) @@ -855,5 +903,26 @@ resolved2expression (ResolvedRReference mrtype name) = Value $ ResourceReference mrtype (resolved2expression name) resolved2expression (ResolvedArray vals) = Value $ PuppetArray $ map resolved2expression vals resolved2expression (ResolvedHash hash) = Value $ PuppetHash $ Parameters $ map (\(s,v) -> (Value $ Literal s, resolved2expression v)) hash -resolved2expression (ResolvedUndefined) = Value $ Undefined +resolved2expression ResolvedUndefined = Value Undefined resolved2expression (ResolvedRegexp a) = Value $ PuppetRegexp a +resolved2expression (ResolvedDouble d) = Value $ Double d + +arithmeticOperation :: Expression -> Expression -> (Integer -> Integer -> Integer) -> (Double -> Double -> Double) -> GeneralValue -> CatalogMonad GeneralValue +arithmeticOperation a b opi opf def = do + ra <- tryResolveExpression a + rb <- tryResolveExpression b + case (ra, rb) of + (Right (ResolvedInt sa) , Right (ResolvedInt sb)) -> return $ Right $ ResolvedInt $ opi sa sb + (Right (ResolvedDouble sa), Right (ResolvedInt sb)) -> return $ Right $ ResolvedDouble $ opf sa (fromIntegral sb) + (Right (ResolvedInt sa) , Right (ResolvedDouble sb)) -> return $ Right $ ResolvedDouble $ opf (fromIntegral sa) sb + (Right (ResolvedDouble sa), Right (ResolvedDouble sb)) -> return $ Right $ ResolvedDouble $ opf sa sb + _ -> return def + + +stringTransform :: [Expression] -> Value -> (String -> String) -> CatalogMonad GeneralValue +stringTransform [u] n f = do + r <- tryResolveExpressionString u + case r of + Right s -> return $ Right $ ResolvedString $ f s + Left _ -> return $ Left $ Value n +stringTransform _ _ _ = throwPosError "This function takes a single argument." diff --git a/Puppet/Interpreter/Functions.hs b/Puppet/Interpreter/Functions.hs --- a/Puppet/Interpreter/Functions.hs +++ b/Puppet/Interpreter/Functions.hs @@ -5,16 +5,24 @@ ,regmatch ,versioncmp ,file + ,puppetSplit + ,puppetSHA1 + ,puppetMD5 ) where import Data.Hash.MD5 import qualified Crypto.Hash.SHA1 as SHA1 import qualified Data.ByteString.Char8 as BS -import Data.String.Utils (join) +import Data.String.Utils (join,replace) import Text.RegexPR import Puppet.Interpreter.Types import Control.Monad.Error import System.IO +import qualified Data.ByteString.Base16 as B16 + +puppetMD5 = md5s . Str +puppetSHA1 = BS.unpack . B16.encode . SHA1.hash . BS.pack + {- TODO : achieve compatibility with puppet the first String must be the fqdn @@ -28,29 +36,26 @@ mysql_password :: String -> CatalogMonad String mysql_password pwd = return $ '*':hash where - hash = BS.unpack $ SHA1.hash (BS.pack pwd) + hash = puppetSHA1 pwd regsubst :: String -> String -> String -> String -> CatalogMonad String regsubst str src dst flags = do - let multiline = elem 'M' flags - extended = elem 'E' flags - insensitive = elem 'I' flags - global = elem 'G' flags + let multiline = 'M' `elem` flags + extended = 'E' `elem` flags + insensitive = 'I' `elem` flags + global = 'G' `elem` flags refunc | global = gsubRegexPR | otherwise = subRegexPR - if multiline - then throwError "Multiline flag not implemented" - else return () - if extended - then throwError "Extended flag not implemented" - else return () - if insensitive - then throwError "Case insensitive flag not implemented" - else return () - return $ refunc src dst str + when multiline $ throwError "Multiline flag not implemented" + when extended $ throwError "Extended flag not implemented" + when insensitive $ throwError "Case insensitive flag not implemented" + return $ refunc (alterregexp src) dst str +alterregexp :: String -> String +alterregexp = replace "\\n" "\n" + regmatch :: String -> String -> Bool -regmatch str reg = case matchRegexPR str reg of +regmatch str reg = case matchRegexPR (alterregexp str) reg of Just _ -> True Nothing -> False @@ -62,4 +67,7 @@ file :: [String] -> IO (Maybe String) file [] = return Nothing -file (x:xs) = catch (withFile x ReadMode hGetContents >>= return . Just) (\_ -> file xs) +file (x:xs) = catch (liftM Just (withFile x ReadMode hGetContents)) (\_ -> file xs) + +puppetSplit :: String -> String -> [String] +puppetSplit str reg = splitRegexPR reg str diff --git a/Puppet/Interpreter/Types.hs b/Puppet/Interpreter/Types.hs --- a/Puppet/Interpreter/Types.hs +++ b/Puppet/Interpreter/Types.hs @@ -17,13 +17,14 @@ -- 'FinalCatalog' and in the resolved parts of a 'Catalog'. They are to be -- compared with the 'Value's. data ResolvedValue - = ResolvedString !String - | ResolvedRegexp !String - | ResolvedInt !Integer - | ResolvedBool !Bool + = ResolvedString !String + | ResolvedRegexp !String + | ResolvedInt !Integer + | ResolvedDouble !Double + | ResolvedBool !Bool | ResolvedRReference !String !ResolvedValue - | ResolvedArray ![ResolvedValue] - | ResolvedHash ![(String, ResolvedValue)] + | ResolvedArray ![ResolvedValue] + | ResolvedHash ![(String, ResolvedValue)] | ResolvedUndefined deriving(Show, Eq, Ord) @@ -81,9 +82,11 @@ internal state. -} data ScopeState = ScopeState { - curScope :: ![ScopeName], + curScope :: ![[ScopeName]], -- ^ The list of scopes. It works like a stack, and its initial value must - -- be @[\"::\"]@ + -- 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 String (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 @@ -121,11 +124,11 @@ type CatalogMonad = ErrorT String (StateT ScopeState IO) generalizeValueE :: Expression -> GeneralValue -generalizeValueE e = Left e +generalizeValueE = Left generalizeValueR :: ResolvedValue -> GeneralValue -generalizeValueR e = Right e +generalizeValueR = Right generalizeStringE :: Expression -> GeneralString -generalizeStringE s = Left s +generalizeStringE = Left generalizeStringS :: String -> GeneralString -generalizeStringS s = Right s +generalizeStringS = Right diff --git a/Puppet/NativeTypes.hs b/Puppet/NativeTypes.hs --- a/Puppet/NativeTypes.hs +++ b/Puppet/NativeTypes.hs @@ -7,8 +7,8 @@ fakeTypes = map faketype ["class", "ssh_authorized_key_secure"] -defaultTypes = map defaulttype ["augeas","computer","cron","exec","filebucket","group","host","interface","k5login","macauthorization","mailalias","maillist","mcx","mount","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"] +defaultTypes = map defaulttype ["augeas","computer","cron","exec","filebucket","group","host","interface","k5login","macauthorization","mailalias","maillist","mcx","mount","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"] -- | The map of native types. They are described in "Puppet.NativeTypes.Helpers". -nativeTypes :: Map.Map PuppetTypeName (PuppetTypeMethods) +nativeTypes :: Map.Map PuppetTypeName PuppetTypeMethods nativeTypes = Map.fromList (fakeTypes ++ defaultTypes ++ nativeFile) diff --git a/Puppet/NativeTypes/File.hs b/Puppet/NativeTypes/File.hs --- a/Puppet/NativeTypes/File.hs +++ b/Puppet/NativeTypes/File.hs @@ -41,6 +41,6 @@ parammap = rrparams res source = Map.member "source" parammap content = Map.member "content" parammap - in if (source && content) + in if source && content then Left "Source and content can't be specified at the same time" else Right res diff --git a/Puppet/NativeTypes/Helpers.hs b/Puppet/NativeTypes/Helpers.hs --- a/Puppet/NativeTypes/Helpers.hs +++ b/Puppet/NativeTypes/Helpers.hs @@ -19,7 +19,7 @@ } faketype :: PuppetTypeName -> (PuppetTypeName, PuppetTypeMethods) -faketype tname = (tname, PuppetTypeMethods (\x -> Right x) Set.empty) +faketype tname = (tname, PuppetTypeMethods Right Set.empty) defaulttype :: PuppetTypeName -> (PuppetTypeName, PuppetTypeMethods) defaulttype tname = (tname, PuppetTypeMethods (defaultValidate Set.empty) Set.empty) @@ -34,7 +34,7 @@ checkParameterList validparameters res | Set.null validparameters = Right res | otherwise = if Set.null setdiff then Right res - else Left $ "Unknown parameters " ++ (show $ Set.toList setdiff) + else Left $ "Unknown parameters " ++ show (Set.toList setdiff) where keyset = Map.keysSet (rrparams res) setdiff = Set.difference keyset (Set.insert "tag" validparameters) @@ -52,7 +52,7 @@ 'ResolvedBool' it will convert them to strings. -} string :: String -> PuppetTypeValidate -string param res = case (Map.lookup param (rrparams res)) of +string param res = case Map.lookup param (rrparams res) of Just (ResolvedString _) -> Right res Just (ResolvedInt n) -> Right (insertparam res param (ResolvedString $ show n)) Just (ResolvedBool True) -> Right (insertparam res param (ResolvedString "true")) @@ -63,7 +63,7 @@ -- | Makes sure that the parameter, if defined, has a value among this list. values :: [String] -> String -> PuppetTypeValidate values valuelist param res = case (Map.lookup param (rrparams res)) of - Just (ResolvedString x) -> if (elem x valuelist) + Just (ResolvedString x) -> if elem x valuelist then Right res else Left $ "Parameter " ++ param ++ " value should be one of " ++ show valuelist Just _ -> Left $ "Parameter " ++ param ++ " value should be one of " ++ show valuelist @@ -85,7 +85,7 @@ where integer' pr rs = case (Map.lookup pr (rrparams rs)) of Nothing -> Right rs - Just (ResolvedString x) -> if (all isDigit x) + Just (ResolvedString x) -> if all isDigit x then Right $ insertparam rs pr (ResolvedInt $ read x) else Left $ "Parameter " ++ pr ++ " should be a number" Just (ResolvedInt _) -> Right rs diff --git a/Puppet/Printers.hs b/Puppet/Printers.hs --- a/Puppet/Printers.hs +++ b/Puppet/Printers.hs @@ -40,8 +40,8 @@ where showrres (RResource _ rname _ params rels mpos) = " " ++ show rname ++ ":" ++ " #" ++ show mpos ++ "\n" - ++ commaretsep (map showparams (Map.toList params)) - ++ commareqs ((null rels) || (Map.null params)) + ++ commaretsep (map showparams (Map.toList $ Map.delete "title" params)) + ++ commareqs (null rels || Map.null params) ++ commaretsep (map showrequire (sort rels)) ++ ";\n" commareqs c | c = "" | otherwise = ",\n" 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.3 +Version: 0.1.4 -- A short (one-line) description of the package. Synopsis: Tools to parse and evaluate the Puppet DSL. @@ -53,10 +53,10 @@ Puppet.Interpreter.Types, Puppet.Interpreter.Catalog, Puppet.NativeTypes.Helpers -- 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 + Build-depends: base >=3 && <5,parsec,MissingH,containers,pretty,mtl,unix,hslogger,filepath,Glob,regexpr,process,bytestring,cryptohash,base16-bytestring -- Modules not exported by this package. - Other-modules: Puppet.Interpreter.Functions, Puppet.NativeTypes.File, Erb.Compute, SafeProcess, Paths_language_puppet, Erb.Parser, Erb.Ruby + Other-modules: Puppet.Interpreter.Functions, Puppet.NativeTypes.File, Erb.Compute, SafeProcess, Paths_language_puppet, Erb.Parser, Erb.Ruby, Erb.Evaluate -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source. -- Build-tools: