language-puppet 0.3.0.0 → 0.3.1.0
raw patch · 9 files changed
+140/−52 lines, 9 files
Files
- Puppet/DSL/Types.hs +14/−0
- Puppet/Interpreter/Catalog.hs +24/−31
- Puppet/Interpreter/Functions.hs +3/−1
- Puppet/Interpreter/Types.hs +1/−1
- Puppet/JsonCatalog.hs +71/−0
- Puppet/NativeTypes/File.hs +16/−3
- Puppet/Printers.hs +4/−1
- PuppetDB/Query.hs +5/−13
- language-puppet.cabal +2/−2
Puppet/DSL/Types.hs view
@@ -3,7 +3,11 @@ module Puppet.DSL.Types where import Text.Parsec.Pos+import Data.List (intercalate)+import Data.Char (toUpper)+import Data.String.Utils (split) + data Parameters = Parameters ![(Expression, Expression)] deriving(Show, Ord, Eq) -- |This type is used to differenciate the distinct top level types that are@@ -139,3 +143,13 @@ | BFalse -- ^ False expression | Error !String -- ^ Not used anymore. deriving(Show, Ord, Eq)++-- function that capitalizes types so that they look good+capitalizeResType :: String -> String+capitalizeResType = intercalate "::" . map capitalize' . split "::"++capitalize' :: String -> String+capitalize' "" = ""+capitalize' (x:xs) = toUpper x : xs++
Puppet/Interpreter/Catalog.hs view
@@ -41,6 +41,7 @@ import qualified PuppetDB.Query as PDB import System.IO.Unsafe+import Control.Arrow (first) import Data.List import Data.Char (isDigit,toLower,toUpper, isAlpha, isAlphaNum, isSpace) import Data.Maybe (isJust, fromJust, catMaybes, isNothing)@@ -111,7 +112,7 @@ , luaState = luastate , userFunctions = Set.fromList userfunctions , nativeTypes = ntypes- , definedResources = Map.empty+ , definedResources = Map.singleton ("node",nodename) (newPos "site.pp" 0 0) , currentDependencyStack = [("node",nodename)] } ) case luastate of@@ -142,7 +143,7 @@ -- it should only be called with native types or the validatefunction lookup with abord with an error finalizeResource :: CResource -> CatalogMonad (ResIdentifier, RResource) finalizeResource cr = do- ((_, rname), prefinalresource) <- resolveResource cr+ ((_, rname), prefinalresource) <- extractRelations cr >>= resolveResource let ctype = rrtype prefinalresource cpos = rrpos prefinalresource ntypes <- fmap nativeTypes get@@ -238,7 +239,8 @@ RNotify -> return $ Just (dst, src, (RSubscribe, lutype,lpos)) RBefore -> return $ Just (dst, src, (RRequire , lutype,lpos)) _ -> return (Just o)- _ -> throwError $ "Unknown resource " ++ show dst ++ " used at " ++ show lpos ++ " debug: " ++ show (Map.member src drs, Map.member dst drs, Map.member src exported, Map.member dst exported)+ (False, _, _, _) -> throwError $ "Unknown resources " ++ show src ++ " used in a relation at " ++ show lpos ++ " debug: " ++ show (Map.member src drs, Map.member dst drs, Map.member src exported, Map.member dst exported)+ (_, False, _, _) -> throwError $ "Unknown resources " ++ show dst ++ " used in a relation at " ++ show lpos ++ " debug: " ++ show (Map.member src drs, Map.member dst drs, Map.member src exported, Map.member dst exported) -- now look for cycles in the graph checkedrels <- fmap catMaybes $ mapM checkRelationExists rels let !edgeMap = Map.fromList (map (\(d,s,i) -> ((s,d),i)) checkedrels) :: EdgeMap -- warning, in the edgemap we have (src, dst), contrary to all other uses@@ -443,32 +445,24 @@ 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- srname <- resolveGeneralString rname- let (nparams, nrelations) = mergeParams rparams rdefs False+applyDefaults' r@(CResource i rname rtype rparams rvirtuality rpos) (RDefaults dtype rdefs _) = do+ let nparams = mergeParams rparams rdefs False if dtype == rtype- then do- addUnresRel (nrelations, (rtype, Right srname), UDefault, dpos)- return $ CResource i rname rtype nparams rvirtuality rpos+ then return $ CResource i rname rtype nparams rvirtuality rpos else return r-applyDefaults' r@(CResource i rname rtype rparams rvirtuality rpos) (ROverride dtype dname rdefs dpos) = do+applyDefaults' r@(CResource i rname rtype rparams rvirtuality rpos) (ROverride dtype dname rdefs _) = do srname <- resolveGeneralString rname sdname <- resolveGeneralString dname- let (nparams, nrelations) = mergeParams rparams rdefs True+ let nparams = mergeParams rparams rdefs True if (dtype == rtype) && (srname == sdname)- then do- addUnresRel (nrelations, (rtype, Right srname), UDefault, dpos)- return $ CResource i rname rtype nparams rvirtuality rpos+ then return $ CResource i rname rtype nparams rvirtuality rpos else return r -- merge defaults and actual parameters depending on the override flag-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.union dstprm srcprm- else Map.union srcprm dstprm- in (prm, dstrels)+mergeParams :: Map.Map GeneralString GeneralValue -> Map.Map GeneralString GeneralValue -> Bool -> Map.Map GeneralString GeneralValue+mergeParams srcprm defs override = if override+ then Map.union defs srcprm+ else Map.union srcprm defs -- The actual meat @@ -528,12 +522,10 @@ getPos >>= addDefinedResource (rtype, rse) return $ Right rse Left e -> return $ Left e- let (realparams, relations) = partitionParamsRelations rparameters- -- push all the relations (curdeptype, curdepname) <- fmap (head . currentDependencyStack) get let defaultdependency = (RRequire, Right (ResolvedString curdeptype), Right (ResolvedString curdepname))- addUnresRel (defaultdependency : relations, (rtype, srname), UNormal, position)- return [CResource resid srname rtype realparams virtuality position]+ addUnresRel ([defaultdependency], (rtype, srname), UNormal, position)+ return [CResource resid srname rtype rparameters virtuality position] -- node evaluateStatements :: Statement -> CatalogMonad Catalog@@ -623,7 +615,7 @@ 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 ()+loadClassVariable :: SourcePos -> Map.Map String (GeneralValue, SourcePos) -> (String, Maybe Expression) -> CatalogMonad (String, GeneralValue) loadClassVariable position inputs (paramname, defvalue) = do let inputvalue = Map.lookup paramname inputs (v, vpos) <- case (inputvalue, defvalue) of@@ -632,7 +624,7 @@ (Nothing, Nothing) -> throwError $ "Must define parameter " ++ paramname ++ " at " ++ show position rv <- tryResolveGeneralValue v putVariable paramname (rv, vpos)- return ()+ return (paramname, rv) -- class -- ClassDeclaration String (Maybe String) [(String, Maybe Expression)] [Statement] SourcePos@@ -646,20 +638,21 @@ then return [] else do oldpos <- getPos -- saves where we were at class declaration so that we known were the class was included- addDefinedResource ("class",classname) oldpos+ addDefinedResource ("class", classname) oldpos -- detection of spurious parameters let classparamset = Set.fromList $ map fst parameters inputparamset = Set.filter (\x -> getRelationParameterType (Right x) == Nothing) $ Map.keysSet inputparams overparams = Set.difference inputparamset (Set.union metaparameters classparamset)+ -- to insert into the final resource unless (Set.null overparams) (throwError $ "Spurious parameters " ++ intercalate ", " (Set.toList overparams) ++ " at " ++ show position) resid <- getNextId -- get this resource id, for the dummy class that will be used to handle relations setPos position- pushDependency ("class",classname)+ pushDependency ("class", classname) case actualname of Nothing -> pushScope [classname] -- sets the scope Just ac -> pushScope [classname, ac]- mapM_ (loadClassVariable position inputparams) parameters -- add variables for parametrized classes+ mparameters <- mapM (loadClassVariable position inputparams) parameters -- add variables for parametrized classes -- load inherited classes inherited <- case inherits of@@ -683,7 +676,7 @@ popScope popDependency return $- [CResource resid (Right classname) "class" Map.empty Normal position]+ [CResource resid (Right classname) "class" (Map.fromList $ map (first Right) mparameters) Normal position] ++ inherited ++ nres
Puppet/Interpreter/Functions.hs view
@@ -29,9 +29,11 @@ import Data.Either (lefts, rights) import Data.List (intercalate) import qualified Data.ByteString.Lazy.Char8 as BSL+import Data.Char (toUpper) puppetMD5 = md5s . Str puppetSHA1 = BS.unpack . B16.encode . SHA1.hash . BS.pack+puppetMysql = BS.unpack . B16.encode . SHA1.hash . SHA1.hash . BS.pack {- TODO : achieve compatibility with puppet@@ -46,7 +48,7 @@ mysql_password :: String -> CatalogMonad String mysql_password pwd = return $ '*':hash where- hash = puppetSHA1 pwd+ hash = map toUpper $ puppetMysql pwd regsubst :: String -> String -> String -> String -> CatalogMonad String regsubst str src dst flags = do
Puppet/Interpreter/Types.hs view
@@ -174,7 +174,7 @@ generalizeStringS = Right -- |This is the set of meta parameters-metaparameters = Set.fromList ["tag","stage","name","title","alias","audit","check","loglevel","noop","schedule", "EXPORTEDSOURCE"]+metaparameters = Set.fromList ["tag","stage","name","title","alias","audit","check","loglevel","noop","schedule", "EXPORTEDSOURCE", "require", "before", "register", "notify"] getPos = liftM curPos get modifyScope f sc = sc { curScope = f $ curScope sc }
+ Puppet/JsonCatalog.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE OverloadedStrings #-}+module Puppet.JsonCatalog where++import Puppet.DSL.Types hiding (Value)+import Puppet.Interpreter.Types+import Puppet.Printers++import qualified Data.Text as T+import qualified Data.HashMap.Strict as HM+import qualified Data.Map as Map+import Data.Aeson+import qualified Data.Vector as V+import Data.Attoparsec.Number+import Text.Parsec.Pos+import qualified Data.ByteString.Lazy as BSL++prref = String . T.pack . showRRef++mkJsonCatalog :: T.Text -> Integer -> FinalCatalog -> FinalCatalog -> EdgeMap -> Value+mkJsonCatalog nodename version cat exports edges = Object $ HM.fromList [("data",datahash), ("document_type", String "Catalog"), ("metadata", Object (HM.fromList [("api_version", Number 1)]))]+ where+ datahash = Object $ HM.fromList [ ("classes" , Array (V.fromList classes))+ , ("edges" , Array (V.fromList ledges))+ , ("environment", String "production")+ , ("name" , String nodename)+ , ("resources" , Array (V.fromList resources))+ , ("tags" , Array V.empty)+ , ("version" , Number (I version))+ ]+ lcat = Map.toList cat+ classes = map (String . T.pack . snd . fst) . filter (\((k,_),_) -> k == "class") $ lcat+ --notcatalog = map fakeResource $ nubBy (\(a,_) (b,_) -> a == b) . filter (\(x,_) -> not (Map.member x cat)) . concatMap (\((a,b),(_,_,c)) -> [(a,c),(b,c)]) . Map.toList $ edges+ ledges = map (\(s,d) -> Object $ HM.fromList [("source", prref s),("target", prref d)] ) . filter (\i -> Map.member (fst i) cat && Map.member (snd i) cat) . Map.keys $ edges+ resources = map (res2JSon False . snd) lcat++fakeResource :: (ResIdentifier, SourcePos) -> RResource+fakeResource ((t,n),p) = RResource 0 n t Map.empty [] p++-- stuff that is done+-- * the EXPORTEDSOURCE is added for resources coming from PuppetDB+res2JSon :: Bool -> RResource -> Value+res2JSon isExported (RResource _ rn rt rp _ rpos) = Object $ HM.fromList [ ("exported", Bool isExported)+ , ("file", String (T.pack (sourceName rpos)))+ , ("line", Number (fromIntegral (sourceLine rpos)))+ , ("parameters", Object (HM.delete "EXPORTEDSOURCE" $ HM.fromList paramlist))+ , ("tags", Array V.empty)+ , ("title", String (T.pack realtitle))+ , ("type", String . T.pack . capitalizeResType $ rt)+ ]+ where+ -- in puppet class titles are capitalized ...+ realtitle = if rt == "class"+ then capitalizeResType ctitle+ else ctitle+ ctitle = case Map.lookup "title" rp of+ Just (ResolvedString s) -> s+ _ -> rn+ paramlist = map (\(k,v) -> (T.pack k, rv2json v)) $ Map.toList $ Map.delete "title" rp++rv2json :: ResolvedValue -> Value+rv2json (ResolvedString x) = String (T.pack x)+rv2json (ResolvedRegexp x) = String (T.pack x)+rv2json (ResolvedInt x) = Number (I x)+rv2json (ResolvedDouble x) = Number (D x)+rv2json (ResolvedBool x) = Bool x+rv2json (ResolvedArray h) = Array (V.fromList (map rv2json h))+rv2json (ResolvedHash h) = Object $ HM.fromList $ map (\(k,v) -> (T.pack k, rv2json v)) h+rv2json _ = Null++catalog2JSon :: String -> Integer -> FinalCatalog -> FinalCatalog -> EdgeMap -> BSL.ByteString+catalog2JSon nodename version dc de dm = encode (mkJsonCatalog (T.pack nodename) version dc de dm)
Puppet/NativeTypes/File.hs view
@@ -5,12 +5,13 @@ import Puppet.Interpreter.Types import qualified Data.Map as Map import qualified Data.Set as Set+import Data.Char (isDigit) nativeFile = ("file", PuppetTypeMethods validateFile parameterset) -- Autorequires: If Puppet is managing the user or group that owns a file, the file resource will autorequire them. If Puppet is managing any parent directories of a file, the file resource will autorequire them. parameterset = Set.fromList $ map fst parameterfunctions-parameterfunctions = +parameterfunctions = [("backup" , [string]) ,("checksum" , [values ["md5", "md5lite", "mtime", "ctime", "none"]]) ,("content" , [string])@@ -20,7 +21,7 @@ ,("group" , [defaultvalue "root", string]) ,("ignore" , [string]) ,("links" , [string])- ,("mode" , [integer])+ ,("mode" , [defaultvalue "0644", string]) ,("owner" , [string]) ,("path" , [nameval, fullyQualified]) ,("provider" , [values ["posix","windows"]])@@ -34,7 +35,19 @@ ] validateFile :: PuppetTypeValidate-validateFile = defaultValidate parameterset >=> parameterFunctions parameterfunctions >=> validateSourceOrContent+validateFile = defaultValidate parameterset >=> parameterFunctions parameterfunctions >=> validateSourceOrContent >=> validateMode++validateMode :: PuppetTypeValidate+validateMode res = let+ modestr = case ((rrparams res) Map.! "mode") of+ ResolvedString s -> s+ _ -> "0644"+ in do+ when ((length modestr /= 3) && (length modestr /= 4)) (throwError "Invalid mode size")+ when (not (all isDigit modestr)) (throwError "The mode should only be made of digits")+ if length modestr == 3+ then return $ insertparam res "mode" (ResolvedString ('0':modestr))+ else return res validateSourceOrContent :: PuppetTypeValidate validateSourceOrContent res = let
Puppet/Printers.hs view
@@ -4,9 +4,11 @@ , showFCatalog , showValue , showRRef+ , capitalizeResType ) where import Puppet.Interpreter.Types+import Puppet.DSL.Types import qualified Data.Map as Map import Data.List @@ -28,7 +30,8 @@ commaretsep = intercalate ",\n" showRRef :: ResIdentifier -> String-showRRef (rt, rn) = rt ++ "[" ++ rn ++ "]"+showRRef (rt, rn) = capitalizeResType rt ++ "[" ++ rn ++ "]"+ showValue :: ResolvedValue -> String showValue (ResolvedString x) = show x
PuppetDB/Query.hs view
@@ -1,8 +1,7 @@ module PuppetDB.Query where +import Puppet.DSL.Types import Data.List (intercalate)-import Data.Char (toUpper)-import Data.String.Utils (split) data Operator = OEqual | OOver | OUnder | OOverE | OUnderE | OAnd | OOr | ONot deriving (Show, Ord, Eq)@@ -11,31 +10,24 @@ data Query = Query Operator [Query] | Term String | Terms [String] deriving (Show, Ord, Eq) -capitalize :: String -> String-capitalize = intercalate "::" . map capitalize' . split "::"--capitalize' :: String -> String-capitalize' "" = ""-capitalize' (x:xs) = toUpper x : xs- -- | Query used for realizing a resources, when its type and title is known. queryRealize :: String -> String -> Query queryRealize rtype rtitle = Query OAnd- [ Query OEqual [ Term "type", Term (capitalize rtype) ]+ [ Query OEqual [ Term "type", Term (capitalizeResType rtype) ] , Query OEqual [ Term "title", Term rtitle ] , Query OEqual [ Term "exported", Term "true" ] ] -- | Collects all resources of a given type collectAll :: String -> Query-collectAll rtype = Query OAnd [ Query OEqual [ Term "type", Term (capitalize rtype) ]+collectAll rtype = Query OAnd [ Query OEqual [ Term "type", Term (capitalizeResType rtype) ] , Query OEqual [ Term "exported", Term "true" ] ] -- | Collections based on tags. collectTag :: String -> String -> Query collectTag rtype tagval = Query OAnd- [ Query OEqual [ Term "type", Term (capitalize rtype) ]+ [ Query OEqual [ Term "type", Term (capitalizeResType rtype) ] , Query OEqual [ Term "tag" , Term tagval ] , Query OEqual [ Term "exported", Term "true" ] ]@@ -43,7 +35,7 @@ -- | Used to emulate collections such as `Type<|| prmname == "prmval" ||>` collectParam :: String -> String -> String -> Query collectParam rtype prmname prmval = Query OAnd- [ Query OEqual [ Term "type", Term (capitalize rtype) ]+ [ Query OEqual [ Term "type", Term (capitalizeResType rtype) ] , Query OEqual [ Terms ["parameter", "prmname"], Term prmval ] , Query OEqual [ Term "exported", Term "true" ] ]
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.3.0.0+Version: 0.3.1.0 -- A short (one-line) description of the package. Synopsis: Tools to parse and evaluate the Puppet DSL.@@ -56,7 +56,7 @@ -- 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.Stats+ Puppet.Stats, Puppet.JsonCatalog -- 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>=0.10.2.0,cryptohash,base16-bytestring,regex-pcre-builtin,