diff --git a/Puppet/DSL/Types.hs b/Puppet/DSL/Types.hs --- a/Puppet/DSL/Types.hs +++ b/Puppet/DSL/Types.hs @@ -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 + + diff --git a/Puppet/Interpreter/Catalog.hs b/Puppet/Interpreter/Catalog.hs --- a/Puppet/Interpreter/Catalog.hs +++ b/Puppet/Interpreter/Catalog.hs @@ -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 diff --git a/Puppet/Interpreter/Functions.hs b/Puppet/Interpreter/Functions.hs --- a/Puppet/Interpreter/Functions.hs +++ b/Puppet/Interpreter/Functions.hs @@ -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 diff --git a/Puppet/Interpreter/Types.hs b/Puppet/Interpreter/Types.hs --- a/Puppet/Interpreter/Types.hs +++ b/Puppet/Interpreter/Types.hs @@ -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 } diff --git a/Puppet/JsonCatalog.hs b/Puppet/JsonCatalog.hs new file mode 100644 --- /dev/null +++ b/Puppet/JsonCatalog.hs @@ -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) diff --git a/Puppet/NativeTypes/File.hs b/Puppet/NativeTypes/File.hs --- a/Puppet/NativeTypes/File.hs +++ b/Puppet/NativeTypes/File.hs @@ -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 diff --git a/Puppet/Printers.hs b/Puppet/Printers.hs --- a/Puppet/Printers.hs +++ b/Puppet/Printers.hs @@ -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 diff --git a/PuppetDB/Query.hs b/PuppetDB/Query.hs --- a/PuppetDB/Query.hs +++ b/PuppetDB/Query.hs @@ -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" ] ] 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.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,