diff --git a/Puppet/Interpreter/Catalog.hs b/Puppet/Interpreter/Catalog.hs --- a/Puppet/Interpreter/Catalog.hs +++ b/Puppet/Interpreter/Catalog.hs @@ -112,6 +112,7 @@ , luaState = luastate , userFunctions = Set.fromList userfunctions , nativeTypes = ntypes + , definedResources = Set.empty } ) case luastate of Just l -> closeLua l @@ -428,7 +429,10 @@ rparameters <- mapM resolveParams parameters -- il faut transformer grname qui est une generalvalue en generalstring srname <- case grname of - Right e -> liftM Right (rstring e) + Right e -> do + rse <- rstring e + addDefinedResource (rtype, rse) + return $ Right rse Left e -> return $ Left e let (realparams, relations) = partitionParamsRelations rparameters -- push all the relations @@ -686,6 +690,13 @@ if null filtered then return $ Right $ ResolvedBool False else return $ Right $ ResolvedBool True + (Right (ResolvedHash h), Right idx) -> do + let filtered = filter (\(fa,_) -> fa == idx) h + if null filtered + then return $ Right $ ResolvedBool False + else return $ Right $ ResolvedBool True + (Right (ResolvedString _), Right _) -> throwPosError "in operator not yet implemented for substrings" + (Right ba, Right bb) -> throwPosError $ "Expected a string and a hash, array or string for the in operator, not " ++ show (ba,bb) _ -> 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 @@ -878,10 +889,9 @@ 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 (ResolvedRReference rtype (ResolvedString rname)) -> do + defset <- fmap definedResources get + return $ Right $ ResolvedBool (Set.member (rtype, rname) defset) 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 @@ -987,7 +997,11 @@ executeFunction "fail" [ResolvedString errmsg] = throwPosError ("Error: " ++ errmsg) executeFunction "fail" args = throwPosError ("Error: " ++ show args) executeFunction "realize" rlist = mapM_ pushRealize rlist >> return [] -executeFunction "create_resources" [mrtype, rdefs] = do +executeFunction "create_resources" (mrtype:rdefs:rest) = do +-- applyDefaults' :: CResource -> ResDefaults -> CatalogMonad CResource +-- data ResDefaults = RDefaults String [(GeneralString, GeneralValue)] SourcePos +-- +-- mrrtype <- case mrtype of ResolvedString x -> return x _ -> throwPosError $ "Resource type must be a string and not " ++ show mrtype @@ -995,6 +1009,10 @@ ResolvedHash x -> return x _ -> 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 + _ -> 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 realargs <- case pval of @@ -1002,7 +1020,7 @@ _ -> throwPosError "This should not happen, create_resources argument is not a hash" return $ Resource mrrtype resname realargs Normal position ) prestatements - liftM concat (mapM evaluateStatements resources) + liftM concat (mapM evaluateStatements resources) >>= mapM (\r -> applyDefaults' r defaults) executeFunction "create_resources" x = throwPosError ("Bad arguments to create_resources: " ++ show x) executeFunction "validate_array" [x] = case x of ResolvedArray _ -> return [] diff --git a/Puppet/Interpreter/Types.hs b/Puppet/Interpreter/Types.hs --- a/Puppet/Interpreter/Types.hs +++ b/Puppet/Interpreter/Types.hs @@ -149,8 +149,10 @@ -- ^ The Lua state, used for user supplied content. userFunctions :: Set.Set String, -- ^ The list of registered user functions - nativeTypes :: Map.Map PuppetTypeName PuppetTypeMethods + nativeTypes :: Map.Map PuppetTypeName PuppetTypeMethods, -- ^ The list of native types. + definedResources :: Set.Set (String, String) + -- ^ Horrible hack to kind of support the "defined" function } -- | The monad all the interpreter lives in. It is 'ErrorT' with a state. @@ -179,6 +181,7 @@ 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) } ) 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 @@ -72,28 +72,6 @@ valuetype _ = Lua.TUSERDATA -instance (Lua.StackValue a, Lua.StackValue b, Ord a) => Lua.StackValue (Map.Map a b) - where - push l mp = do - let llen = Map.size mp + 1 - Lua.createtable l llen 0 - forM_ (Map.toList mp) $ \(key, val) -> do - Lua.push l key - Lua.push l val - Lua.rawset l (-3) - peek l i = do - top <- Lua.gettop l - let ix = if (i < 0) then top + i + 1 else i - Lua.pushnil l - arr <- whileM (Lua.next l ix) $ do - xk <- Lua.peek l (-2) - xv <- Lua.peek l (-1) - Lua.pop l 1 - return (fromJust xk, fromJust xv) - return $ Just (Map.fromList arr) - valuetype _ = Lua.TTABLE - - getDirContents :: FilePath -> IO [FilePath] getDirContents x = fmap (filter (not . all (=='.'))) (getDirectoryContents x) diff --git a/Puppet/Testing.hs b/Puppet/Testing.hs new file mode 100644 --- /dev/null +++ b/Puppet/Testing.hs @@ -0,0 +1,87 @@ +module Puppet.Testing (testCatalog, Test, testFileSources) where + +import qualified Data.Map as Map +import Puppet.Interpreter.Types +import Data.List +import Data.Maybe +import Data.List.Utils +import Data.Either +import Control.Monad.Error +import System.Posix.Files + +type TestResult = IO (Either String ()) + +data TestR + = TestGroupR String [TestR] + | SingleTestR String (Either String ()) + deriving (Show) + +data Test + = TestGroup String [Test] + | TestFirstOk String [Test] + | SingleTest String (FinalCatalog -> TestResult) + +failedTests :: TestR -> Maybe TestR +failedTests (TestGroupR d tests) = case catMaybes (map failedTests tests) of + [] -> Nothing + x -> Just (TestGroupR d x) +failedTests t@(SingleTestR _ (Left _)) = Just t +failedTests _ = Nothing + +showRes :: TestR -> String +showRes = showRes' 0 + where + showRes' :: Int -> TestR -> String + showRes' dec (TestGroupR desc tsts) = replicate dec ' ' ++ desc ++ "\n" ++ unlines (map (showRes' (dec + 1)) tsts) + showRes' dec (SingleTestR desc (Right ())) = replicate dec ' ' ++ desc ++ " OK" + showRes' dec (SingleTestR desc (Left err)) = replicate dec ' ' ++ desc ++ " FAIL: " ++ err + +testFileSources :: String -> FinalCatalog -> Test +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] + 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 () + genFileTest :: ResolvedValue -> Test + genFileTest (ResolvedString src) = SingleTest (src ++ " exists") (checkSrcExists src) + genFileTest (ResolvedArray arr) = TestFirstOk "First exists" (map genFileTest arr) + genFileTest x = SingleTest ("Valid source") (\_ -> return $ Left ("Not a valid data type: " ++ show x)) + in (TestGroup "check that all files are defined" (map genFileTest filesources)) + +unsingle :: TestR -> Either String () +unsingle (SingleTestR desc (Left err)) = Left (desc ++ " failed: " ++ err) +unsingle (SingleTestR _ _ ) = Right () +unsingle x = Left ("Bad type for unsingle " ++ show x) + +runTest :: FinalCatalog -> Test -> IO TestR +runTest cat (SingleTest desc test) = fmap (\x -> SingleTestR desc x) (test cat) +runTest cat (TestGroup desc tests) = fmap (TestGroupR desc) (mapM (runTest cat) tests) +runTest cat (TestFirstOk desc tests) = do + allRes <- mapM (fmap unsingle . runTest cat) tests + case lefts allRes of + [] -> return $ SingleTestR desc (Right ()) + x -> return $ SingleTestR desc (Left (show x)) + +runTests :: Test -> FinalCatalog -> IO (Either String ()) +runTests tsts cat = do + tr <- fmap failedTests (runTest cat tsts) + case tr of + Nothing -> return $ Right () + Just fl -> return $ Left $ showRes fl + +testCatalog :: String -> FinalCatalog -> [Test] -> IO (Either String ()) +testCatalog puppetdir catalog stests = runTests (TestGroup "All Tests" ( testFileSources puppetdir catalog : stests )) catalog 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 +Version: 0.2.0.1 -- A short (one-line) description of the package. Synopsis: Tools to parse and evaluate the Puppet DSL. @@ -30,6 +30,7 @@ Homepage: http://lpuppet.banquise.net + -- A copyright notice. -- Copyright: @@ -47,15 +48,27 @@ Data-Files: ruby/calcerb.rb +source-repository head + type: git + location: git://github.com/bartavelle/language-puppet.git + Library ghc-options: -Wall -fno-warn-missing-signatures -fno-warn-unused-do-bind -funbox-strict-fields -- Modules exported by the library. Exposed-modules: Puppet.DSL.Parser, Puppet.DSL.Printer, Puppet.Daemon, Puppet.Init, Puppet.DSL.Loader, Puppet.Printers, Puppet.NativeTypes, Puppet.DSL.Types, - Puppet.Interpreter.Types, Puppet.Interpreter.Catalog, Puppet.NativeTypes.Helpers, PuppetDB.Rest, PuppetDB.Query, Puppet.Plugins + Puppet.Interpreter.Types, Puppet.Interpreter.Catalog, Puppet.NativeTypes.Helpers, PuppetDB.Rest, PuppetDB.Query, Puppet.Plugins, Puppet.Testing -- Packages needed in order to build this package. - Build-depends: base >=3 && <5,parsec,MissingH,containers,pretty,mtl,unix,hslogger,filepath,Glob,regexpr,process,bytestring,cryptohash,base16-bytestring,regex-pcre-builtin, - iconv, text, unordered-containers, aeson, vector, http-types, http-conduit, attoparsec, failure, hslua, monad-loops, directory, luautils, transformers + Build-depends: base >=3 && <5, + 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 -- 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