language-puppet 0.2.0 → 0.2.0.1
raw patch · 5 files changed
+133/−34 lines, 5 filesdep ~MissingHdep ~containersdep ~luautils
Dependency ranges changed: MissingH, containers, luautils, mtl, parsec
Files
- Puppet/Interpreter/Catalog.hs +25/−7
- Puppet/Interpreter/Types.hs +4/−1
- Puppet/Plugins.hs +0/−22
- Puppet/Testing.hs +87/−0
- language-puppet.cabal +17/−4
Puppet/Interpreter/Catalog.hs view
@@ -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 []
Puppet/Interpreter/Types.hs view
@@ -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
Puppet/Plugins.hs view
@@ -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)
+ Puppet/Testing.hs view
@@ -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
language-puppet.cabal view
@@ -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