language-puppet 0.10.5 → 0.10.6
raw patch · 16 files changed
+471/−161 lines, 16 filesdep +parallel-iodep +splitdep ~pcre-utils
Dependencies added: parallel-io, split
Dependency ranges changed: pcre-utils
Files
- Facter.hs +45/−21
- Hiera/Server.hs +1/−0
- Puppet/Interpreter.hs +53/−30
- Puppet/Interpreter/Resolve.hs +35/−50
- Puppet/Interpreter/Types.hs +16/−0
- Puppet/Lens.hs +188/−0
- Puppet/NativeTypes/File.hs +1/−1
- Puppet/PP.hs +13/−0
- Puppet/Parser.hs +10/−5
- Puppet/Preferences.hs +1/−1
- Puppet/Stdlib.hs +17/−8
- Puppet/Testing.hs +11/−1
- PuppetDB/TestDB.hs +8/−4
- language-puppet.cabal +6/−4
- progs/PuppetResources.hs +63/−35
- progs/pdbQuery.hs +3/−1
Facter.hs view
@@ -6,11 +6,15 @@ import qualified Data.HashSet as HS import qualified Data.HashMap.Strict as HM import Puppet.Interpreter.Types-import System.Info import qualified Data.Text as T import Control.Arrow import qualified Data.Either.Strict as S import Control.Lens+import System.Posix.User+import System.Posix.Unistd (getSystemID, SystemID(..))+import Data.List.Split (splitOn)+import Data.List (intercalate)+import System.Environment storageunits :: [(String, Int)] storageunits = [ ("", 0), ("K", 1), ("M", 2), ("G", 3), ("T", 4) ]@@ -57,30 +61,26 @@ factOS :: IO [(String, String)] factOS = do lsb <- fmap (map (break (== '=')) . lines) (readFile "/etc/lsb-release")- hostname <- fmap (head . lines) (readFile "/proc/sys/kernel/hostname")- let getval st | null filtered = "?"+ let getval st | null filterd = "?" | otherwise = rvalue- where filtered = filter (\(k,_) -> k == st) lsb- value = (tail . snd . head) filtered+ where filterd = filter (\(k,_) -> k == st) lsb+ value = (tail . snd . head) filterd rvalue | head value == '"' = read value | otherwise = value- release = getval "DISTRIB_RELEASE"+ lrelease = getval "DISTRIB_RELEASE" distid = getval "DISTRIB_ID"- maj | release == "?" = "?"- | otherwise = fst $ break (== '.') release+ maj | lrelease == "?" = "?"+ | otherwise = fst $ break (== '.') lrelease osfam | distid == "Ubuntu" = "Debian" | otherwise = distid return [ ("lsbdistid" , distid) , ("operatingsystem" , distid)- , ("lsbdistrelease" , release)- , ("operatingsystemrelease" , release)+ , ("lsbdistrelease" , lrelease)+ , ("operatingsystemrelease" , lrelease) , ("lsbmajdistrelease" , maj) , ("osfamily" , osfam)- , ("hostname" , hostname) , ("lsbdistcodename" , getval "DISTRIB_CODENAME") , ("lsbdistdescription" , getval "DISTRIB_DESCRIPTION")- , ("hardwaremodel" , arch)- , ("architecture" , arch) ] factMountPoints :: IO [(String, String)]@@ -97,29 +97,53 @@ goodfs = map (!! 1) goodlines return [("mountpoints", unwords goodfs)] -version :: IO [(String, String)]-version = return [("facterversion", "0.1"),("environment","test")]+fversion :: IO [(String, String)]+fversion = return [("facterversion", "0.1"),("environment","test")] +factUser :: IO [(String, String)]+factUser = do+ username <- getLoginName+ return [("id",username)]++factUName :: IO [(String, String)]+factUName = do+ SystemID sn nn rl _ mc <- getSystemID+ let vparts = splitOn "." (takeWhile (/='-') rl)+ return [ ("kernel" , sn) -- Linux+ , ("kernelmajversion" , intercalate "." (take 2 vparts)) -- 3.5+ , ("kernelrelease" , rl) -- 3.5.0-45-generic+ , ("kernelversion" , intercalate "." (take 3 vparts)) -- 3.5.0+ , ("hardwareisa" , mc) -- x86_64+ , ("hardwaremodel" , mc) -- x86_64+ , ("hostname" , nn)+ ]++fenv :: IO [(String,String)]+fenv = do+ path <- getEnv "PATH"+ return [ ("path", path) ]+ puppetDBFacts :: T.Text -> PuppetDBAPI -> IO (Container T.Text)-puppetDBFacts nodename pdbapi =- getFacts pdbapi (QEqual FCertname nodename) >>= \case+puppetDBFacts ndename pdbapi =+ getFacts pdbapi (QEqual FCertname ndename) >>= \case S.Right facts@(_:_) -> return (HM.fromList (map (\f -> (f ^. factname, f ^. factval)) facts)) _ -> do- rawFacts <- fmap concat (sequence [factNET, factRAM, factOS, version, factMountPoints, factOS])+ rawFacts <- fmap concat (sequence [factNET, factRAM, factOS, fversion, factMountPoints, factOS, factUser, factUName, fenv]) let ofacts = genFacts $ map (T.pack *** T.pack) rawFacts- (hostname, ddomainname) = T.break (== '.') nodename+ (hostname, ddomainname) = T.break (== '.') ndename domainname = if T.null ddomainname then "" else T.tail ddomainname- nfacts = genFacts [ ("fqdn", nodename)+ nfacts = genFacts [ ("fqdn", ndename) , ("hostname", hostname) , ("domain", domainname) , ("rootrsa", "xxx") , ("operatingsystem", "Ubuntu") , ("puppetversion", "language-puppet") , ("virtual", "xenu")- , ("clientcert", nodename)+ , ("clientcert", ndename) , ("is_virtual", "true")+ , ("concat_basedir", "/var/lib/puppet/concat") ] allfacts = nfacts `HM.union` ofacts genFacts = HM.fromList
Hiera/Server.hs view
@@ -23,6 +23,7 @@ import Control.Applicative import Control.Lens import Control.Lens.Aeson+import Puppet.Lens import System.FilePath.Lens (directory) import Control.Exception
Puppet/Interpreter.hs view
@@ -158,7 +158,8 @@ -- replace the modified stuff let res = foldl' (\curm e -> curm & at (e ^. rid) ?~ e) realized refinalized return (toList res)- resnode <- evaluateNode node >>= finalStep . (++ restop)+ mainstage = Resource (RIdentifier "stage" "main") mempty mempty mempty [ContRoot] Normal mempty (initialPPos "dummy") ndename+ resnode <- evaluateNode node >>= finalStep . (++ (mainstage : restop)) let (real :!: exported) = foldl' classify (mempty :!: mempty) resnode classify (curr :!: cure) r = let i curm = curm & at (r ^. rid) ?~ r@@ -337,7 +338,7 @@ . filter ((/= fqdn) . _rnode) ) `fmap` interpreterIO (getResources pdb q) scpdesc <- ContImported `fmap` getScope- void $ enterScope S.Nothing scpdesc+ void $ enterScope SENormal scpdesc "importing" p pushScope scpdesc o <- finalize res popScope@@ -478,15 +479,28 @@ S.Just e -> resolveExpression e loadVariable k rv +data ScopeEnteringContext = SENormal+ | SEChild !T.Text -- ^ We enter the scope as the child of another class+ | SEParent !T.Text -- ^ We enter the scope as the parent of another class+ -- | Enters a new scope, checks it is not already defined, and inherits the -- defaults from the current scope -- -- Inheriting the defaults is necessary for non native types, because they -- will be expanded in "finalize", so if this was not done, we would be -- expanding the defines without the defaults applied-enterScope :: S.Maybe T.Text -> CurContainerDesc -> InterpreterMonad T.Text-enterScope parent cont = do+enterScope :: ScopeEnteringContext+ -> CurContainerDesc+ -> T.Text+ -> PPosition+ -> InterpreterMonad T.Text+enterScope secontext cont modulename p = do let scopename = scopeName cont+ -- | This is a special hack for inheritance, because at this time we+ -- have not properly stacked the scopes.+ curcaller <- case secontext of+ SEParent l -> return (PString $ T.takeWhile (/=':') l)+ _ -> resolveVariable "module_name" scopeAlreadyDefined <- use (scopes . contains scopename) let isImported = case cont of ContImported _ -> True@@ -496,16 +510,19 @@ when scopeAlreadyDefined (throwPosError ("Internal error: scope" <+> brackets (ttext scopename) <+> "already defined when loading scope for" <+> pretty cont)) scp <- getScopeName -- TODO fill tags- basescope <- case parent of- S.Nothing -> do- curdefs <- use (scopes . ix scp . scopeDefaults)- return $ ScopeInformation mempty curdefs mempty (CurContainer cont mempty) mempty parent- S.Just p -> do- parentscope <- use (scopes . at p)- when (isNothing parentscope) (throwPosError ("Internal error: could not find parent scope" <+> ttext p))+ basescope <- case secontext of+ SEChild prt -> do+ parentscope <- use (scopes . at prt)+ when (isNothing parentscope) (throwPosError ("Internal error: could not find parent scope" <+> ttext prt)) let Just psc = parentscope- return (psc & scopeParent .~ parent)+ return (psc & scopeParent .~ S.Just prt)+ _ -> do+ curdefs <- use (scopes . ix scp . scopeDefaults)+ return $ ScopeInformation mempty curdefs mempty (CurContainer cont mempty) mempty S.Nothing scopes . at scopename ?= basescope+ scopes . ix scopename . scopeVariables . at "caller_module_name" ?= (curcaller :!: p :!: cont)+ scopes . ix "::" . scopeVariables . at "calling_module" ?= (curcaller :!: p :!: cont) -- hiera compatibility :(+ scopes . ix scopename . scopeVariables . at "module_name" ?= (PString modulename :!: p :!: cont) return scopename dropInitialColons :: T.Text -> T.Text@@ -518,16 +535,15 @@ modulename = case T.splitOn "::" deftype of [] -> deftype (x:_) -> x- curcaller <- resolveVariable "module_name" let curContType = ContDefine deftype defname- scopename <- enterScope S.Nothing curContType+ p <- use curPos+ void $ enterScope SENormal curContType modulename p (spurious, dls) <- getstt TopDefine deftype let isImported (ContImported _) = True isImported _ = False isImportedDefine <- isImported `fmap` getScope case dls of (DefineDeclaration _ defineParams stmts cp) -> do- p <- use curPos curPos .= r ^. rpos curscp <- getScope when isImportedDefine (pushScope (ContImport (r ^. rnode) curscp ))@@ -536,8 +552,6 @@ loadVariable "name" (PString defname) -- not done through loadvariable because of override -- errors- scopes . ix scopename . scopeVariables . at "module_name" ?= (PString modulename :!: p :!: curContType)- scopes . ix scopename . scopeVariables . at "callermodule_name" ?= (curcaller :!: p :!: curContType) loadParameters (r ^. rattributes) defineParams cp S.Nothing curPos .= cp res <- evaluateStatementsVector stmts@@ -549,17 +563,21 @@ loadClass :: T.Text+ -> S.Maybe T.Text -- ^ Set if this is an inheritance load, so that we can set calling module properly -> Container PValue -> ClassIncludeType -> InterpreterMonad [Resource]-loadClass rclassname params cincludetype = do+loadClass rclassname loadedfrom params cincludetype = do let classname = dropInitialColons rclassname p <- use curPos -- check if the class has already been loaded -- http://docs.puppetlabs.com/puppet/3/reference/lang_classes.html#using-resource-like-declarations use (loadedClasses . at classname) >>= \case- Just (_ :!: pp) -> do- when (cincludetype == IncludeResource) (throwPosError ("Can't include class" <+> ttext classname <+> "twice when using the resource-like syntax (first occurence at" <+> showPPos pp <> ")"))+ Just (prv :!: pp) -> do+ when ( (cincludetype == IncludeResource)+ || (prv == IncludeResource)+ )+ (throwPosError ("Can't include class" <+> ttext classname <+> "twice when using the resource-like syntax (first occurence at" <+> showPPos pp <> ")")) return [] -- already loaded, go on Nothing -> do@@ -572,10 +590,17 @@ -- check if we need to define a resource representing the class -- This will be the case for the first standard include inhstmts <- case inh of- S.Nothing -> return []- S.Just ihname -> loadClass ihname mempty IncludeResource+ S.Nothing -> return []+ S.Just ihname -> loadClass ihname (S.Just classname) mempty IncludeStandard let !scopedesc = ContClass classname- scopename <- enterScope inh scopedesc+ modulename = case T.splitOn "::" classname of+ [] -> classname+ (x:_) -> x+ secontext = case (inh, loadedfrom) of+ (S.Just x,_) -> SEChild x+ (_,S.Just x) -> SEParent x+ _ -> SENormal+ void $ enterScope secontext scopedesc modulename p classresource <- if cincludetype == IncludeStandard then do scp <- use curScope@@ -583,13 +608,8 @@ return [Resource (RIdentifier "class" classname) (HS.singleton classname) mempty mempty scp Normal mempty p fqdn] else return [] pushScope scopedesc- let modulename = case T.splitOn "::" classname of- [] -> classname- (x:_) -> x -- not done through loadvariable because of override -- errors- scopes . ix scopename . scopeVariables . at "module_name" ?= (PString modulename :!: p :!: ContClass classname)- scopes . ix "::" . scopeVariables . at "calling_module" ?= (PString modulename :!: p :!: ContClass classname) -- hiera compatibility :( loadParameters params classParams cp (S.Just classname) curPos .= cp res <- evaluateStatementsVector stmts@@ -663,7 +683,10 @@ case rt of "class" -> {-# SCC "rrClass" #-} do definedResources . at resid ?= r- fmap (r:) $ loadClass rn (r ^. rattributes) IncludeResource+ let attrs = r ^. rattributes+ fmap (r:) $ loadClass rn S.Nothing attrs $ if HM.null attrs+ then IncludeStandard+ else IncludeResource _ -> {-# SCC "rrGeneralCase" #-} use (definedResources . at resid) >>= \case Just otheres -> throwPosError ("Resource" <+> pretty resid <+> "already defined:" <$>@@ -699,7 +722,7 @@ mainFunctionCall "include" includes = fmap concat $ forM includes $ \e -> do classname <- resolvePValueString e- loadClass classname mempty IncludeStandard+ loadClass classname S.Nothing mempty IncludeStandard mainFunctionCall "create_resources" [rtype, hs] = mainFunctionCall "create_resources" [rtype, hs, PHash mempty] mainFunctionCall "create_resources" [PString rtype, PHash hs, PHash defs] = do p <- use curPos
Puppet/Interpreter/Resolve.hs view
@@ -3,10 +3,7 @@ -- the fully exploitable corresponding data type. The main use case is the -- conversion of 'Expression' to 'PValue'. module Puppet.Interpreter.Resolve- ( -- * Pure resolution functions and prisms- _PString,- _PInteger,- pvnum,+ ( -- * Pure resolution functions getVariable, pValue2Bool, -- * Monadic resolution functions@@ -33,7 +30,7 @@ import Puppet.Interpreter.Types import Puppet.Parser.Types import Puppet.Interpreter.PrettyPrinter()-import Puppet.Parser.PrettyPrinter()+import Puppet.Parser.PrettyPrinter(showPos) import Data.Version (parseVersion) import Text.ParserCombinators.ReadP (readP_to_S)@@ -52,8 +49,9 @@ import Control.Exception import Control.Monad import Control.Monad.Error-import Data.Tuple.Strict+import Data.Tuple.Strict as S import Control.Lens+import Control.Lens.Aeson hiding (key) import Data.Attoparsec.Number import Data.Attoparsec.Text import qualified Data.Either.Strict as S@@ -120,8 +118,8 @@ rb <- resolveExpression b case toNumbers ra rb of S.Nothing -> throwPosError ("Expected numbers, not" <+> pretty ra <+> "or" <+> pretty rb)- S.Just (S.Right (na :!: nb)) -> return (pvnum # D (opd na nb))- S.Just (S.Left (na :!: nb)) -> return (pvnum # I (opi na nb))+ S.Just (S.Right (na :!: nb)) -> return (_Double # opd na nb)+ S.Just (S.Left (na :!: nb)) -> return (_Integer # opi na nb) -- | Just like 'binaryOperation', but for operations that only work on -- integers.@@ -132,32 +130,7 @@ case toNumbers ra rb of S.Nothing -> throwPosError ("Expected numbers, not" <+> pretty ra <+> "or" <+> pretty rb) S.Just (S.Right _) -> throwPosError ("Expected integer values, not" <+> pretty ra <+> "or" <+> pretty rb)- S.Just (S.Left (na :!: nb)) -> return (pvnum # I (opr na nb))---- | A prism between 'PValue' and 'Number'-pvnum :: Prism' PValue Number-pvnum = prism num2PValue toNumber- where- num2PValue :: Number -> PValue- num2PValue (I x) = PString (T.pack (show x))- num2PValue (D x) = PString (T.pack (show x))- toNumber :: PValue -> Either PValue Number- toNumber p@(PString x) = case parseOnly number x of- Right y -> Right y- _ -> Left p- toNumber p = Left p---- | A prism between 'PValue' and 'T.Text'-_PString :: Prism' PValue T.Text-_PString = prism PString $ \x -> case x of- PString s -> Right s- n -> Left n---- | A prism between 'PValue' and 'Integer'-_PInteger :: Prism' PValue Integer-_PInteger = prism (PString . T.pack . show) $ \x -> case x ^? pvnum of- Just (I z) -> Right z- _ -> Left x+ S.Just (S.Left (na :!: nb)) -> return (_Integer # opr na nb) -- | Resolves a variable, or throws an error if it can't. resolveVariable :: T.Text -> InterpreterMonad PValue@@ -224,12 +197,18 @@ resolveExpression (Not e) = fmap (PBoolean . not . pValue2Bool) (resolveExpression e) resolveExpression (And a b) = do ra <- fmap pValue2Bool (resolveExpression a)- rb <- fmap pValue2Bool (resolveExpression b)- return (PBoolean (ra && rb))+ if ra+ then do+ rb <- fmap pValue2Bool (resolveExpression b)+ return (PBoolean (ra && rb))+ else return (PBoolean False) resolveExpression (Or a b) = do ra <- fmap pValue2Bool (resolveExpression a)- rb <- fmap pValue2Bool (resolveExpression b)- return (PBoolean (ra || rb))+ if ra+ then return (PBoolean True)+ else do+ rb <- fmap pValue2Bool (resolveExpression b)+ return (PBoolean (ra || rb)) resolveExpression (LessThan a b) = numberCompare a b (<) (<) resolveExpression (MoreThan a b) = numberCompare a b (>) (>) resolveExpression (LessEqualThan a b) = numberCompare a b (<=) (<=)@@ -270,8 +249,8 @@ Nothing -> throwPosError ("Can't find index '" <> ttext ridx <> "' in" <+> pretty (PHash h)) PArray ar -> do ridx <- resolveExpression idx- i <- case ridx ^? pvnum of- Just (I n) -> return (fromIntegral n)+ i <- case ridx ^? _Integer of+ Just n -> return (fromIntegral n) _ -> throwPosError ("Need an integral number for indexing an array, not" <+> pretty ridx) let arl = V.length ar if arl <= i@@ -315,7 +294,11 @@ resolveValue (UString x) = return (PString x) resolveValue UUndef = return PUndef resolveValue (UInterpolable vals) = fmap (PString . mconcat) (mapM resolveValueString (V.toList vals))-resolveValue (UResourceReference t e) = PResourceReference `fmap` pure t <*> resolveExpressionString e+resolveValue (UResourceReference t e) = do+ r <- resolveExpressionStrings e+ case r of+ [s] -> return (PResourceReference t s)+ _ -> return (PArray (V.fromList (map (\s -> PResourceReference t s) r))) resolveValue (UArray a) = fmap PArray (V.mapM resolveExpression a) resolveValue (UHash a) = fmap (PHash . HM.fromList) (mapM resPair (V.toList a)) where@@ -365,8 +348,8 @@ when (nbargs < 1 || nbargs > 2) (throwPosError "fqdn_rand(): Expects one or two arguments") fqdn <- resolveVariable "::fqdn" >>= resolvePValueString (mx:targs) <- mapM resolveExpressionString (V.toList args)- curmax <- case PString mx ^? pvnum of- Just (I x) -> return x+ curmax <- case PString mx ^? _Integer of+ Just x -> return x _ -> throwPosError ("fqdn_rand(): the first argument must be an integer, not" <+> ttext mx) let rargs = if null targs then [fqdn, ""]@@ -375,8 +358,11 @@ myhash = toint (MD5.hash (T.encodeUtf8 fullstring)) :: Integer toint = BS.foldl' (\c nx -> c*256 + fromIntegral nx) 0 fullstring = T.intercalate ":" rargs- return (pvnum # I val)-resolveFunction fname args = mapM resolveExpression (V.toList args) >>= resolveFunction' fname+ return (_Integer # val)+resolveFunction fname args = mapM resolveExpression (V.toList args) >>= resolveFunction' fname . map undefEmptyString+ where+ undefEmptyString PUndef = PString ""+ undefEmptyString x = x resolveFunction' :: T.Text -> [PValue] -> InterpreterMonad PValue resolveFunction' "defined" [PResourceReference rt rn] = fmap PBoolean (use (definedResources . contains (RIdentifier rt rn)))@@ -401,12 +387,12 @@ resolveFunction' "regsubst" [ptarget, pregexp, preplacement, pflags] = do -- TODO handle all the flags -- http://docs.puppetlabs.com/references/latest/function.html#regsubst- when (pflags /= "G") (throwPosError "regsubst(): Currently only supports a single flag (G)")+ when (pflags /= "G") (use curPos >>= \p -> warn ("regsubst(): Currently only supports a single flag (G) " <> showPos (S.fst p))) target <- fmap T.encodeUtf8 (resolvePValueString ptarget) regexp <- fmap T.encodeUtf8 (resolvePValueString pregexp) replacement <- fmap T.encodeUtf8 (resolvePValueString preplacement) liftIO (substituteCompile regexp target replacement) >>= \case- Left rr -> throwPosError ("regsubst():" <+> text rr)+ Left rr -> throwPosError ("regsubst" <> parens (pretty pregexp <> comma <> pretty preplacement) <> ":" <+> text rr) Right x -> fmap PString (safeDecodeUtf8 x) resolveFunction' "regsubst" _ = throwPosError "regsubst(): Expects 3 or 4 arguments" resolveFunction' "split" [psrc, psplt] = do@@ -467,7 +453,7 @@ Nothing -> throwPosError ("Unknown function" <+> dullred (ttext fname)) pdbresourcequery :: PValue -> Maybe T.Text -> InterpreterMonad PValue-pdbresourcequery q key = do+pdbresourcequery q mkey = do pdb <- view pdbAPI rrv <- case fromJSON (toJSON q) of Success rq -> interpreterIO (getResources pdb rq)@@ -480,7 +466,7 @@ Just val -> return val Nothing -> throwPosError ("pdbresourcequery strange error, could not find key" <+> ttext ky <+> "in" <+> pretty (PHash h)) extractSubHash _ x = throwPosError ("pdbresourcequery strange error, expected a hash, had" <+> pretty x)- case key of+ case mkey of Nothing -> return (PArray rv) (Just k) -> fmap PArray (V.mapM (extractSubHash k) rv) @@ -646,5 +632,4 @@ PHash hh -> return $ PHash $ HM.fromList $ map Prelude.fst $ filter Prelude.snd $ Prelude.zip (HM.toList hh) res x -> throwPosError ("Can't iterate on this data type:" <+> pretty x) x -> throwPosError ("This type of function is not supported yet by language-puppet!" <+> pretty x)-
Puppet/Interpreter/Types.hs view
@@ -19,6 +19,7 @@ import Control.Monad.Writer hiding ((<>)) import Control.Monad.Error import Control.Lens+import Control.Lens.Aeson import Data.String (IsString(..)) import qualified Data.Either.Strict as S import qualified Data.Maybe.Strict as S@@ -33,6 +34,8 @@ import Data.Time.Clock import GHC.Stack import Data.Maybe (fromMaybe)+import Data.Attoparsec.Number+import Data.Attoparsec.Text (parseOnly,number) #ifdef HRUBY import Foreign.Ruby@@ -649,3 +652,16 @@ <*> v .: "facts_timestamp" <*> v .: "report_timestamp" parseJSON _ = fail "invalide node info"++instance AsNumber PValue where+ _Number = prism num2PValue toNumber+ where+ num2PValue :: Number -> PValue+ num2PValue (I x) = PString (T.pack (show x))+ num2PValue (D x) = PString (T.pack (show x))+ toNumber :: PValue -> Either PValue Number+ toNumber p@(PString x) = case parseOnly number x of+ Right y -> Right y+ _ -> Left p+ toNumber p = Left p+
+ Puppet/Lens.hs view
@@ -0,0 +1,188 @@+{-# LANGUAGE FlexibleContexts #-}+module Puppet.Lens+ ( -- * Pure resolution prisms+ _PResolveExpression+ , _PResolveValue+ -- * Prisms for PValues+ , _PHash+ , _PBoolean+ , _PString+ , _PResourceReference+ , _PArray+ -- * Parsing prism+ , _PParse+ -- * Lenses and Prisms for 'Statement's+ , _VariableAssignment+ , _NodeDeclaration+ , _DefineDeclaration+ , _ClassDeclaration+ , _Statements+ ) where++import Control.Lens+import Control.Lens.Aeson+import Control.Applicative++import Puppet.PP (displayNocolor)+import Puppet.Parser.Types+import Puppet.Interpreter.Types+import Puppet.Interpreter.Resolve+import Puppet.Parser+import Puppet.Parser.PrettyPrinter (ppStatements)++import qualified Data.Vector as V+import qualified Data.HashMap.Strict as HM+import qualified Data.Text as T+import qualified Data.Maybe.Strict as S+import Data.Tuple.Strict hiding (uncurry)+import Text.Parsec.Prim (runParserT)+import Text.PrettyPrint.ANSI.Leijen (renderPretty,displayS,SimpleDoc(..))+import System.IO.Unsafe+import Data.Bits+import Text.Parser.Combinators (eof)++-- | Incomplete+_PResolveExpression :: Prism' Expression PValue+_PResolveExpression = prism reinject extract+ where+ extract x@(PValue v) = case v ^? _PResolveValue of+ Just r -> Right r+ Nothing -> Left x+ extract x@(And a b) =+ let a' = a ^? _PResolveExpression . to pValue2Bool+ b' = b ^? _PResolveExpression . to pValue2Bool+ in case (a',b') of+ (Just False, _) -> Right (PBoolean False)+ (Just _, Just r) -> Right (PBoolean r)+ _ -> Left x+ extract x@(Or a b) =+ let a' = a ^? _PResolveExpression . to pValue2Bool+ b' = b ^? _PResolveExpression . to pValue2Bool+ in case (a',b') of+ (Just True, _) -> Right (PBoolean True)+ (Just _, Just r) -> Right (PBoolean r)+ _ -> Left x+ extract x@(Addition a b) = extractBinop x a b (+) (+)+ extract x@(Substraction a b) = extractBinop x a b (-) (-)+ extract x@(Division a b) = extractNotZero b >> extractBinop x a b div (/)+ extract x@(Multiplication a b) = extractBinop x a b (*) (*)+ extract x@(Modulo a b) = extractNotZero b >> extractIntOp x a b mod+ extract x@(RightShift a b) = extractIntOp x a b (\v -> shiftR v . fromIntegral)+ extract x@(LeftShift a b) = extractIntOp x a b (\v -> shiftL v . fromIntegral)+ extract x = Left x+ reinject = PValue . review _PResolveValue++extractNotZero :: Expression -> Either Expression PValue+extractNotZero e = case e ^? _PResolveExpression of+ Just "0" -> Left e+ Just r -> Right r+ _ -> Left e++extractBinop :: Expression -> Expression -> Expression -> (Integer -> Integer -> Integer) -> (Double -> Double -> Double) -> Either Expression PValue+extractBinop x a b opi opf = case opi `fmap` (a ^? _PResolveExpression . _Integer) <*> (b ^? _PResolveExpression . _Integer) of+ Just ri -> Right $ review _Integer ri+ Nothing -> case opf `fmap` (a ^? _PResolveExpression . _Double) <*> (b ^? _PResolveExpression . _Double) of+ Just rd -> Right $ review _Double rd+ Nothing -> Left x++extractIntOp :: Expression -> Expression -> Expression -> (Integer -> Integer -> Integer) -> Either Expression PValue+extractIntOp x a b opi = case opi `fmap` (a ^? _PResolveExpression . _Integer) <*> (b ^? _PResolveExpression . _Integer) of+ Just ri -> Right $ review _Integer ri+ Nothing -> Left x++_PResolveValue :: Prism' UValue PValue+_PResolveValue = prism toU toP+ where+ toP (UString s) = Right (PString s)+ toP UUndef = Right PUndef+ toP (UBoolean b) = Right (PBoolean b)+ toP r@(UResourceReference t n) = maybe (Left r) (Right . PResourceReference t) (n ^? _PResolveExpression . _PString)+ toP r@(UArray lst) = maybe (Left r) (Right . PArray) (V.mapM (preview _PResolveExpression) lst)+ toP r@(UHash lst) = maybe (Left r) (Right . PHash . HM.fromList) (mapM resolveKV (V.toList lst))+ where+ resolveKV (k :!: v) = do+ k' <- k ^? _PResolveExpression . _PString+ v' <- v ^? _PResolveExpression+ return (k',v')+ toP r@(UInterpolable ip) = maybe (Left r) (Right . PString . T.concat . V.toList ) (V.mapM (preview (_PResolveValue . _PString)) ip)+ toP r = Left r+ toU (PBoolean x) = UBoolean x+ toU PUndef = UUndef+ toU (PString s) = UString s+ toU (PResourceReference t n) = UResourceReference t (PValue (UString n))+ toU (PArray r) = UArray (fmap (PValue . toU) r)+ toU (PHash h) = UHash (V.fromList $ map (\(k,v) -> (PValue (UString k) :!: PValue (toU v))) $ HM.toList h)++_PHash :: Prism' PValue (Container PValue)+_PHash = prism PHash $ \c -> case c of; PHash x -> Right x; _ -> Left c+_PBoolean :: Prism' PValue Bool+_PBoolean = prism PBoolean $ \c -> case c of; PBoolean x -> Right x; _ -> Left c+_PString :: Prism' PValue T.Text+_PString = prism PString $ \c -> case c of; PString x -> Right x; _ -> Left c+_PResourceReference :: Prism' PValue (T.Text, T.Text)+_PResourceReference = prism (uncurry PResourceReference) $ \c -> case c of; PResourceReference t n -> Right (t,n); _ -> Left c+_PArray :: Prism' PValue (V.Vector PValue)+_PArray = prism PArray $ \c -> case c of; PArray x -> Right x; _ -> Left c++-- | Warning, this uses 'unsafePerformIO' to parse (parsing Regexps+-- requires IO).+_PParse :: Prism' T.Text (V.Vector Statement)+_PParse = prism dspl prs+ where+ prs i = case unsafePerformIO (runParserT (puppetParser <* eof) () "dummy" i) of+ Left _ -> Left i+ Right x -> Right x+ dspl = T.pack . displayNocolor . ppStatements++_VariableAssignment :: Prism' Statement (T.Text,Expression,PPosition)+_VariableAssignment = prism rebuild extract+ where+ extract (VariableAssignment t e p) = Right (t,e,p)+ extract x = Left x+ rebuild (t,e,p) = VariableAssignment t e p++_NodeDeclaration :: Prism' Statement (NodeDesc, V.Vector Statement, S.Maybe NodeDesc, PPosition)+_NodeDeclaration = prism rebuild extract+ where+ extract (Node nd s nd' p) = Right (nd, s, nd', p)+ extract x = Left x+ rebuild (nd, s, nd', p) = Node nd s nd' p++_DefineDeclaration :: Prism' Statement (T.Text, V.Vector (Pair T.Text (S.Maybe Expression)), V.Vector Statement, PPosition)+_DefineDeclaration = prism rebuild extract+ where+ extract (DefineDeclaration n args stmts p) = Right (n, args, stmts, p)+ extract x = Left x+ rebuild (n, args, stmts, p) = DefineDeclaration n args stmts p++_ClassDeclaration :: Prism' Statement (T.Text, V.Vector (Pair T.Text (S.Maybe Expression)), S.Maybe T.Text, V.Vector Statement, PPosition)+_ClassDeclaration = prism rebuild extract+ where+ extract (ClassDeclaration n args inh stmts p) = Right (n, args, inh, stmts, p)+ extract x = Left x+ rebuild (n, args, inh, stmts, p) = ClassDeclaration n args inh stmts p++_TopContainer :: Prism' Statement (V.Vector Statement, Statement)+_TopContainer = prism rebuild extract+ where+ extract (TopContainer spur s) = Right (spur, s)+ extract x = Left x+ rebuild (spur, s) = TopContainer spur s++-- | Extracts the statements from 'ClassDeclaration', 'DefineDeclaration',+-- 'Node' and the spurious statements of 'TopContainer'.+_Statements :: Lens' Statement [Statement]+_Statements = lens (V.toList . sget) (\s v -> sset s (V.fromList v))+ where+ sget :: Statement -> V.Vector Statement+ sget (ClassDeclaration _ _ _ s _) = s+ sget (DefineDeclaration _ _ s _) = s+ sget (Node _ s _ _) = s+ sget (TopContainer s _) = s+ sget _ = V.empty+ sset :: Statement -> V.Vector Statement -> Statement+ sset (ClassDeclaration n args inh _ p) s = ClassDeclaration n args inh s p+ sset (Node ns _ nd' p) s = Node ns s nd' p+ sset (DefineDeclaration n args _ p) s = DefineDeclaration n args s p+ sset (TopContainer _ p) s = TopContainer s p+ sset x _ = x
Puppet/NativeTypes/File.hs view
@@ -25,7 +25,7 @@ ,("ensure" , [defaultvalue "present", string]) ,("force" , [string, values ["true","false"]]) ,("group" , [defaultvalue "root", string])- ,("ignore" , [string])+ ,("ignore" , [strings]) ,("links" , [string]) ,("mode" , [defaultvalue "0644", string]) ,("owner" , [string])
Puppet/PP.hs view
@@ -4,6 +4,7 @@ , tshow , dq , pshow+ , displayNocolor ) where import Text.PrettyPrint.ANSI.Leijen hiding ((<>))@@ -20,4 +21,16 @@ pshow :: Doc -> String pshow d = displayS (renderPretty 0.4 120 d) ""++-- | A rendering function that drops colors:+displayNocolor :: Doc -> String+displayNocolor = flip displayS "" . dropEffects . renderPretty 0.4 180+ where+ dropEffects :: SimpleDoc -> SimpleDoc+ dropEffects (SSGR _ x) = dropEffects x+ dropEffects (SLine l d) = SLine l (dropEffects d)+ dropEffects (SText v t d) = SText v t (dropEffects d)+ dropEffects (SChar c d) = SChar c (dropEffects d)+ dropEffects SEmpty = SEmpty+
Puppet/Parser.hs view
@@ -185,8 +185,9 @@ where acceptable x = isAsciiLower x || isAsciiUpper x || isDigit x || (x == '_') || (x == '-') -genFunctionCall :: Parser (T.Text, V.Vector Expression)-genFunctionCall = do+-- The first argument defines if non-parenthesized arguments are acceptable+genFunctionCall :: Bool -> Parser (T.Text, V.Vector Expression)+genFunctionCall nonparens = do fname <- moduleName <?> "Function name" -- this is a hack. Contrary to what the documentation says, -- a "bareword" can perfectly be a qualified name :@@ -194,12 +195,16 @@ let argsc sep e = (fmap (PValue . UString) (qualif1 className) <|> e <?> "Function argument") `sep` comma terminalF = terminalG (fail "function hack") expressionF = buildExpressionParser expressionTable (token terminalF) <?> "function expression"- args <- parens (argsc sepEndBy expression) <|> argsc sepEndBy1 expressionF <?> "Function arguments"+ withparens = parens (argsc sepEndBy expression)+ withoutparens = argsc sepEndBy1 expressionF+ args <- withparens <|> if nonparens+ then withoutparens <?> "Function arguments"+ else fail "Function arguments" return (fname, V.fromList args) functionCall :: Parser UValue functionCall = do- (fname, args) <- genFunctionCall+ (fname, args) <- genFunctionCall False return $ UFunctionCall fname args literalValue :: Parser T.Text@@ -483,7 +488,7 @@ mainFunctionCall :: Parser [Statement] mainFunctionCall = do p <- getPosition- (fname, args) <- genFunctionCall+ (fname, args) <- genFunctionCall True pe <- getPosition return [ MainFunctionCall fname args (p :!: pe) ]
Puppet/Preferences.hs view
@@ -35,4 +35,4 @@ templatedir = basedir <> "/templates" typenames <- fmap (map takeBaseName) (getFiles (T.pack modulesdir) "lib/puppet/type" ".rb") let loadedTypes = HM.fromList (map defaulttype typenames)- return $ Preferences manifestdir modulesdir templatedir 4 4 dummyPuppetDB (baseNativeTypes `HM.union` loadedTypes) (stdlibFunctions) (Just (basedir <> "/hiera.yaml"))+ return $ Preferences manifestdir modulesdir templatedir 8 4 dummyPuppetDB (baseNativeTypes `HM.union` loadedTypes) (stdlibFunctions) (Just (basedir <> "/hiera.yaml"))
Puppet/Stdlib.hs view
@@ -7,6 +7,8 @@ import Puppet.Interpreter.Types import Control.Lens+import Control.Lens.Aeson+import Puppet.Lens import Data.Char import Data.Monoid import Control.Monad@@ -41,6 +43,7 @@ , singleArgument "is_array" isArray , singleArgument "is_domain_name" isDomainName , singleArgument "is_integer" isInteger+ , singleArgument "is_string" isString , singleArgument "keys" keys , ("lstrip", stringArrayFunction T.stripStart) , ("merge", merge)@@ -80,9 +83,9 @@ Left ms -> throwPosError ("Can't parse regexp" <+> pretty (URegexp p undefined) <+> ":" <+> text (show ms)) puppetAbs :: PValue -> InterpreterMonad PValue-puppetAbs y = case y ^? pvnum of- Just (I x) -> return $ pvnum # I (abs x)- Just (D x) -> return $ pvnum # D (abs x)+puppetAbs y = case y ^? _Number of+ Just (I x) -> return $ _Integer # abs x+ Just (D x) -> return $ _Double # abs x Nothing -> throwPosError ("abs(): Expects a number, not" <+> pretty y) any2array :: [PValue] -> InterpreterMonad PValue@@ -128,12 +131,12 @@ puppetConcat _ = throwPosError "concat(): expects 2 arguments" puppetCount :: [PValue] -> InterpreterMonad PValue-puppetCount [PArray x] = return (pvnum # I (V.foldl' cnt 0 x))+puppetCount [PArray x] = return (_Integer # V.foldl' cnt 0 x) where cnt cur (PString "") = cur cnt cur PUndef = cur cnt cur _ = cur + 1-puppetCount [PArray x, y] = return (pvnum # I (V.foldl' cnt 0 x))+puppetCount [PArray x, y] = return (_Integer # V.foldl' cnt 0 x) where cnt cur z | y == z = cur + 1 | otherwise = cur@@ -151,8 +154,8 @@ delete _ = throwPosError "delete(): expects 2 arguments" deleteAt :: [PValue] -> InterpreterMonad PValue-deleteAt [PArray r, z] = case z ^? pvnum of- Just (I gn) ->+deleteAt [PArray r, z] = case z ^? _Integer of+ Just gn -> let n = fromInteger gn lr = V.length r s1 = V.slice 0 n r@@ -199,7 +202,13 @@ return $ PBoolean $ not (T.null rs) && T.length rs <= 255 && all checkPart prts isInteger :: PValue -> InterpreterMonad PValue-isInteger = return . PBoolean . not . isn't pvnum+isInteger = return . PBoolean . not . isn't _Integer++isString :: PValue -> InterpreterMonad PValue+isString pv = return $ PBoolean $ case (pv ^? _PString, pv ^? _Number) of+ (_, Just _) -> False+ (Just _, _) -> True+ _ -> False keys :: PValue -> InterpreterMonad PValue keys (PHash h) = return (PArray $ V.fromList $ map PString $ HM.keys h)
Puppet/Testing.hs view
@@ -49,7 +49,17 @@ type PSpec = PSpecM () testCatalog :: Nodename -> FilePath -> FinalCatalog -> PSpec -> IO H.Summary-testCatalog nd pdir catlg test = H.hspecWith (H.defaultConfig { H.configFormatter = H.failed_examples }) (describeCatalog nd pdir catlg test)+testCatalog nd pdir catlg test = H.hspecWith (H.defaultConfig { H.configFormatter = H.silent { H.failedFormatter = fform } })+ (describeCatalog nd pdir catlg test)+ where+ fform = do+ failures <- H.getFailMessages+ forM_ failures $ \(H.FailureRecord path reason) -> do+ H.write ("[" ++ T.unpack nd ++ "] ")+ H.writeLine (snd path)+ let err = either (("uncaught exception: " ++) . H.formatException) id reason+ H.withFailColor $ unless (null err) $ H.writeLine err+ unless (null failures) H.newParagraph describeCatalog :: Nodename -> FilePath -> FinalCatalog -> PSpec -> H.Spec describeCatalog nd pdir catlg test = H.describe (T.unpack nd) $ runReaderT test (TestEnv catlg (pdir <> "/modules") pdir)
PuppetDB/TestDB.hs view
@@ -7,6 +7,7 @@ import qualified Data.Either.Strict as S import qualified Data.Vector as V import Control.Lens+import Control.Lens.Aeson import Control.Exception import Control.Concurrent.STM import Data.Monoid@@ -19,8 +20,8 @@ import Puppet.Parser.Types import Puppet.Interpreter.Types-import Puppet.Interpreter.Resolve import Puppet.PP hiding ((<$>))+import Puppet.Lens data DBContent = DBContent { _dbcontentResources :: Container WireCatalog , _dbcontentFacts :: Container Facts@@ -49,12 +50,15 @@ decodeFileEither fp >>= \case Left (OtherParseException rr) -> return (S.Left (string (show rr))) Left (InvalidYaml Nothing) -> baseError "Unknown error"- Left (InvalidYaml (Just (YamlException s))) -> baseError (string s)+ Left (InvalidYaml (Just (YamlException s))) -> if take 21 s == "Yaml file not found: "+ then newFile+ else baseError (string s) Left (InvalidYaml (Just (YamlParseException pb ctx (YamlMark _ l c)))) -> baseError $ red (string pb <+> string ctx) <+> "at line" <+> int l <> ", column" <+> int c- Left _ -> S.Right <$> genDBAPI (newDB & backingFile ?~ fp )+ Left _ -> newFile Right x -> fmap S.Right (genDBAPI (x & backingFile ?~ fp )) where baseError r = return $ S.Left $ "Could not parse" <+> string fp <> ":" <+> r+ newFile = S.Right <$> genDBAPI (newDB & backingFile ?~ fp ) -- | Starts a new PuppetDB, without any backing file. initTestDB :: IO PuppetDBAPI@@ -105,7 +109,7 @@ ncompare :: (Integer -> Integer -> Bool) -> (a -> b -> Extracted) -> a -> Integer -> (b -> Bool) ncompare operation f a i v = case f a v of- EText tt -> case PString tt ^? _PInteger of+ EText tt -> case PString tt ^? _Integer of Just ii -> operation i ii _ -> False _ -> False
language-puppet.cabal view
@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: language-puppet-version: 0.10.5+version: 0.10.6 synopsis: Tools to parse and evaluate the Puppet DSL. description: This is a set of tools that is supposed to fill all your Puppet needs : syntax checks, catalog compilation, PuppetDB queries, simulationg of complex interactions between nodes, Puppet master replacement, and more ! homepage: http://lpuppet.banquise.net/@@ -50,6 +50,7 @@ , PuppetDB.Dummy , PuppetDB.Common , Hiera.Server+ , Puppet.Lens other-modules: Text.Parser.Parsec , Puppet.Utils , Puppet.NativeTypes.File@@ -100,7 +101,7 @@ , time == 1.4.* , filecache >= 0.2.2 && < 0.3 , regex-pcre-builtin >= 0.94.4- , pcre-utils == 0.1.*+ , pcre-utils >= 0.1.0.1 && < 0.2 , process == 1.1.* , iconv == 0.4.* , http-types == 0.8.*@@ -115,6 +116,7 @@ , yaml >= 0.8.0 && <0.9 , lens-aeson >= 0.1.2 && <0.2 , stateWriter == 0.2.*+ , split == 0.2.* Test-Suite test-lexer hs-source-dirs: tests@@ -151,9 +153,9 @@ executable puppetresources hs-source-dirs: progs extensions: BangPatterns, OverloadedStrings- ghc-options: -Wall -rtsopts -threaded+ ghc-options: -Wall -rtsopts -threaded -eventlog ghc-prof-options: -auto-all -caf-all -fprof-auto- build-depends: language-puppet,base,text,parsec,vector,ansi-wl-pprint,bytestring,mtl,hslogger,Diff,unordered-containers,strict-base-types,optparse-applicative,regex-pcre-builtin,lens,aeson,yaml+ build-depends: language-puppet,base,text,parsec,vector,ansi-wl-pprint,bytestring,mtl,hslogger,Diff,unordered-containers,strict-base-types,optparse-applicative,regex-pcre-builtin,lens,aeson,yaml,parallel-io main-is: PuppetResources.hs executable pdbquery
progs/PuppetResources.hs view
@@ -130,30 +130,36 @@ import Puppet.Parser import Puppet.Parser.PrettyPrinter() import Puppet.Interpreter.PrettyPrinter()-import Puppet.Interpreter.Resolve (_PString) import PuppetDB.Remote import PuppetDB.Dummy import PuppetDB.TestDB import PuppetDB.Common import Puppet.Testing hiding ((<$>))+import Puppet.Lens +import Control.Concurrent.ParallelIO (parallel_)+import Data.Maybe (mapMaybe)+ tshow :: Show a => a -> T.Text tshow = T.pack . show +type QueryFunc = T.Text -> IO (S.Either Doc (FinalCatalog, EdgeMap, FinalCatalog))++checkErrorStrict :: S.Either Doc x -> IO x+checkErrorStrict (S.Left rr) = putDoc rr >> putStrLn "" >> error "error!"+checkErrorStrict (S.Right x) = return x+ {-| Does all the work of initializing a daemon for querying. Returns the final catalog when given a node name. Note that this is pretty hackish as it will generate facts from the local computer ! -} -initializedaemonWithPuppet :: LOG.Priority -> PuppetDBAPI -> FilePath -> Maybe FilePath -> (Facts -> Facts) -> IO (T.Text -> IO (FinalCatalog, EdgeMap, FinalCatalog))+initializedaemonWithPuppet :: LOG.Priority -> PuppetDBAPI -> FilePath -> Maybe FilePath -> (Facts -> Facts) -> IO QueryFunc initializedaemonWithPuppet prio pdbapi puppetdir hierapath overrideFacts = do LOG.updateGlobalLogger "Puppet.Daemon" (LOG.setLevel prio) q <- fmap ((prefPDB .~ pdbapi) . (hieraPath .~ hierapath)) (genPreferences puppetdir) >>= initDaemon let f ndename = fmap overrideFacts (puppetDBFacts ndename pdbapi) >>= _dGetCatalog q ndename- >>= \case- S.Left rr -> putDoc rr >> putStrLn "" >> error "error!"- S.Right x -> return x return f parseFile :: FilePath -> IO (Either P.ParseError (V.Vector Statement))@@ -246,7 +252,7 @@ <> help "Puppet directory") nn = strOption ( long "node" <> short 'o'- <> help "Node name")+ <> help "Node name. Using 'allnodes' enables a special mode where all nodes present in site.pp are tried. Run with +RTS -N") pdbfile = strOption ( long "pdbfile" <> help "Path to the testing PuppetDB file.") hiera = strOption ( long "hiera"@@ -272,13 +278,16 @@ Just y -> return y Nothing -> error ("Error when parsing " ++ fp ++ ": some of the values were not strings") where- tv x = x ^? _PString+ tv x = x ^? _PString <|> isBool x+ isBool (PBoolean True) = Just "true"+ isBool (PBoolean False) = Just "false"+ isBool _ = Nothing run :: CommandLine -> IO () run (CommandLine _ _ _ _ _ f Nothing _ _ _ _ _) = parseFile f >>= \case Left rr -> error ("parse error:" ++ show rr) Right s -> putDoc (vcat (map pretty (V.toList s)))-run (CommandLine puppeturl showjson showcontent mrt mrn puppetdir (Just ndename) mpdbf prio hpath fcts fdef) = do+run c@(CommandLine puppeturl _ _ _ _ puppetdir (Just ndename) mpdbf prio hpath fcts fdef) = do let checkError r (S.Left rr) = error (show (red r <> ":" <+> rr)) checkError _ (S.Right x) = return x tnodename = T.pack ndename@@ -297,34 +306,53 @@ if isterm then putDoc x >> putStrLn "" else displayIO stdout (renderCompact x) >> putStrLn ""- (rawcatalog,m,rawexported) <- queryfunc tnodename- let wireCatalog = generateWireCatalog tnodename (rawcatalog <> rawexported) m- void $ replaceCatalog pdbapi wireCatalog+ if tnodename == "allnodes"+ then do+ allstmts <- parseFile (puppetdir <> "/manifests/site.pp") >>= \presult -> case presult of+ Left rr -> error (show rr)+ Right x -> return x+ let topnodes = mapMaybe getNodeName (V.toList allstmts)+ getNodeName (Node (NodeName n) _ _ _) = Just n+ getNodeName _ = Nothing+ parallel_ (map (computeCatalogs True queryfunc pdbapi printFunc c) topnodes)+ putStrLn ("Tested " ++ show (length topnodes) ++ " nodes.")+ else computeCatalogs False queryfunc pdbapi printFunc c tnodename void $ commitDB pdbapi- let cmpMatch Nothing _ curcat = return curcat- cmpMatch (Just rg) lns curcat = compile compBlank execBlank (T.unpack rg) >>= \case- Left rr -> error ("Error compiling regexp 're': " ++ show rr)- Right rec -> fmap HM.fromList $ filterM (filterResource lns rec) (HM.toList curcat)- filterResource lns rec v = execute rec (v ^. lns) >>= \case- Left rr -> error ("Error when applying regexp: " ++ show rr)- Right Nothing -> return False- _ -> return True- filterCatalog = cmpMatch mrt (_1 . itype . unpacked) >=> cmpMatch mrn (_1 . iname . unpacked)- catalog <- filterCatalog rawcatalog- exported <- filterCatalog rawexported- case (showcontent, showjson) of- (_, True) -> BSL.putStrLn (encode (prepareForPuppetApply wireCatalog))- (True, _) -> do- unless (mrt == Just "file" || mrt == Nothing) (error $ "Show content only works for file, not for " ++ show mrt)- case mrn of- Just f -> printContent f catalog- Nothing -> error "You should supply a resource name when using showcontent"- _ -> do- void $ testCatalog tnodename puppetdir rawcatalog basicTest- printFunc (pretty (HM.elems catalog))- unless (HM.null exported) $ do- printFunc (mempty <+> dullyellow "Exported:" <+> mempty)- printFunc (pretty (HM.elems exported))++computeCatalogs :: Bool -> QueryFunc -> PuppetDBAPI -> (Doc -> IO ()) -> CommandLine -> T.Text -> IO ()+computeCatalogs testOnly queryfunc pdbapi printFunc (CommandLine _ showjson showcontent mrt mrn puppetdir _ _ _ _ _ _) tnodename = queryfunc tnodename >>= \case+ S.Left rr -> if testOnly+ then putDoc ("Problem with" <+> ttext tnodename <+> ":" <+> rr </> mempty)+ else putDoc rr >> putStrLn "" >> error "error!"+ S.Right (rawcatalog,m,rawexported) -> do+ let wireCatalog = generateWireCatalog tnodename (rawcatalog <> rawexported) m+ void $ replaceCatalog pdbapi wireCatalog+ let cmpMatch Nothing _ curcat = return curcat+ cmpMatch (Just rg) lns curcat = compile compBlank execBlank (T.unpack rg) >>= \case+ Left rr -> error ("Error compiling regexp 're': " ++ show rr)+ Right rec -> fmap HM.fromList $ filterM (filterResource lns rec) (HM.toList curcat)+ filterResource lns rec v = execute rec (v ^. lns) >>= \case+ Left rr -> error ("Error when applying regexp: " ++ show rr)+ Right Nothing -> return False+ _ -> return True+ filterCatalog = cmpMatch mrt (_1 . itype . unpacked) >=> cmpMatch mrn (_1 . iname . unpacked)+ case (testOnly, showcontent, showjson) of+ (True, _, _) -> void $ testCatalog tnodename puppetdir rawcatalog basicTest+ (_, _, True) -> BSL.putStrLn (encode (prepareForPuppetApply wireCatalog))+ (_, True, _) -> do+ catalog <- filterCatalog rawcatalog+ unless (mrt == Just "file" || mrt == Nothing) (error $ "Show content only works for file, not for " ++ show mrt)+ case mrn of+ Just f -> printContent f catalog+ Nothing -> error "You should supply a resource name when using showcontent"+ _ -> do+ catalog <- filterCatalog rawcatalog+ exported <- filterCatalog rawexported+ void $ testCatalog tnodename puppetdir rawcatalog basicTest+ printFunc (pretty (HM.elems catalog))+ unless (HM.null exported) $ do+ printFunc (mempty <+> dullyellow "Exported:" <+> mempty)+ printFunc (pretty (HM.elems exported)) main :: IO () main = execParser pinfo >>= run
progs/pdbQuery.hs view
@@ -83,7 +83,9 @@ let getOrError s (S.Left rr) = error (s <> " " <> show rr) getOrError _ (S.Right x) = return x case _pdbcmd cmdl of- DumpFacts -> getFacts pdbapi QEmpty >>= display "get facts"+ DumpFacts -> if _pdbtype cmdl == PDBDummy+ then puppetDBFacts "dummy" pdbapi >>= mapM_ print . HM.toList+ else getFacts pdbapi QEmpty >>= display "get facts" DumpNodes -> getNodes pdbapi QEmpty >>= display "dump nodes" AddFacts n -> do unless (_pdbtype cmdl == PDBTest) (error "This option only works with the test puppetdb")