diff --git a/Facter.hs b/Facter.hs --- a/Facter.hs +++ b/Facter.hs @@ -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 diff --git a/Hiera/Server.hs b/Hiera/Server.hs --- a/Hiera/Server.hs +++ b/Hiera/Server.hs @@ -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 diff --git a/Puppet/Interpreter.hs b/Puppet/Interpreter.hs --- a/Puppet/Interpreter.hs +++ b/Puppet/Interpreter.hs @@ -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 diff --git a/Puppet/Interpreter/Resolve.hs b/Puppet/Interpreter/Resolve.hs --- a/Puppet/Interpreter/Resolve.hs +++ b/Puppet/Interpreter/Resolve.hs @@ -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) - diff --git a/Puppet/Interpreter/Types.hs b/Puppet/Interpreter/Types.hs --- a/Puppet/Interpreter/Types.hs +++ b/Puppet/Interpreter/Types.hs @@ -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 + diff --git a/Puppet/Lens.hs b/Puppet/Lens.hs new file mode 100644 --- /dev/null +++ b/Puppet/Lens.hs @@ -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 diff --git a/Puppet/NativeTypes/File.hs b/Puppet/NativeTypes/File.hs --- a/Puppet/NativeTypes/File.hs +++ b/Puppet/NativeTypes/File.hs @@ -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]) diff --git a/Puppet/PP.hs b/Puppet/PP.hs --- a/Puppet/PP.hs +++ b/Puppet/PP.hs @@ -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 + diff --git a/Puppet/Parser.hs b/Puppet/Parser.hs --- a/Puppet/Parser.hs +++ b/Puppet/Parser.hs @@ -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) ] diff --git a/Puppet/Preferences.hs b/Puppet/Preferences.hs --- a/Puppet/Preferences.hs +++ b/Puppet/Preferences.hs @@ -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")) diff --git a/Puppet/Stdlib.hs b/Puppet/Stdlib.hs --- a/Puppet/Stdlib.hs +++ b/Puppet/Stdlib.hs @@ -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) diff --git a/Puppet/Testing.hs b/Puppet/Testing.hs --- a/Puppet/Testing.hs +++ b/Puppet/Testing.hs @@ -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) diff --git a/PuppetDB/TestDB.hs b/PuppetDB/TestDB.hs --- a/PuppetDB/TestDB.hs +++ b/PuppetDB/TestDB.hs @@ -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 diff --git a/language-puppet.cabal b/language-puppet.cabal --- a/language-puppet.cabal +++ b/language-puppet.cabal @@ -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 diff --git a/progs/PuppetResources.hs b/progs/PuppetResources.hs --- a/progs/PuppetResources.hs +++ b/progs/PuppetResources.hs @@ -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 diff --git a/progs/pdbQuery.hs b/progs/pdbQuery.hs --- a/progs/pdbQuery.hs +++ b/progs/pdbQuery.hs @@ -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")