diff --git a/Erb/Compute.hs b/Erb/Compute.hs --- a/Erb/Compute.hs +++ b/Erb/Compute.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BangPatterns #-} module Erb.Compute(computeTemplate, getTemplateFile, initTemplateDaemon) where import Data.List @@ -13,24 +14,30 @@ import Erb.Parser import Erb.Evaluate import qualified Data.Map as Map +import Debug.Trace +import qualified Data.ByteString.Lazy.Char8 as BS +import qualified Data.ByteString.Builder as BB +import Data.Monoid +import qualified System.Log.Logger as LOG +import Puppet.Stats -type TemplateQuery = (Chan TemplateAnswer, String, String, [(String, GeneralValue)]) +type TemplateQuery = (Chan TemplateAnswer, String, String, Map.Map String GeneralValue) type TemplateAnswer = Either String String -initTemplateDaemon :: Prefs -> IO (String -> String -> [(String, GeneralValue)] -> IO (Either String String)) -initTemplateDaemon (Prefs _ modpath templatepath _ _ _ _) = do +initTemplateDaemon :: Prefs -> MStats -> IO (String -> String -> Map.Map String GeneralValue -> IO (Either String String)) +initTemplateDaemon (Prefs _ modpath templatepath _ _ ps _ _) mvstats = do controlchan <- newChan - forkIO (templateDaemon modpath templatepath controlchan) + replicateM_ ps (forkIO (templateDaemon modpath templatepath controlchan mvstats)) return (templateQuery controlchan) -templateQuery :: Chan TemplateQuery -> String -> String -> [(String, GeneralValue)] -> IO (Either String String) +templateQuery :: Chan TemplateQuery -> String -> String -> Map.Map String GeneralValue -> IO (Either String String) templateQuery qchan filename scope variables = do rchan <- newChan writeChan qchan (rchan, filename, scope, variables) readChan rchan -templateDaemon :: String -> String -> Chan TemplateQuery -> IO () -templateDaemon modpath templatepath qchan = do +templateDaemon :: String -> String -> Chan TemplateQuery -> MStats -> IO () +templateDaemon modpath templatepath qchan mvstats = do (respchan, filename, scope, variables) <- readChan qchan let parts = DLU.split "/" filename searchpathes | length parts > 1 = [modpath ++ "/" ++ head parts ++ "/templates/" ++ (DLU.join "/" (tail parts)), templatepath ++ "/" ++ filename] @@ -38,49 +45,77 @@ acceptablefiles <- filterM fileExist searchpathes if(null acceptablefiles) then writeChan respchan (Left $ "Can't find template file for " ++ filename ++ ", looked in " ++ show searchpathes) - else computeTemplate (head acceptablefiles) scope variables >>= writeChan respchan - templateDaemon modpath templatepath qchan + else measure mvstats ("total - " ++ filename) (computeTemplate (head acceptablefiles) scope variables mvstats) >>= writeChan respchan + templateDaemon modpath templatepath qchan mvstats -computeTemplate :: String -> String -> [(String, GeneralValue)] -> IO TemplateAnswer -computeTemplate filename curcontext variables = do - parsed <- parseErbFile filename +computeTemplate :: String -> String -> Map.Map String GeneralValue -> MStats -> IO TemplateAnswer +computeTemplate filename curcontext variables mstats = do + parsed <- measure mstats ("parsing - " ++ filename) $ parseErbFile filename case parsed of - Left _ -> computeTemplateWRuby filename curcontext variables - Right ast -> return $ rubyEvaluate (Map.fromList variables) curcontext ast + Left err -> do + let !msg = "template " ++ filename ++ " could not be parsed " ++ show err + traceEventIO msg + LOG.debugM "Erb.Compute" msg + measure mstats ("ruby - " ++ filename) $ computeTemplateWRuby filename curcontext variables + Right ast -> case rubyEvaluate variables curcontext ast of + Right ev -> return (Right ev) + Left err -> do + let !msg = "template " ++ filename ++ " evaluation failed " ++ show err + traceEventIO msg + LOG.debugM "Erb.Compute" msg + measure mstats ("ruby efail - " ++ filename) $ computeTemplateWRuby filename curcontext variables -computeTemplateWRuby :: String -> String -> [(String, GeneralValue)] -> IO TemplateAnswer +computeTemplateWRuby :: String -> String -> Map.Map 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 + let rubyvars = BB.string8 "{\n" <> mconcat (intersperse (BB.string8 ",\n") (concatMap toRuby (Map.toList variables))) <> BB.string8 "\n}\n" :: BB.Builder + input = BB.stringUtf8 curcontext <> BB.charUtf8 '\n' <> BB.stringUtf8 filename <> BB.charUtf8 '\n' <> rubyvars :: BB.Builder 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 + ret <- safeReadProcessTimeout "ruby" [rubyscriptpath] (BB.toLazyByteString input) 1000 case ret of - Just (Right x) -> return $ Right x + Just (Right x) -> return $ Right (BS.unpack x) Just (Left er) -> do (tmpfilename, tmphandle) <- openTempFile "/tmp" "templatefail" - hPutStr tmphandle input + BS.hPut tmphandle (BB.toLazyByteString input) hClose tmphandle return $ Left $ er ++ " - for template " ++ filename ++ " input in " ++ tmpfilename Nothing -> do return $ Left "Process did not terminate" +minterc :: BB.Builder -> [BB.Builder] -> BB.Builder +minterc _ [] = mempty +minterc _ [a] = a +minterc !sep !(x:xs) = x <> foldl' minterc' mempty xs + where + minterc' !curbuilder !b = curbuilder <> sep <> b + getTemplateFile :: String -> CatalogMonad String getTemplateFile rawpath = do throwError rawpath - +renderString :: String -> BB.Builder +renderString x = let !y = BB.stringUtf8 (show x) in y +{- +renderString cs = BB.char8 '"' <> foldMap escape cs <> BB.char8 '"' + where + escape '\\' = BB.string8 "\\\\" + escape '\"' = BB.string8 "\\\"" + escape '\n' = BB.string8 "\\n" + escape c = BB.charUtf8 c +-} toRuby (_, Left _) = [] toRuby (_, Right ResolvedUndefined) = [] -toRuby (varname, Right varval) = ["\t" ++ show varname ++ " => " ++ toRuby' varval] -toRuby' (ResolvedString str) = show str -toRuby' (ResolvedInt i) = "'" ++ show i ++ "'" -toRuby' (ResolvedBool True) = "true" -toRuby' (ResolvedBool False) = "false" -toRuby' (ResolvedArray rr) = "[" ++ intercalate ", " (map toRuby' rr) ++ "]" -toRuby' (ResolvedHash hh) = "{ " ++ intercalate ", " (map (\(varname, varval) -> show varname ++ " => " ++ toRuby' varval) hh) ++ " }" -toRuby' ResolvedUndefined = ":undef" -toRuby' x = show x +toRuby (varname, Right varval) = [BB.charUtf8 '\t' <> renderString varname <> BB.string8 " => " <> toRuby' varval] +toRuby' (ResolvedString str) = renderString str +toRuby' (ResolvedInt i) = BB.charUtf8 '\'' <> BB.intDec (fromIntegral i) <> BB.charUtf8 '\'' +toRuby' (ResolvedBool True) = BB.string8 "true" +toRuby' (ResolvedBool False) = BB.string8 "false" +--toRuby' (ResolvedArray rr) = BB.charUtf8 '[' <> mconcat (intercalate [BB.string8 ", "] (map (return . toRuby') rr)) <> BB.charUtf8 ']' +--toRuby' (ResolvedHash hh) = BB.string8 "{ " <> mconcat (intercalate [BB.string8 ", "] (map (\(varname, varval) -> [renderString varname <> BB.string8 " => " <> toRuby' varval]) hh)) <> BB.string8 " }" +toRuby' (ResolvedArray rr) = BB.charUtf8 '[' <> minterc (BB.string8 ", ") (map toRuby' rr) <> BB.charUtf8 ']' +toRuby' (ResolvedHash hh) = BB.string8 "{ " <> minterc (BB.string8 ", ") (map (\(varname, varval) -> renderString varname <> BB.string8 " => " <> toRuby' varval) hh) <> BB.string8 " }" +toRuby' ResolvedUndefined = BB.string8 ":undef" +toRuby' x = BB.string8 $ show x diff --git a/Erb/Parser.hs b/Erb/Parser.hs --- a/Erb/Parser.hs +++ b/Erb/Parser.hs @@ -33,22 +33,22 @@ identifier = P.identifier lexer rubyexpression = buildExpressionParser table term "expression" - -table = [ [ Infix ( reservedOp "+" >> return PlusOperation ) AssocLeft + +table = [ [ Infix ( reservedOp "+" >> return PlusOperation ) AssocLeft , Infix ( reservedOp "-" >> return MinusOperation ) AssocLeft ] - , [ Infix ( reservedOp "/" >> return DivOperation ) AssocLeft + , [ Infix ( reservedOp "/" >> return DivOperation ) AssocLeft , Infix ( reservedOp "*" >> return MultiplyOperation ) AssocLeft ] - , [ Infix ( reservedOp "<<" >> return ShiftLeftOperation ) AssocLeft + , [ Infix ( reservedOp "<<" >> return ShiftLeftOperation ) AssocLeft , Infix ( reservedOp ">>" >> return ShiftRightOperation ) AssocLeft ] - , [ Infix ( reservedOp "and" >> return AndOperation ) AssocLeft + , [ Infix ( reservedOp "and" >> return AndOperation ) AssocLeft , Infix ( reservedOp "or" >> return OrOperation ) AssocLeft ] - , [ Infix ( reservedOp "==" >> return EqualOperation ) AssocLeft + , [ Infix ( reservedOp "==" >> return EqualOperation ) AssocLeft , Infix ( reservedOp "!=" >> return DifferentOperation ) AssocLeft ] - , [ Infix ( reservedOp ">" >> return AboveOperation ) AssocLeft + , [ Infix ( reservedOp ">" >> return AboveOperation ) AssocLeft , Infix ( reservedOp ">=" >> return AboveEqualOperation ) AssocLeft - , Infix ( reservedOp "<=" >> return UnderEqualOperation ) AssocLeft + , Infix ( reservedOp "<=" >> return UnderEqualOperation ) AssocLeft , Infix ( reservedOp "<" >> return UnderOperation ) AssocLeft ] - , [ Infix ( reservedOp "=~" >> return RegexpOperation ) AssocLeft + , [ Infix ( reservedOp "=~" >> return RegexpOperation ) AssocLeft , Infix ( reservedOp "!~" >> return NotRegexpOperation ) AssocLeft ] , [ Prefix ( symbol "!" >> return NotOperation ) ] , [ Prefix ( symbol "-" >> return NegOperation ) ] @@ -57,20 +57,37 @@ ] term = parens rubyexpression + <|> scopeLookup + <|> stringLiteral <|> objectterm <|> variablereference +scopeLookup = do + try $ string "scope.lookupvar(" + expr <- rubyexpression + char ')' + return $ Object $ expr + blockinfo = many1 $ noneOf "}" +stringLiteral = doubleQuoted <|> singleQuoted + +doubleQuoted = fmap (Value . Literal) $ between (char '"') (char '"') (many $ noneOf "\"") +singleQuoted = fmap (Value . Literal) $ between (char '\'') (char '\'') (many $ noneOf "'") + objectterm = do methodname <- identifier >>= return . Value . Literal - isblock <- optionMaybe (symbol "{") - case isblock of - Just _ -> do + nc <- lookAhead anyChar + case nc of + '{' -> do + symbol "{" b <- blockinfo symbol "}" return $ MethodCall methodname (BlockOperation b) - Nothing -> return $ Object methodname + '(' -> do + args <- parens (rubyexpression `sepBy` symbol ",") + return $ MethodCall methodname (Value $ Array args) + _ -> return $ Object methodname variablereference = identifier >>= return . Object . Value . Literal @@ -102,6 +119,7 @@ parsed <- case isequal of Just _ -> spaces >> rubyexpression >>= return . Puts Nothing -> spaces >> rubystatement + spaces string "%>" n <- textblock return (parsed : n) diff --git a/Erb/Ruby.hs b/Erb/Ruby.hs --- a/Erb/Ruby.hs +++ b/Erb/Ruby.hs @@ -2,6 +2,7 @@ data Value = Literal String + | Array [Expression] deriving (Show, Ord, Eq) data Expression diff --git a/Puppet/Daemon.hs b/Puppet/Daemon.hs --- a/Puppet/Daemon.hs +++ b/Puppet/Daemon.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BangPatterns #-} module Puppet.Daemon (initDaemon) where import Puppet.Init @@ -21,17 +22,14 @@ import qualified Data.List.Utils as DLU import qualified Data.Map as Map import Text.Parsec.Pos (initialPos) +import Puppet.Stats +import Debug.Trace -- this daemon returns a catalog when asked for a node and facts data DaemonMessage = QCatalog (String, Facts, Chan DaemonMessage) | RCatalog (Either String FinalCatalog) --- nbstats nbrequests -data DaemonStats = DaemonStats Int Integer - deriving (Show) - - logDebug = LOG.debugM "Puppet.Daemon" logInfo = LOG.infoM "Puppet.Daemon" logWarning = LOG.warningM "Puppet.Daemon" @@ -40,7 +38,8 @@ {-| This is a high level function, that will initialize the parsing and interpretation infrastructure from the 'Prefs' structure, and will return a function that will take a node name, 'Facts' and return either an error or the -'FinalCatalog'. +'FinalCatalog'. It also return a few IO functions that can be used in order to +query the daemon for statistics, following the format in "Puppet.Stats". It will internaly initialize several threads that communicate with channels. It should scale well, althrough it hasn't really been tested yet. It should cache @@ -63,7 +62,7 @@ * It might be buggy when top level statements that are not class/define/nodes are altered, or when files loaded with require are changed. -* Exported resources are not yet supported. +* Exported resources are supported through the PuppetDB interface. * The catalog is not computed exactly the same way Puppet does. Take a look at "Puppet.Interpreter.Catalog" for a list of differences. @@ -75,35 +74,42 @@ is not existent. This will need fixing. -} -initDaemon :: Prefs -> IO ( String -> Facts -> IO(Either String FinalCatalog) ) +initDaemon :: Prefs -> IO ( String -> Facts -> IO(Either String FinalCatalog), IO StatsTable, IO StatsTable, IO StatsTable ) initDaemon prefs = do logDebug "initDaemon" - controlChan <- newChan - getstmts <- initParserDaemon prefs - templatefunc <- initTemplateDaemon prefs - forkIO (master prefs controlChan getstmts templatefunc) - return (gCatalog controlChan) + traceEventIO "initDaemon" + controlChan <- newChan + templateStats <- newStats + parserStats <- newStats + catalogStats <- newStats + getstmts <- initParserDaemon prefs parserStats + templatefunc <- initTemplateDaemon prefs templateStats + replicateM_ (compilepoolsize prefs) (forkIO (master prefs controlChan getstmts templatefunc catalogStats)) + return (gCatalog controlChan, getStats parserStats, getStats catalogStats, getStats templateStats) master :: Prefs -> Chan DaemonMessage -> (TopLevelType -> String -> IO (Either String Statement)) - -> (String -> String -> [(String, GeneralValue)] -> IO (Either String String)) + -> (String -> String -> Map.Map String GeneralValue -> IO (Either String String)) + -> MStats -> IO () -master prefs chan getstmts gettemplate = do +master prefs chan getstmts gettemplate mstats = do message <- readChan chan case message of QCatalog (nodename, facts, respchan) -> do logDebug ("Received query for node " ++ nodename) + traceEventIO ("Received query for node " ++ nodename) let pdbfunc = case (puppetDBurl prefs) of Just x -> Just (pdbResRequest x) Nothing -> Nothing - (stmts, warnings) <- getCatalog getstmts gettemplate pdbfunc nodename facts (Just $ modules prefs) (natTypes prefs) + (!stmts, !warnings) <- measure mstats nodename $ getCatalog getstmts gettemplate pdbfunc nodename facts (Just $ modules prefs) (natTypes prefs) + traceEventIO ("getCatalog finished for " ++ nodename) mapM_ logWarning warnings case stmts of Left x -> writeChan respchan (RCatalog $ Left x) - Right x -> writeChan respchan (RCatalog $ Right x) + Right !x -> writeChan respchan (RCatalog $ Right x) _ -> logError "Bad message type for master" - master prefs chan getstmts gettemplate + master prefs chan getstmts gettemplate mstats gCatalog :: Chan DaemonMessage -> String -> Facts -> IO (Either String FinalCatalog) gCatalog channel nodename facts = do @@ -119,14 +125,14 @@ = QStatement (TopLevelType, String, Chan ParserMessage) | RStatement (Either String Statement) -initParserDaemon :: Prefs -> IO +initParserDaemon :: Prefs -> MStats -> IO ( TopLevelType -> String -> IO (Either String Statement) ) -initParserDaemon prefs = do +initParserDaemon prefs mstats = do logDebug "initParserDaemon" controlChan <- newChan - getparsed <- initParsedDaemon prefs - forkIO (pmaster prefs controlChan getparsed) + getparsed <- initParsedDaemon prefs mstats + replicateM_ (parsepoolsize prefs) (forkIO (pmaster prefs controlChan getparsed)) return (getStatements controlChan) -- extracts data from a filestatus @@ -285,7 +291,7 @@ pmessage <- readChan chan case pmessage of QStatement (qtype, name, respchan) -> do - out <- runErrorT $ handlePRequest prefs cachefuncs qtype name + out <- runErrorT $ handlePRequest prefs cachefuncs qtype name case out of Left x -> writeChan respchan $ RStatement $ Left x Right y -> writeChan respchan $ RStatement $ Right y @@ -308,23 +314,22 @@ = GetParsedData TopLevelType String (Chan ParsedCacheResponse) | UpdateParsedData TopLevelType String CacheEntry (Chan ParsedCacheResponse) | InvalidateCacheFile String (Chan ParsedCacheResponse) - | GetStats (Chan DaemonStats) data ParsedCacheResponse = CacheError String | RCacheEntry CacheEntry | NoCacheEntry | CacheUpdated - + -- this one is singleton, and is used to cache de parsed values, along with the file names they depend on -initParsedDaemon :: Prefs -> IO +initParsedDaemon :: Prefs -> MStats -> IO ( TopLevelType -> String -> ErrorT String IO (Maybe CacheEntry) , TopLevelType -> String -> CacheEntry -> IO ParsedCacheResponse , String -> IO ParsedCacheResponse ) -initParsedDaemon prefs = do +initParsedDaemon prefs mstats = do logDebug "initParsedDaemon" controlChan <- newChan - forkIO ( evalStateT (parsedmaster prefs controlChan) (Map.empty, Map.empty, 0 :: Integer) ) + forkIO ( evalStateT (parsedmaster prefs controlChan mstats) (Map.empty, Map.empty) ) return (getParsedInformation controlChan, updateParsedInformation controlChan, invalidateCachedFile controlChan) getParsedInformation :: Chan ParsedCacheQuery -> TopLevelType -> String -> ErrorT String IO (Maybe CacheEntry) @@ -351,27 +356,22 @@ readChan respchan -- state : (parsed statements map, file association map, nbrequests) -parsedmaster :: Prefs -> Chan ParsedCacheQuery -> StateT +parsedmaster :: Prefs -> Chan ParsedCacheQuery -> MStats -> StateT ( Map.Map (TopLevelType, String) CacheEntry , Map.Map FilePath (FileStatus, [(TopLevelType, String)]) - , Integer ) IO () -parsedmaster prefs controlchan = do +parsedmaster prefs controlchan mstats = do curmsg <- liftIO $ readChan controlchan case curmsg of - GetStats respchan -> do - (curmap, _, nbrequests) <- get - liftIO $ writeChan respchan $ DaemonStats (Map.size curmap) nbrequests GetParsedData qtype name respchan -> do - (curmap, _, _) <- get - modify (\(mp, fm, rq) -> (mp, fm, rq + 1)) + (curmap, _) <- get case Map.lookup (qtype, name) curmap of - Just x -> liftIO $ writeChan respchan (RCacheEntry x) - Nothing -> liftIO $ writeChan respchan NoCacheEntry + Just x -> liftIO $ measure mstats "hit" (writeChan respchan (RCacheEntry x)) + Nothing -> liftIO $ measure mstats "miss" (writeChan respchan NoCacheEntry) UpdateParsedData qtype name val@(_, filepath, filestatus, _) respchan -> do - liftIO $ logDebug ("Updating parsed cache for " ++ show qtype ++ " " ++ name) - (mp, fm, rq) <- get - let + liftIO $ logInfo ("Updating parsed cache for " ++ show qtype ++ " " ++ name) + (mp, fm) <- get + let -- retrieve the current status curstatus = Map.lookup filepath fm fmclean = case curstatus of @@ -382,16 +382,16 @@ addsnd (a1, b1) (_, b2) = (a1, b1 ++ b2) fileassocmap = Map.insertWith addsnd filepath (filestatus, [(qtype, name)]) fmclean statementmap = Map.insert (qtype, name) val mp - put (statementmap, fileassocmap, rq+1) - liftIO $ writeChan respchan CacheUpdated + put (statementmap, fileassocmap) + liftIO $ measure mstats "update" (writeChan respchan CacheUpdated) InvalidateCacheFile fname respchan -> do liftIO $ logDebug $ "Invalidating files for " ++ fname - (mp, fm, rq) <- get + (mp, fm) <- get let nfm = Map.delete fname fm 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 - parsedmaster prefs controlchan + put (nmp, nfm) + liftIO $ measure mstats "invalidate" (writeChan respchan CacheUpdated) + parsedmaster prefs controlchan mstats diff --git a/Puppet/Init.hs b/Puppet/Init.hs --- a/Puppet/Init.hs +++ b/Puppet/Init.hs @@ -14,6 +14,7 @@ templates :: FilePath, -- ^ The path to the template. compilepoolsize :: Int, -- ^ Size of the compiler pool. parsepoolsize :: Int, -- ^ Size of the parser pool. + erbpoolsize :: Int, -- ^ Size of the template pool. puppetDBurl :: Maybe String, -- ^ Url of the PuppetDB connector (must be cleartext). natTypes :: Map.Map PuppetTypeName PuppetTypeMethods -- ^ The list of native types. } @@ -28,7 +29,7 @@ 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) + return $ Prefs manifestdir modulesdir templatedir 1 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 @@ -1,3 +1,4 @@ +{-# LANGUAGE BangPatterns #-} {-| This module exports the 'getCatalog' function, that computes catalogs from parsed manifests. The behaviour of this module is probably non canonical on many details. The problem is that most of Puppet behaviour is undocumented or @@ -50,16 +51,7 @@ import Control.Monad.Error import qualified Data.Map as Map import qualified Data.Set as Set - --- Utility function used to check if the there are duplicates a in [(a,_)] -checkDuplicateFirst :: (Show a, Eq a) => [(a,b)] -> CatalogMonad () -checkDuplicateFirst list = - let fsts = ldups (map fst list) [] - ldups [] a = a - ldups (x:xs) a | x `elem` xs = x:a - | otherwise = ldups xs a - in unless (null fsts) $ throwPosError $ "Duplicate parameters " ++ show fsts - +import qualified Data.Traversable as DT qualified [] = False qualified str = isPrefixOf "::" str || qualified (tail str) @@ -75,7 +67,7 @@ getCatalog :: (TopLevelType -> String -> IO (Either String Statement)) -- ^ The \"get statements\" function. Given a top level type and its name it -- should return the corresponding statement. - -> (String -> String -> [(String, GeneralValue)] -> IO (Either String String)) + -> (String -> String -> Map.Map String GeneralValue -> IO (Either String String)) -- ^ The \"get template\" function. Given a file name, a scope name and a -- list of variables, it should return the computed template. -> Maybe (String -> PDB.Query -> IO (Either String [CResource])) @@ -94,12 +86,12 @@ (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 ) ) + (!output, !finalstate) <- runStateT ( runErrorT ( computeCatalog getstatements nodename ) ) (ScopeState { curScope = [["::"]] , curVariables = convertedfacts , curClasses = Map.empty - , curDefaults = [] + , curDefaults = Map.empty , curResId = 1 , curPos = (initialPos "dummy") , nestedtoplevels = Map.empty @@ -135,8 +127,7 @@ finalizeResource cr@(CResource cid cname ctype cparams _ cpos) = do setPos cpos rname <- resolveGeneralString cname - rparams <- mapM (\(a,b) -> do { ra <- resolveGeneralString a; rb <- resolveGeneralValue b; return (ra,rb); }) cparams - checkDuplicateFirst rparams + rparams <- mapM (\(a,b) -> do { ra <- resolveGeneralString a; rb <- resolveGeneralValue b; return (ra,rb); }) (Map.toList cparams) -- add collected relations -- TODO ntypes <- fmap nativeTypes get @@ -170,12 +161,12 @@ processOverride :: CResource -> Map.Map String ResolvedValue -> CatalogMonad (Map.Map String ResolvedValue) processOverride cr prms = - let applyOverride :: CResource -> Map.Map String ResolvedValue -> (CResource -> CatalogMonad Bool, [(GeneralString, GeneralValue)], Maybe PDB.Query) -> CatalogMonad (Map.Map String ResolvedValue) + let applyOverride :: CResource -> Map.Map String ResolvedValue -> (CResource -> CatalogMonad Bool, Map.Map GeneralString GeneralValue, Maybe PDB.Query) -> CatalogMonad (Map.Map String ResolvedValue) -- this checks if the collection function matches applyOverride c prm (func, overs, _) = do check <- func c if check - then foldM tryReplace prm overs + then foldM tryReplace prm (Map.toList overs) else return prm tryReplace :: Map.Map String ResolvedValue -> (GeneralString, GeneralValue) -> CatalogMonad (Map.Map String ResolvedValue) -- if it does, this resolves the override and applies it @@ -185,7 +176,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 $ null x) . curCollect) get >>= foldM (applyOverride cr) prms + in liftM (filter (\(_, x, _) -> not $ Map.null x) . curCollect) get >>= foldM (applyOverride cr) prms retrieveRemoteResources :: (PDB.Query -> IO (Either String [CResource])) -> PDB.Query -> CatalogMonad [CResource] retrieveRemoteResources f q = do @@ -249,7 +240,32 @@ -- State alteration functions pushScope = modify . modifyScope . (:) -pushDefaults = modify . modifyDefaults . (:) + +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 }) + +emptyDefaults :: CatalogMonad () +emptyDefaults = do + curstate <- get + let curscope = (head . curScope) curstate + curdefaults = curDefaults curstate + newdefaults = Map.delete curscope curdefaults + put (curstate { curDefaults = newdefaults }) + +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 + popScope = modify (modifyScope tail) getScope = do scope <- liftM curScope get @@ -316,10 +332,10 @@ Those that define relationship must be properly resolved or hell will break loose. This is a BUG. -} -partitionParamsRelations :: [(GeneralString, GeneralValue)] -> ([(GeneralString, GeneralValue)], [(LinkType, GeneralValue, GeneralValue)]) +partitionParamsRelations :: Map.Map GeneralString GeneralValue -> (Map.Map GeneralString GeneralValue, [(LinkType, GeneralValue, GeneralValue)]) partitionParamsRelations rparameters = (realparams, relations) - where realparams = filteredparams - relations = concatMap convertrelation filteredrelations + where realparams = filteredparams :: Map.Map GeneralString GeneralValue + relations = concatMap convertrelation (Map.toList filteredrelations) :: [(LinkType, GeneralValue, GeneralValue)] convertrelation :: (GeneralString, GeneralValue) -> [(LinkType, GeneralValue, GeneralValue)] convertrelation (_, Right ResolvedUndefined) = [] convertrelation (reltype, Right (ResolvedArray rs)) = concatMap (\x -> convertrelation (reltype, Right x)) rs @@ -327,7 +343,7 @@ convertrelation (reltype, Right (ResolvedString "undef")) = [(fromJust $ getRelationParameterType reltype, Right $ ResolvedString "undef", Right $ ResolvedString "undef")] convertrelation (_, Left x) = error ("partitionParamsRelations unresolved : " ++ show x) convertrelation x = error ("partitionParamsRelations error : " ++ show x) - (filteredrelations, filteredparams) = partition (isJust . getRelationParameterType . fst) rparameters -- filters relations with actual parameters + (filteredrelations, filteredparams) = Map.partitionWithKey (const . isJust . getRelationParameterType) rparameters -- filters relations with actual parameters -- TODO check whether parameters changed checkLoaded name = do @@ -343,9 +359,20 @@ rb <- tryResolveExpression b return (ra, rb) +-- safely insert parameters, checking they are not already defined +addParameters :: Map.Map GeneralString GeneralValue -> [(Expression, Expression)] -> CatalogMonad (Map.Map GeneralString GeneralValue) +addParameters m p = foldM rp m p + where + rp :: Map.Map GeneralString GeneralValue -> (Expression, Expression) -> CatalogMonad (Map.Map GeneralString GeneralValue) + rp curmap prm = do + (k, v) <- resolveParams prm + case Map.lookup k curmap of + Just _ -> throwPosError $ "Parameter " ++ show k ++ " had been declared twice!" + Nothing -> return (Map.insert k v curmap) + -- apply default values to a resource applyDefaults :: CResource -> CatalogMonad CResource -applyDefaults res = liftM curDefaults get >>= foldM applyDefaults' res +applyDefaults res = getCurDefaults >>= foldM applyDefaults' res applyDefaults' :: CResource -> ResDefaults -> CatalogMonad CResource applyDefaults' r@(CResource i rname rtype rparams rvirtuality rpos) (RDefaults dtype rdefs dpos) = do @@ -367,14 +394,12 @@ else return r -- merge defaults and actual parameters depending on the override flag -mergeParams :: [(GeneralString, GeneralValue)] -> [(GeneralString, GeneralValue)] -> Bool -> ([(GeneralString, GeneralValue)], [(LinkType, GeneralValue, GeneralValue)]) -mergeParams srcparams defs override = let - (dstparams, dstrels) = partitionParamsRelations defs - srcprm = Map.fromList srcparams - dstprm = Map.fromList dstparams +mergeParams :: Map.Map GeneralString GeneralValue -> Map.Map GeneralString GeneralValue -> Bool -> (Map.Map GeneralString GeneralValue, [(LinkType, GeneralValue, GeneralValue)]) +mergeParams srcprm defs override = let + (dstprm, dstrels) = partitionParamsRelations defs prm = if override - then Map.toList $ Map.union dstprm srcprm - else Map.toList $ Map.union srcprm dstprm + then Map.union dstprm srcprm + else Map.union srcprm dstprm in (prm, dstrels) -- The actual meat @@ -385,12 +410,11 @@ --oldpos <- getPos pushScope ["#DEFINE#" ++ dtype] -- add variables - mrrparams <- mapM (\(gs, gv) -> do { rgs <- resolveGeneralString gs; rgv <- tryResolveGeneralValue gv; return (rgs, (rgv, dpos)); }) rparams + mparams <- fmap Map.fromList $ mapM (\(gs, gv) -> do { rgs <- resolveGeneralString gs; rgv <- tryResolveGeneralValue gv; return (rgs, (rgv, dpos)); }) (Map.toList rparams) let expr = gs2gv rname - mparams = Map.fromList mrrparams defineparamset = Set.fromList $ map fst args mandatoryparams = Set.fromList $ map fst $ filter (isNothing . snd) args - resourceparamset = Set.fromList $ map fst mrrparams + resourceparamset = Map.keysSet mparams extraparams = Set.difference resourceparamset (Set.union defineparamset metaparameters) unsetparams = Set.difference mandatoryparams resourceparamset unless (Set.null extraparams) $ throwPosError $ "Spurious parameters set for " ++ dtype ++ ": " ++ intercalate ", " (Set.toList extraparams) @@ -420,14 +444,13 @@ handleDelayedActions :: Catalog -> CatalogMonad Catalog handleDelayedActions res = do dres <- liftM concat (mapM applyDefaults res >>= mapM evaluateDefine) - modify emptyDefaults + 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 + rparameters <- addParameters Map.empty parameters srname <- case grname of Right e -> do rse <- rstring e @@ -466,11 +489,10 @@ case rtype of -- checks whether we are handling a parametrized class "class" -> do - rparameters <- mapM (\(a,b) -> do { pa <- resolveExpressionString a; pb <- tryResolveExpression b; return (pa, pb) } ) parameters - checkDuplicateFirst rparameters + rparameters <- fmap Map.fromList $ mapM (\(a,b) -> do { pa <- resolveExpressionString a; pb <- tryResolveExpression b; return (pa, pb) } ) parameters classname <- resolveExpressionString rname topstatement <- getstatement TopClass classname - let classparameters = Map.fromList $ map (\(pname, pvalue) -> (pname, (pvalue, position))) rparameters + let classparameters = Map.map (\pvalue -> (pvalue, position)) rparameters :: Map.Map String (GeneralValue, SourcePos) evaluateClass topstatement classparameters Nothing _ -> do srname <- tryResolveExpression rname @@ -479,12 +501,12 @@ _ -> addResource rtype parameters virtuality position srname evaluateStatements (ResourceDefault rdtype rdparams rdpos) = do - rrdparams <- mapM resolveParams rdparams + rrdparams <- addParameters Map.empty rdparams pushDefaults $ RDefaults rdtype rrdparams rdpos return [] evaluateStatements (ResourceOverride rotype roname roparams ropos) = do rroname <- tryResolveExpressionString roname - rroparams <- mapM resolveParams roparams + rroparams <- addParameters Map.empty roparams pushDefaults $ ROverride rotype rroname rroparams ropos return [] evaluateStatements (DependenceChain (srctype, srcname) (dsttype, dstname) position) = do @@ -498,7 +520,7 @@ setPos position when (not $ null overrides) $ throwPosError $ "Amending attributes with a Collector only works with <| |>, not <<| |>>." func <- collectionFunction Exported rtype expr - addCollect (func, []) + addCollect (func, Map.empty) return [] -- <| |> -- TODO : check that this is a native type when overrides are defined. @@ -506,7 +528,7 @@ evaluateStatements (VirtualResourceCollection rtype expr overrides position) = do setPos position func <- collectionFunction Virtual rtype expr - prms <- mapM resolveParams overrides + prms <- addParameters Map.empty overrides addCollect (func, prms) return [] @@ -585,7 +607,7 @@ -- depend explicitely on a class popScope return $ - [CResource resid (Right classname) "class" [] Normal position] + [CResource resid (Right classname) "class" Map.empty Normal position] ++ inherited ++ nres @@ -866,10 +888,11 @@ case fname of 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 + 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 - out <- liftIO (templatefunc filename scp vars) + out <- liftIO (templatefunc filename scp (Map.map fst vars)) case out of Right x -> return $ Right $ ResolvedString x Left err -> throwPosError err @@ -988,7 +1011,7 @@ myfunction (CResource _ mcrname mcrtype _ _ _) = do srname <- resolveGeneralString mcrname return ((srname == rname) && (mcrtype == rtype)) - addCollect ((myfunction, Just $ PDB.queryRealize rtype rname) , []) + addCollect ((myfunction, Just $ PDB.queryRealize rtype rname) , Map.empty) return () pushRealize (ResolvedRReference _ x) = throwPosError (show x ++ " was not resolved to a string") pushRealize x = throwPosError ("A reference was expected instead of " ++ show x) @@ -1010,8 +1033,8 @@ _ -> throwPosError $ "Resource definition must be a hash, and not " ++ show rdefs position <- getPos defaults <- case rest of - [ResolvedHash h] -> return $ RDefaults mrrtype (map (\(a,b) -> (Right a, Right b)) h) position - [] -> return $ RDefaults mrrtype [] position + [ResolvedHash h] -> return $ RDefaults mrrtype (Map.fromList $ map (\(a,b) -> (Right a, Right b)) h) position + [] -> return $ RDefaults mrrtype Map.empty position _ -> throwPosError ("Bad many arguments to create_resources: " ++ show rest) let prestatements = map (\(rname, rargs) -> (Value $ Literal rname, resolved2expression rargs)) arghash resources <- mapM (\(resname, pval) -> do @@ -1135,11 +1158,10 @@ when (Set.notMember paramname paramset && (not $ Set.member paramname metaparameters)) $ 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) :: [(GeneralString, GeneralValue)] - if null param - then return False - else do - cmp <- resolveGeneralValue $ snd (head param) + case Map.lookup (Right paramname) (crparams r) of + Nothing -> return False + Just prmmatch -> do + cmp <- resolveGeneralValue prmmatch case (paramname, cmp) of ("tag", ResolvedArray xs) -> let filtered = filter (compareRValues rb) xs diff --git a/Puppet/Interpreter/Functions.hs b/Puppet/Interpreter/Functions.hs --- a/Puppet/Interpreter/Functions.hs +++ b/Puppet/Interpreter/Functions.hs @@ -28,6 +28,7 @@ import SafeProcess import Data.Either (lefts, rights) import Data.List (intercalate) +import qualified Data.ByteString.Lazy.Char8 as BSL puppetMD5 = md5s . Str puppetSHA1 = BS.unpack . B16.encode . SHA1.hash . BS.pack @@ -107,9 +108,9 @@ generate :: String -> [String] -> IO (Maybe String) generate command args = do - cmdout <- safeReadProcessTimeout command args "" 60000 + cmdout <- safeReadProcessTimeout command args (BSL.empty) 60000 case cmdout of - Just (Right x) -> return $ Just x + Just (Right x) -> return $ Just (BSL.unpack x) _ -> return Nothing pdbresourcequery :: String -> Maybe String -> CatalogMonad ResolvedValue diff --git a/Puppet/Interpreter/Types.hs b/Puppet/Interpreter/Types.hs --- a/Puppet/Interpreter/Types.hs +++ b/Puppet/Interpreter/Types.hs @@ -62,7 +62,7 @@ crid :: Int, -- ^ Resource ID, used in the Puppet YAML. crname :: GeneralString, -- ^ Resource name. crtype :: String, -- ^ Resource type. - crparams :: [(GeneralString, GeneralValue)], -- ^ Resource parameters. + crparams :: Map.Map GeneralString GeneralValue, -- ^ Resource parameters. crvirtuality :: Virtuality, -- ^ Resource virtuality. pos :: SourcePos -- ^ Source code position of the resource definition. } deriving(Show) @@ -96,8 +96,8 @@ {-| A data type to hold defaults values -} -data ResDefaults = RDefaults String [(GeneralString, GeneralValue)] SourcePos - | ROverride String GeneralString [(GeneralString, GeneralValue)] SourcePos +data ResDefaults = RDefaults String (Map.Map GeneralString GeneralValue) SourcePos + | ROverride String GeneralString (Map.Map GeneralString GeneralValue) SourcePos deriving (Show, Ord, Eq) {-| The most important data structure for the interpreter. It stores its @@ -116,7 +116,7 @@ curClasses :: !(Map.Map String SourcePos), -- ^ The list of classes that have already been included, along with the -- place where this happened. - curDefaults :: ![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'. @@ -131,7 +131,7 @@ -- ^ This is a function that, given the type of a top level statement and -- its name, should return it. getWarnings :: ![String], -- ^ List of warnings. - curCollect :: ![(CResource -> CatalogMonad Bool, [(GeneralString, GeneralValue)], Maybe PDB.Query)], + curCollect :: ![(CResource -> CatalogMonad Bool, Map.Map GeneralString GeneralValue, Maybe PDB.Query)], -- ^ 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 @@ -139,7 +139,7 @@ unresolvedRels :: ![([(LinkType, GeneralValue, GeneralValue)], (String, GeneralString), RelUpdateType, SourcePos)], -- ^ This stores unresolved relationships, because the original string name -- can't be resolved. Fieds are [ ( [dstrelations], srcresource, type, pos ) ] - computeTemplateFunction :: String -> String -> [(String, GeneralValue)] -> IO (Either String String), + computeTemplateFunction :: String -> String -> Map.Map 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])), @@ -174,14 +174,13 @@ modifyScope f sc = sc { curScope = f $ curScope sc } 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 } 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 } addDefinedResource r = modify (\st -> st { definedResources = Set.insert r (definedResources st) } ) +saveVariables vars = modify (\st -> st { curVariables = vars }) throwPosError :: String -> CatalogMonad a throwPosError msg = do diff --git a/Puppet/Plugins.hs b/Puppet/Plugins.hs --- a/Puppet/Plugins.hs +++ b/Puppet/Plugins.hs @@ -29,9 +29,6 @@ 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 diff --git a/Puppet/Stats.hs b/Puppet/Stats.hs new file mode 100644 --- /dev/null +++ b/Puppet/Stats.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE BangPatterns #-} +{-| A quickly done module that exports utility functions used to collect various +statistics. All statistics are stored in a MVar holding a Map. +-} +module Puppet.Stats where + +import Data.Time.Clock.POSIX (getPOSIXTime) +import Control.Monad +import Control.Concurrent.MVar +import qualified Data.Map as Map + +data StatsPoint = StatsPoint !Int !Double !Double !Double + deriving(Show) +type StatsTable = Map.Map String StatsPoint + +type MStats = MVar StatsTable + +getStats :: MStats -> IO StatsTable +getStats = readMVar + +newStats :: IO MStats +newStats = newMVar Map.empty + +measure :: MStats -> String -> IO a -> IO a +measure mtable statsname action = do + (tm, out) <- time action + stats <- takeMVar mtable :: IO StatsTable + let nstats :: StatsTable + nstats = case Map.lookup statsname stats of + Nothing -> Map.insert statsname (StatsPoint 1 tm tm tm) stats + Just (StatsPoint sc st smi sma) -> + let nmax = if tm > sma + then tm + else sma + nmin = if tm < smi + then tm + else smi + in Map.insert statsname (StatsPoint (sc+1) (st+tm) nmin nmax) stats + putMVar mtable nstats + return out + +measure_ :: MStats -> String -> IO a -> IO () +measure_ mtable statsname act = void ( measure mtable statsname act ) + +getTime :: IO Double +getTime = realToFrac `fmap` getPOSIXTime + +time :: IO a -> IO (Double, a) +time act = do + start <- getTime + result <- act + end <- getTime + let !delta = end - start + return (delta, result) + diff --git a/Puppet/Testing.hs b/Puppet/Testing.hs --- a/Puppet/Testing.hs +++ b/Puppet/Testing.hs @@ -40,22 +40,22 @@ testFileSources puppetdir cat = let fileresources = Map.elems $ Map.filterWithKey (\k _ -> fst k == "file") cat filesources = catMaybes $ map (Map.lookup "source" . rrparams) fileresources - findPlaces :: String -> [String] - findPlaces stringdir = - let defaultsearch = puppetdir ++ "/files/" ++ stringdir - in case split "/" stringdir of - ("private":_) -> [puppetdir] -- not handled - ("modules":modulename:rest) -> [puppetdir ++ "/modules/" ++ modulename ++ "/files/" ++ intercalate "/" rest, defaultsearch] - _ -> [defaultsearch] + findPlace :: String -> Maybe String + findPlace stringdir = + case split "/" stringdir of + ("private":_) -> Just puppetdir -- not handled + ("modules":modulename:rest) -> Just $ puppetdir ++ "/modules/" ++ modulename ++ "/files/" ++ intercalate "/" rest + ("files":rest) -> Just $ puppetdir ++ "/files/" ++ intercalate "/" rest + _ -> Nothing checkSrcExists :: String -> FinalCatalog -> TestResult checkSrcExists src _ = runErrorT $ do let protostring = "puppet:///" unless (startswith protostring src) (throwError "Does not start with puppet:///") let stringdir = drop (length protostring) src - places = findPlaces stringdir - exists <- liftIO $ foldM (\c n -> if c then return True else fileExist n) False places - unless exists (throwError $ "Searched in " ++ show places) - return () + place = findPlace stringdir + case place of + Just dir -> liftIO (fileExist dir) >>= (`unless` (throwError $ "Searched in " ++ dir)) + Nothing -> throwError ("Unknown path: " ++ stringdir) genFileTest :: ResolvedValue -> Test genFileTest (ResolvedString src) = SingleTest (src ++ " exists") (checkSrcExists src) genFileTest (ResolvedArray arr) = TestFirstOk "First exists" (map genFileTest arr) diff --git a/PuppetDB/Rest.hs b/PuppetDB/Rest.hs --- a/PuppetDB/Rest.hs +++ b/PuppetDB/Rest.hs @@ -20,6 +20,7 @@ import Control.Monad.Error import Control.Applicative import qualified Text.Parsec.Pos as TPP +import qualified Data.Map as Map instance FromJSON ResolvedValue where parseJSON Null = return ResolvedUndefined @@ -42,7 +43,7 @@ sourceline <- o .: "sourceline" certname <- o .: "certname" let _ = params :: HM.HashMap String ResolvedValue - parameters = map (\(k,v) -> (Right k, Right v)) $ ("EXPORTEDSOURCE", ResolvedString certname) : HM.toList params :: [(GeneralString, GeneralValue)] + parameters = Map.fromList $ map (\(k,v) -> (Right k, Right v)) $ ("EXPORTEDSOURCE", ResolvedString certname) : HM.toList params :: Map.Map GeneralString GeneralValue position = TPP.newPos (sourcefile ++ "(host: " ++ certname ++ ")") sourceline 1 CResource <$> pure 0 <*> pure (Right utitle) @@ -66,12 +67,9 @@ Left err -> throwError err isNotLocal :: String -> CResource -> Bool -isNotLocal fqdn cr = - let prms = crparams cr - e = filter ((== Right "EXPORTEDSOURCE") . fst ) prms :: [(GeneralString, GeneralValue)] - in case e of - [(_, Right (ResolvedString x))] -> x /= fqdn - _ -> True +isNotLocal fqdn cr = case Map.lookup (Right "EXPORTEDSOURCE") (crparams cr) of + Just (Right (ResolvedString x)) -> x /= fqdn + _ -> True pdbResRequest :: String -> String -> PDB.Query -> IO (Either String [CResource]) pdbResRequest url fqdn qquery = do diff --git a/SafeProcess.hs b/SafeProcess.hs --- a/SafeProcess.hs +++ b/SafeProcess.hs @@ -10,8 +10,9 @@ import System.Posix.Signals import System.Process import System.Process.Internals +import qualified Data.ByteString.Lazy as BS -safeReadProcessTimeout :: String -> [String] -> String -> Int -> IO (Maybe (Either String String)) +safeReadProcessTimeout :: String -> [String] -> BS.ByteString -> Int -> IO (Maybe (Either String BS.ByteString)) safeReadProcessTimeout prog args input tout = timeout (tout*1000) $ safeReadProcess prog args input safeCreateProcess :: String -> [String] -> StdStream -> StdStream -> StdStream @@ -37,18 +38,18 @@ fun {-# NOINLINE safeCreateProcess #-} -safeReadProcess :: String -> [String] -> String -> IO (Either String String) +safeReadProcess :: String -> [String] -> BS.ByteString -> IO (Either String BS.ByteString) safeReadProcess prog args str = safeCreateProcess prog args CreatePipe CreatePipe Inherit (\(Just inh, Just outh, _, ph) -> do hSetBinaryMode inh True hSetBinaryMode outh True - hPutStr inh str + BS.hPut inh str hClose inh -- fork a thread to consume output - output <- hGetContents outh + output <- BS.hGetContents outh outMVar <- newEmptyMVar - forkIO $ evaluate (length output) >> putMVar outMVar () + forkIO $ evaluate (BS.length output) >> putMVar outMVar () -- wait on output takeMVar outMVar hClose outh 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.2.0.2 +Version: 0.2.2.0 -- A short (one-line) description of the package. Synopsis: Tools to parse and evaluate the Puppet DSL. @@ -30,7 +30,6 @@ Homepage: http://lpuppet.banquise.net - -- A copyright notice. -- Copyright: @@ -56,19 +55,12 @@ 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.Plugins, Puppet.Testing + Puppet.Interpreter.Types, Puppet.Interpreter.Catalog, Puppet.NativeTypes.Helpers, PuppetDB.Rest, PuppetDB.Query, Puppet.Plugins, Puppet.Testing, + Puppet.Stats -- Packages needed in order to build this package. - Build-depends: base >=4.5 && <4.6, - parsec >= 3.1.3, - MissingH >= 1.2, - containers >= 0.4.2.1, - pretty, - mtl >= 2.1.1, - 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, hslua, monad-loops, directory, - luautils >= 0.1.1, - transformers + Build-depends: base >=3 && <5,parsec,MissingH,containers,pretty,mtl,unix,hslogger,filepath,Glob,regexpr,process,bytestring>=0.10.2.0,cryptohash,base16-bytestring,regex-pcre-builtin, + iconv, text, unordered-containers, aeson, vector, http-types, http-conduit, attoparsec, failure, hslua, monad-loops, directory, luautils >= 0.1.1.0, transformers, time -- 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 @@ -78,7 +70,7 @@ -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source. -- Build-tools: - GHC-Prof-Options: -auto-all + GHC-Prof-Options: -auto-all -caf-all Test-Suite test-lexer hs-source-dirs: test @@ -107,4 +99,9 @@ ghc-options: -Wall build-depends: language-puppet,base main-is: lexer.hs + +source-repository head + type: git + location: git://github.com/bartavelle/language-puppet.git + diff --git a/test/interpreter.hs b/test/interpreter.hs --- a/test/interpreter.hs +++ b/test/interpreter.hs @@ -6,6 +6,7 @@ import Puppet.DSL.Types import Puppet.Interpreter.Catalog import Puppet.Interpreter.Types +import Puppet.NativeTypes import qualified Data.Map as Map import Data.Either import Data.List @@ -44,7 +45,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 Nothing "test" facts (Just "test/modules") + ctlg <- getCatalog (getstatement stmtpmap) gettemplate Nothing "test" facts (Just "test/modules") baseNativeTypes print ctlg case ctlg of (Right _, _) -> return ("PASS", True)