language-puppet 1.1.0 → 1.1.1
raw patch · 36 files changed
+745/−456 lines, 36 filesdep +eitherdep +exceptionsdep +servantdep −http-conduitdep −http-typesdep −iconvdep ~basedep ~filecachedep ~hruby
Dependencies added: either, exceptions, servant, servant-client, transformers
Dependencies removed: http-conduit, http-types, iconv, transformers-compat
Dependency ranges changed: base, filecache, hruby, lens, mtl, operational, time
Files
- CHANGELOG.markdown +20/−0
- Erb/Compute.hs +17/−17
- Facter.hs +5/−5
- HLint.hs +4/−0
- Hiera/Server.hs +2/−2
- Puppet/Daemon.hs +39/−15
- Puppet/Interpreter.hs +38/−6
- Puppet/Interpreter/IO.hs +40/−31
- Puppet/Interpreter/PrettyPrinter.hs +11/−8
- Puppet/Interpreter/Pure.hs +3/−2
- Puppet/Interpreter/Resolve.hs +15/−13
- Puppet/Interpreter/Types.hs +58/−40
- Puppet/Lens.hs +8/−0
- Puppet/Manifests.hs +5/−3
- Puppet/NativeTypes.hs +12/−10
- Puppet/NativeTypes/File.hs +15/−13
- Puppet/NativeTypes/Helpers.hs +14/−14
- Puppet/NativeTypes/Notify.hs +15/−0
- Puppet/NativeTypes/Package.hs +3/−2
- Puppet/NativeTypes/SshSecure.hs +1/−1
- Puppet/NativeTypes/ZoneRecord.hs +1/−1
- Puppet/OptionalTests.hs +46/−13
- Puppet/PP.hs +2/−2
- Puppet/Parser/PrettyPrinter.hs +10/−8
- Puppet/Plugins.hs +2/−3
- Puppet/Preferences.hs +94/−25
- Puppet/Stdlib.hs +19/−18
- Puppet/Utils.hs +8/−0
- PuppetDB/Common.hs +3/−1
- PuppetDB/Dummy.hs +9/−9
- PuppetDB/Remote.hs +45/−48
- PuppetDB/TestDB.hs +41/−28
- README.adoc +9/−3
- language-puppet.cabal +18/−15
- progs/PuppetResources.hs +81/−76
- progs/pdbQuery.hs +32/−24
CHANGELOG.markdown view
@@ -1,3 +1,23 @@+# v1.1.1 (2015/04/20)++## New features+* Add 'notify' native type+* Ability to provide defaults via a yaml file for some options+* Added the 'ensure_packages' and 'ensure_resources' functions++## Bugs fixed+* Enable 'package' native type (issue #102)+* Builds against GHC 7.10++## Changes+* Even in Permissive mode, don't resolve unknown variable (see #103)+* Add priority to the logger permissive output (see #106)+* New hruby version+* Rename option `--ignoremodules` into `--ignoredmodules`++## Various+* Hiera config interpolation logs decrease from NOTICE to INFO+ # v1.1.0 (2015/03/11) Critical bugs have been fixed, upgrade recommended.
Erb/Compute.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} module Erb.Compute(computeTemplate, initTemplateDaemon) where@@ -11,10 +10,11 @@ import Puppet.Utils import Control.Concurrent-import Control.Monad.Error+import Control.Monad.Except import qualified Data.Either.Strict as S import Data.FileCache import qualified Data.Text as T+import Data.String import Debug.Trace import Erb.Evaluate import Erb.Parser@@ -29,24 +29,24 @@ import Control.Lens import Data.Tuple.Strict-import qualified Foreign.Ruby as FR-import Foreign.Ruby.Safe+import qualified Foreign.Ruby.Helpers as FR+import qualified Foreign.Ruby.Bindings as FR+import Foreign.Ruby +instance IsString TemplateParseError where+ fromString s = TemplateParseError $ newErrorMessage (Message s) (initialPos "dummy") newtype TemplateParseError = TemplateParseError { tgetError :: ParseError } -instance Error TemplateParseError where- noMsg = TemplateParseError $ newErrorUnknown (initialPos "dummy")- strMsg s = TemplateParseError $ newErrorMessage (Message s) (initialPos "dummy")- type TemplateQuery = (Chan TemplateAnswer, Either T.Text T.Text, T.Text, Container ScopeInformation) type TemplateAnswer = S.Either PrettyError T.Text showRubyError :: RubyError -> PrettyError showRubyError (Stack msg stk) = PrettyError $ dullred (string msg) </> dullyellow (string stk) showRubyError (WithOutput str _) = PrettyError $ dullred (string str)+showRubyError (OtherError rr) = PrettyError (dullred (text rr)) -initTemplateDaemon :: RubyInterpreter -> (Preferences IO) -> MStats -> IO (Either T.Text T.Text -> T.Text -> Container ScopeInformation -> IO (S.Either PrettyError T.Text))+initTemplateDaemon :: RubyInterpreter -> Preferences IO -> MStats -> IO (Either T.Text T.Text -> T.Text -> Container ScopeInformation -> IO (S.Either PrettyError T.Text)) initTemplateDaemon intr prefs mvstats = do controlchan <- newChan templatecache <- newFileCache@@ -115,7 +115,7 @@ getRubyScriptPath :: String -> IO String getRubyScriptPath rubybin = do- let checkpath :: FilePath -> (IO FilePath) -> IO FilePath+ let checkpath :: FilePath -> IO FilePath -> IO FilePath checkpath fp nxt = do e <- fileExist fp if e@@ -137,14 +137,14 @@ variables <- FR.extractHaskellValue rvariables toresolve <- FR.fromRuby rtoresolve let answer = case toresolve of- Just "~g~e~t_h~a~s~h~" ->+ Right "~g~e~t_h~a~s~h~" -> let getvars ctx = (variables ^. ix ctx . scopeVariables) & traverse %~ view (_1 . _1) vars = getvars "::" <> getvars scope in Right (PHash vars)- Just t -> getVariable variables scope t- _ -> Left "The variable name is not a string"+ Right t -> getVariable variables scope t+ Left rr -> Left ("The variable name is not a string" <+> text rr) case answer of- Left _ -> FR.getSymbol "undef"+ Left _ -> getSymbol "undef" Right r -> FR.toRuby r computeTemplateWRuby :: Either T.Text T.Text -> T.Text -> Container ScopeInformation -> IO TemplateAnswer@@ -158,7 +158,7 @@ case erbBinding of Left x -> return (Left x) Right v -> do- forM_ (itoList varlist) $ \(varname, (varval :!: _ :!: _)) -> FR.toRuby varval >>= FR.rb_iv_set v (T.unpack varname)+ forM_ (itoList varlist) $ \(varname, varval :!: _ :!: _) -> FR.toRuby varval >>= FR.rb_iv_set v (T.unpack varname) f v o <- case fileinfo of Right fname -> do@@ -174,5 +174,5 @@ Left _ -> "inline_template" in return (S.Left $ PrettyError (dullred (text rr) <+> "in" <+> dullgreen (text fname))) Right r -> FR.fromRuby r >>= \case- Just result -> return (S.Right result)- Nothing -> return (S.Left "Could not deserialiaze ruby output")+ Right result -> return (S.Right result)+ Left rr -> return (S.Left $ PrettyError ("Could not deserialiaze ruby output" <+> text rr))
Facter.hs view
@@ -8,7 +8,6 @@ import Puppet.Interpreter.Types 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(..))@@ -17,6 +16,7 @@ import System.Environment import System.Directory (doesFileExist) import Data.Maybe (mapMaybe)+import Control.Monad.Trans.Either storageunits :: [(String, Int)] storageunits = [ ("", 0), ("K", 1), ("M", 2), ("G", 3), ("T", 4) ]@@ -107,7 +107,7 @@ lrelease = getval "DISTRIB_RELEASE" distid = getval "DISTRIB_ID" maj | lrelease == "?" = "?"- | otherwise = fst $ break (== '.') lrelease+ | otherwise = takeWhile (/= '.') lrelease osfam | distid == "Ubuntu" = "Debian" | otherwise = distid return [ ("lsbdistid" , distid)@@ -164,13 +164,13 @@ factProcessor = do cpuinfo <- readFile "/proc/cpuinfo" let cpuinfos = zip [ "processor" ++ show (n :: Int) | n <- [0..]] modelnames- modelnames = mapMaybe (fmap (dropWhile (`elem` "\t :")) . stripPrefix "model name") (lines cpuinfo)+ modelnames = mapMaybe (fmap (dropWhile (`elem` ("\t :" :: String))) . stripPrefix "model name") (lines cpuinfo) return $ ("processorcount", show (length cpuinfos)) : cpuinfos puppetDBFacts :: T.Text -> PuppetDBAPI IO -> IO (Container PValue) puppetDBFacts ndename pdbapi =- getFacts pdbapi (QEqual FCertname ndename) >>= \case- S.Right facts@(_:_) -> return (HM.fromList (map (\f -> (f ^. factname, f ^. factval)) facts))+ runEitherT (getFacts pdbapi (QEqual FCertname ndename)) >>= \case+ Right facts@(_:_) -> return (HM.fromList (map (\f -> (f ^. factname, f ^. factval)) facts)) _ -> do rawFacts <- fmap concat (sequence [factNET, factRAM, factOS, fversion, factMountPoints, factOS, factUser, factUName, fenv, factProcessor]) let ofacts = genFacts $ map (T.pack *** T.pack) rawFacts
+ HLint.hs view
@@ -0,0 +1,4 @@+import "hint" HLint.HLint+++ignore "Redundant lambda"
Hiera/Server.hs view
@@ -38,7 +38,7 @@ import qualified System.Log.Logger as LOG import Puppet.Interpreter.Types-import Puppet.PP hiding ((<$>))+import Puppet.PP import Puppet.Utils (strictifyEither) loggerName :: String@@ -159,7 +159,7 @@ case resolveInterpolable vars strs of Just s -> queryCombinator qtype (map (query'' s) _backends) Nothing -> do- LOG.noticeM loggerName (show $ "Hiera lookup: skipping using hierarchy level" <+> pretty strs+ LOG.infoM loggerName (show $ "Hiera lookup: skipping using hierarchy level" <+> pretty strs <$$> "It couldn't be interpolated with known variables:" <+> varlist) return Nothing query'' :: T.Text -> Backend -> IO (Maybe PValue)
Puppet/Daemon.hs view
@@ -1,24 +1,35 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} module Puppet.Daemon (initDaemon) where +import Control.Applicative import Control.Exception+import Control.Exception.Lens import Control.Lens-import Control.Monad (when)-import qualified Data.Either.Strict as S+import qualified Data.Either.Strict as S import Data.FileCache-import qualified Data.HashMap.Strict as HM-import qualified Data.Text as T-import qualified Data.Text.IO as T+import qualified Data.HashMap.Strict as HM+import qualified Data.Text as T+import qualified Data.Text.IO as T+import Data.Traversable (for) import Data.Tuple.Strict-import qualified Data.Vector as V+import qualified Data.Vector as V import Debug.Trace import Erb.Compute import Foreign.Ruby.Safe+import Prelude+import System.IO (stdout)+import System.Log.Formatter as LOG+import System.Log.Handler as LOG+import System.Log.Handler.Simple as LOG+import qualified System.Log.Logger as LOG+ import Hiera.Server import Puppet.Interpreter import Puppet.Interpreter.IO import Puppet.Interpreter.Types+import Puppet.Lens (_PrettyError) import Puppet.Manifests import Puppet.OptionalTests import Puppet.Parser@@ -28,7 +39,6 @@ import Puppet.Preferences import Puppet.Stats import Puppet.Utils-import qualified System.Log.Logger as LOG {-| This is a high level function, that will initialize the parsing and interpretation infrastructure from the 'Preferences', and will return 'DaemonMethods'.@@ -52,12 +62,13 @@ * It might be buggy when top level statements that are not class\/define\/nodes are altered, or when files loaded with require are changed. -* The catalog is not computed exactly the same way Puppet does. Some good practices are enforced.-As an example querying a dictionary with a non existent key returns undef in puppet, whereas it throws an error with language-puppet.+* The catalog is not computed exactly the same way Puppet does. Some good practices are enforced, particularly in strict mode.+For instance, unknown variables are always an error. Querying a dictionary with a non existent key returns undef in puppet, whereas it would throw an error in strict mode. -} initDaemon :: Preferences IO -> IO DaemonMethods initDaemon prefs = do+ setupConsoleLogger logDebug "initDaemon" traceEventIO "initDaemon" templateStats <- newStats@@ -68,7 +79,7 @@ intr <- startRubyInterpreter getTemplate <- initTemplateDaemon intr prefs templateStats hquery <- case prefs ^. hieraPath of- Just p -> fmap (either error id) $ startHiera p+ Just p -> either error id <$> startHiera p Nothing -> return dummyHiera luacontainer <- initLuaMaster (T.pack (prefs ^. puppetPaths.modulesPath)) let myprefs = prefs & prefExtFuncs %~ HM.union luacontainer@@ -95,18 +106,22 @@ hquery defaultImpureMethods (prefs ^. ignoredmodules)+ (prefs ^. externalmodules) (prefs ^. strictness == Strict)) ndename facts (stmts :!: warnings) <- measure stats ndename catalogComputation mapM_ (\(p :!: m) -> LOG.logM loggerName p (displayS (renderCompact (ttext ndename <> ":" <+> m)) "")) warnings traceEventIO ("STOP gCatalog " <> T.unpack ndename)- when (prefs ^. extraTests) $ runOptionalTests stmts- return stmts+ if prefs ^. extraTests+ then runOptionalTests stmts+ else return stmts where- runOptionalTests r = case r^?S._Right._1 of- Nothing -> return ()- Just c -> testCatalog (prefs^.puppetPaths.baseDir) c+ runOptionalTests stm = case stm^?S._Right._1 of+ Nothing -> return stm+ (Just c) -> catching _PrettyError+ (do {testCatalog prefs c; return stm})+ (return . S.Left) parseFunction :: Preferences IO -> FileCache (V.Vector Statement) -> MStats -> TopLevelType -> T.Text -> IO (S.Either PrettyError Statement) parseFunction prefs filecache stats topleveltype toplevelname =@@ -150,3 +165,12 @@ logDebug :: T.Text -> IO () logDebug = LOG.debugM loggerName . T.unpack++setupConsoleLogger :: IO ()+setupConsoleLogger = do+ hs <- for [LOG.DEBUG, LOG.INFO, LOG.NOTICE, LOG.WARNING] consoleLogHandler+ LOG.updateGlobalLogger LOG.rootLoggerName $ LOG.setHandlers hs+ where+ consoleLogHandler p = LOG.setFormatter+ <$> LOG.streamHandler stdout p+ <*> pure (LOG.simpleLogFormatter "$prio: $msg")
Puppet/Interpreter.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} module Puppet.Interpreter@@ -12,11 +13,11 @@ import Puppet.NativeTypes import Puppet.Parser.PrettyPrinter import Puppet.Parser.Types-import Puppet.PP hiding ((<$>))+import Puppet.PP import Control.Applicative import Control.Lens-import Control.Monad.Error hiding (forM, mapM)+import Control.Monad.Except import Control.Monad.Operational hiding (view) import qualified Data.Either.Strict as S import Data.Foldable (Foldable, foldl', foldlM,@@ -30,13 +31,14 @@ import qualified Data.Maybe.Strict as S import Data.Ord (comparing) import qualified Data.Text as T-import Data.Traversable (mapM)+import Data.Traversable (mapM, for) import qualified Data.Tree as T import Data.Tuple.Strict (Pair (..)) import qualified Data.Tuple.Strict as S-import Prelude hiding (mapM)+import qualified Data.Vector as V import Puppet.Utils import System.Log.Logger+import Prelude hiding (mapM) -- helpers vmapM :: (Monad m, Foldable t) => (a -> m b) -> t a -> m [b]@@ -120,7 +122,7 @@ n <- isNativeType (r ^. rid . itype) -- if we have a native type, or a virtual/exported resource it -- should not be expanded !- if (n || r ^. rvirtuality /= Normal)+ if n || r ^. rvirtuality /= Normal then return [r] else expandDefine r concat <$> mapM expandableDefine withDefaults@@ -672,7 +674,6 @@ addAttribute :: OverrideType -> T.Text -> Resource -> PValue -> InterpreterMonad Resource addAttribute _ "alias" r v = (\rv -> r & ralias . contains rv .~ True) <$> resolvePValueString v addAttribute _ "audit" r _ = use curPos >>= \p -> warn ("Metaparameter audit ignored at" <+> showPPos p) >> return r-addAttribute _ "noop" r _ = use curPos >>= \p -> warn ("Metaparameter noop ignored at" <+> showPPos p) >> return r addAttribute _ "loglevel" r _ = use curPos >>= \p -> warn ("Metaparameter loglevel ignored at" <+> showPPos p) >> return r addAttribute _ "schedule" r _ = use curPos >>= \p -> warn ("Metaparameter schedule ignored at" <+> showPPos p) >> return r addAttribute _ "stage" r _ = use curPos >>= \p -> warn ("Metaparameter stage ignored at" <+> showPPos p) >> return r@@ -768,6 +769,8 @@ genRes rname x = throwPosError ("create_resource(): the value corresponding to key" <+> ttext rname <+> "should be a hash, not" <+> pretty x) concat . HM.elems <$> itraverse genRes hs mainFunctionCall "create_resources" args = throwPosError ("create_resource(): expects between two and three arguments, of type [string,hash,hash], and not:" <+> pretty args)+mainFunctionCall "ensure_packages" args = ensurePackages args+mainFunctionCall "ensure_resource" args = ensureResource args mainFunctionCall "realize" args = do p <- use curPos let realiz (PResourceReference rt rn) = resMod %= (ResourceModifier rt ModifierMustMatch RealizeVirtual (REqualitySearch "title" (PString rn)) return p : )@@ -807,6 +810,35 @@ rs <- singleton (ExternalFunction fname args) unless (rs == PUndef) $ throwPosError ("This function call should return" <+> pretty PUndef <+> "and not" <+> pretty rs </> pretty representation) return []++ensurePackages :: [PValue] -> InterpreterMonad [Resource]+ensurePackages [packages] = ensurePackages [packages, PHash mempty]+ensurePackages [PString p, x] = ensurePackages [ PArray (V.singleton (PString p)), x ]+ensurePackages [PArray packages, PHash defaults] = do+ checkStrict "The use of the 'ensure_packages' function is a code smell."+ "The 'ensure_packages' function is not allowed in strict mode."+ concat <$> for packages (resolvePValueString >=> ensureResource' "package" (HM.singleton "ensure" "present" <> defaults))+ensurePackages [PArray _,_] = throwPosError "ensure_packages(): the second argument must be a hash."+ensurePackages [_,_] = throwPosError "ensure_packages(): the first argument must be a string or an array of strings."+ensurePackages _ = throwPosError "ensure_packages(): requires one or two arguments."++ensureResource :: [PValue] -> InterpreterMonad [Resource]+ensureResource [PString tp, PString ttl, PHash params] = do+ checkStrict "The use of the 'ensure_resource' function is a code smell."+ "The 'ensure_resource' function is not allowed in strict mode."+ ensureResource' tp params ttl+ensureResource [tp,ttl] = ensureResource [tp,ttl,PHash mempty]+ensureResource [_, PString _, PHash _] = throwPosError "ensureResource(): The first argument must be a string."+ensureResource [PString _, _, PHash _] = throwPosError "ensureResource(): The second argument must be a string."+ensureResource [PString _, PString _, _] = throwPosError "ensureResource(): The thrid argument must be a hash."+ensureResource _ = throwPosError "ensureResource(): expects 2 or 3 arguments."++ensureResource' :: T.Text -> HM.HashMap T.Text PValue -> T.Text -> InterpreterMonad [Resource]+ensureResource' tp params ttl = do+ def <- has (ix (RIdentifier tp ttl)) <$> use definedResources+ if def+ then return []+ else use curPos >>= registerResource tp ttl params Normal -- Method stuff evaluateHFC :: HFunctionCall -> InterpreterMonad [Resource]
Puppet/Interpreter/IO.hs view
@@ -1,30 +1,35 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}--- | This is an internal module.-module Puppet.Interpreter.IO (defaultImpureMethods, interpretMonad) where--import Puppet.PP hiding ((<$>))-import Puppet.Interpreter.Types-import Puppet.Interpreter.PrettyPrinter()-import Puppet.Plugins()+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-} -import Control.Monad.Operational-import Control.Monad.State.Strict-import Control.Lens-import Control.Applicative+-- | This is an internal module.+module Puppet.Interpreter.IO (+ defaultImpureMethods+ , interpretMonad+ ) where -import qualified Data.Either.Strict as S+import Puppet.Interpreter.PrettyPrinter ()+import Puppet.Interpreter.Types+import Puppet.Plugins ()+import Puppet.PP -import Data.Monoid-import GHC.Stack-import Debug.Trace (traceEventIO)-import qualified Data.Text as T-import qualified Data.Text.IO as T-import qualified Scripting.Lua as Lua-import Control.Exception-import Control.Concurrent.MVar+import Control.Applicative+import Control.Concurrent.MVar+import Control.Exception+import Control.Lens+import Control.Monad.Operational+import Control.Monad.State.Strict+import Control.Monad.Trans.Either+import qualified Data.Either.Strict as S+import Data.Monoid+import qualified Data.Text as T+import qualified Data.Text.IO as T+import Debug.Trace (traceEventIO)+import GHC.Stack+import qualified Scripting.Lua as Lua+import Prelude defaultImpureMethods :: (Functor m, MonadIO m) => ImpureMethods m defaultImpureMethods = ImpureMethods (liftIO currentCallStack)@@ -64,6 +69,9 @@ canFail iof = iof >>= \case S.Left err -> thpe err S.Right x -> runInstr x+ canFailE iof = runEitherT iof >>= \case+ Left err -> thpe err+ Right x -> runInstr x logStuff x c = (_3 %~ (x <>)) <$> c in case a of IsStrict -> runInstr (r ^. isStrict)@@ -82,18 +90,19 @@ GetNodeName -> runInstr (r ^. thisNodename) HieraQuery scps q t -> canFail ((r ^. hieraQuery) scps q t) PDBInformation -> pdbInformation pdb >>= runInstr- PDBReplaceCatalog w -> canFail (replaceCatalog pdb w)- PDBReplaceFacts fcts -> canFail (replaceFacts pdb fcts)- PDBDeactivateNode nn -> canFail (deactivateNode pdb nn)- PDBGetFacts q -> canFail (getFacts pdb q)- PDBGetResources q -> canFail (getResources pdb q)- PDBGetNodes q -> canFail (getNodes pdb q)- PDBCommitDB -> canFail (commitDB pdb)- PDBGetResourcesOfNode nn q -> canFail (getResourcesOfNode pdb nn q)+ PDBReplaceCatalog w -> canFailE (replaceCatalog pdb w)+ PDBReplaceFacts fcts -> canFailE (replaceFacts pdb fcts)+ PDBDeactivateNode nn -> canFailE (deactivateNode pdb nn)+ PDBGetFacts q -> canFailE (getFacts pdb q)+ PDBGetResources q -> canFailE (getResources pdb q)+ PDBGetNodes q -> canFailE (getNodes pdb q)+ PDBCommitDB -> canFailE (commitDB pdb)+ PDBGetResourcesOfNode nn q -> canFailE (getResourcesOfNode pdb nn q) GetCurrentCallStack -> (r ^. ioMethods . imGetCurrentCallStack) >>= runInstr ReadFile fls -> strFail ((r ^. ioMethods . imReadFile) fls) (const $ PrettyError ("No file found in " <> list (map ttext fls))) TraceEvent e -> (r ^. ioMethods . imTraceEvent) e >>= runInstr IsIgnoredModule m -> runInstr (r ^. ignoredModules . contains m)+ IsExternalModule m -> runInstr (r ^. externalModules . contains m) CallLua c fname args -> (r ^. ioMethods . imCallLua) c fname args >>= \case Right x -> runInstr x Left rr -> thpe (PrettyError (string rr))
Puppet/Interpreter/PrettyPrinter.hs view
@@ -8,17 +8,19 @@ import Puppet.PP import Puppet.Utils -import Control.Arrow (first, second)+import Control.Arrow (first, second) import Control.Lens-import qualified Data.ByteString.Lazy.Char8 as BSL-import qualified Data.HashMap.Strict as HM-import qualified Data.HashSet as HS+import qualified Data.ByteString.Lazy.Char8 as BSL+import qualified Data.HashMap.Strict as HM+import qualified Data.HashSet as HS import Data.List-import qualified Data.Text as T-import qualified Data.Vector as V+import qualified Data.Text as T+import qualified Data.Vector as V import GHC.Exts -import Data.Aeson (ToJSON, encode)+import Data.Aeson (ToJSON, encode)+import Text.PrettyPrint.ANSI.Leijen ((<$>))+import Prelude hiding ((<$>)) containerComma'' :: Pretty a => [(Doc, a)] -> Doc containerComma'' x = indent 2 ins@@ -55,7 +57,7 @@ pretty (RIdentifier t n) = pretty (PResourceReference t n) meta :: Resource -> Doc-meta r = showPPos (r ^. rpos) <+> (green (node <+> brackets scp) )+meta r = showPPos (r ^. rpos) <+> green (node <+> brackets scp) where node = red (ttext (r ^. rnode)) scp = "Scope" <+> pretty (r ^.. rscope . folded . filtered (/=ContRoot) . to pretty)@@ -148,6 +150,7 @@ pretty (ReadFile f) = pf "ReadFile" (map ttext f) pretty (TraceEvent e) = pf "TraceEvent" [string e] pretty (IsIgnoredModule m) = pf "IsIgnoredModule" [ttext m]+ pretty (IsExternalModule m) = pf "IsExternalModule" [ttext m] instance Pretty LinkInformation where pretty (LinkInformation lsrc ldst ltype lpos) = pretty lsrc <+> pretty ltype <+> pretty ldst <+> showPPos lpos
Puppet/Interpreter/Pure.hs view
@@ -21,6 +21,7 @@ import qualified Data.HashMap.Strict as HM import Data.Monoid import qualified Data.Text as T+import Prelude -- | Worst name ever, this is a set of pure stub for the 'ImpureMethods' -- type.@@ -31,7 +32,7 @@ -- templates, and that can include only the supplied top level statements. pureReader :: HM.HashMap (TopLevelType, T.Text) Statement -- ^ A top-level statement map -> InterpreterReader Identity-pureReader sttmap = InterpreterReader baseNativeTypes getstatementdummy templatedummy dummyPuppetDB mempty "dummy" hieradummy impurePure mempty True+pureReader sttmap = InterpreterReader baseNativeTypes getstatementdummy templatedummy dummyPuppetDB mempty "dummy" hieradummy impurePure mempty mempty True where templatedummy (Right _) _ _ = return (S.Left "Can't interpret files") templatedummy (Left cnt) ctx scope =@@ -57,7 +58,7 @@ -- | A bunch of facts that can be used for pure evaluation. dummyFacts :: Facts-dummyFacts = HM.fromList $+dummyFacts = HM.fromList [ ("architecture", "amd64") , ("augeasversion", "0.10.0") , ("bios_release_date", "07/06/2010")
Puppet/Interpreter/Resolve.hs view
@@ -35,10 +35,7 @@ import Puppet.PP import Puppet.Utils -import Data.Version (parseVersion)-import Text.ParserCombinators.ReadP (readP_to_S)--import Control.Applicative hiding ((<$>))+import Control.Applicative import Control.Lens import Control.Monad import Control.Monad.Operational (singleton)@@ -59,7 +56,11 @@ import qualified Data.Text.Encoding as T import Data.Tuple.Strict as S import qualified Data.Vector as V+import Data.Version (parseVersion)+import Text.ParserCombinators.ReadP (readP_to_S)+import qualified Text.PrettyPrint.ANSI.Leijen as PP import Text.Regex.PCRE.ByteString.Utils+import Prelude -- | A useful type that is used when trying to perform arithmetic on Puppet -- numbers.@@ -137,9 +138,7 @@ scps <- use scopes scp <- getScopeName case getVariable scps scp fullvar of- Left rr -> ifStrict- (throwPosError rr)- (warn ("The variable" <+> pretty (UVariableReference fullvar) <+> "was not resolved" <+> pretty PUndef <+> "returned") >> return PUndef)+ Left rr -> throwPosError rr Right x -> return x -- | A simple helper that checks if a given type is native or a define.@@ -300,7 +299,7 @@ unless (S.isNothing (hf ^. hfexpr)) (throwPosError ("You can't combine chains of higher order functions (with .) and giving them parameters, in:" <+> pretty a)) resolveValue (UHFunctionCall (hf & hfexpr .~ S.Just e)) resolveExpression (FunctionApplication _ x) = throwPosError ("Expected function application here, not" <+> pretty x)-resolveExpression x = throwPosError ("Don't know how to resolve this expression:" <$> pretty x)+resolveExpression x = throwPosError ("Don't know how to resolve this expression:" PP.<$> pretty x) -- | Resolves an 'UValue' (terminal for the 'Expression' data type) into -- a 'PValue'@@ -335,13 +334,13 @@ "Resolving the keyword `undef` to the string \"undef\"" "Strict mode won't convert the keyword `undef` to the string \"undef\"" return "undef"-resolvePValueString x = throwPosError ("Don't know how to convert this to a string:" <$> pretty x)+resolvePValueString x = throwPosError ("Don't know how to convert this to a string:" PP.<$> pretty x) -- | Turns everything it can into a number, or throws an error resolvePValueNumber :: PValue -> InterpreterMonad Scientific resolvePValueNumber x = case x ^? _Number of Just n -> return n- Nothing -> throwPosError ("Don't know how to convert this to a number:" <$> pretty x)+ Nothing -> throwPosError ("Don't know how to convert this to a number:" PP.<$> pretty x) -- | > resolveExpressionString = resolveExpression >=> resolvePValueString resolveExpressionString :: Expression -> InterpreterMonad T.Text@@ -395,13 +394,16 @@ resolveFunction' :: T.Text -> [PValue] -> InterpreterMonad PValue resolveFunction' "defined" [PResourceReference "class" cn] = do- checkStrict "The 'defined' function should not be used." "The 'defined' function is not allowed in strict mode."+ checkStrict "The use of the 'defined' function is a code smell"+ "The 'defined' function is not allowed in strict mode." fmap (PBoolean . has (ix cn)) (use loadedClasses) resolveFunction' "defined" [PResourceReference rt rn] = do- checkStrict "The 'defined' function should not be used." "The 'defined' function is not allowed in strict mode."+ checkStrict "The use of the 'defined' function is a code smell"+ "The 'defined' function is not allowed in strict mode." fmap (PBoolean . has (ix (RIdentifier rt rn))) (use definedResources) resolveFunction' "defined" [ut] = do- checkStrict "The 'defined' function should not be used." "The 'defined' function is not allowed in strict mode."+ checkStrict "The use of the 'defined' function is a code smell."+ "The 'defined' function is not allowed in strict mode." t <- resolvePValueString ut -- case 1, netsted thingie nestedStuff <- use nestedDeclarations
Puppet/Interpreter/Types.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE AutoDeriveTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}@@ -82,7 +83,6 @@ , getCurContainer , text2Scientific , safeDecodeUtf8- , ifStrict , getScope , getScopeName , scopeName@@ -104,17 +104,14 @@ , eitherDocIO ) where -import Puppet.Parser.PrettyPrinter-import Puppet.Parser.Types-import Puppet.Stats- import Control.Applicative hiding (empty) import Control.Concurrent.MVar (MVar) import Control.Exception import Control.Lens-import Control.Monad.Error+import Control.Monad.Except import Control.Monad.Operational import Control.Monad.State.Strict+import Control.Monad.Trans.Either import Control.Monad.Writer.Class import Data.Aeson as A import Data.Aeson.Lens@@ -136,14 +133,20 @@ import qualified Data.Traversable as TR import Data.Tuple.Strict import qualified Data.Vector as V-import Foreign.Ruby+import Foreign.Ruby.Helpers import GHC.Generics hiding (to) import GHC.Stack import qualified Scripting.Lua as Lua-import System.Log.Logger+import Servant.Common.Text+import qualified System.Log.Logger as LOG import Text.Parsec.Pos import Text.PrettyPrint.ANSI.Leijen hiding (rational, (<$>))+import Prelude +import Puppet.Parser.PrettyPrinter+import Puppet.Parser.Types+import Puppet.Stats+ metaparameters :: HS.HashSet T.Text metaparameters = HS.fromList ["tag","stage","name","title","alias","audit","check","loglevel","noop","schedule", "EXPORTEDSOURCE", "require", "before", "register", "notify"] @@ -163,13 +166,20 @@ instance IsString PrettyError where fromString = PrettyError . string +instance Exception PrettyError+ -- | The intepreter can run in two modes : a strict mode (recommended), and -- a permissive mode. The permissive mode let known antipatterns work with -- the interpreter. data Strictness = Strict | Permissive deriving (Show, Eq) +instance FromJSON Strictness where+ parseJSON (Bool True) = pure Strict+ parseJSON (Bool False) = pure Permissive+ parseJSON _ = mzero + data PValue = PBoolean !Bool | PUndef | PString !T.Text -- integers and doubles are internally serialized as strings by puppet@@ -237,7 +247,7 @@ | ContDefine !T.Text !T.Text !PPosition -- ^ Contained in a define, along with the position where this define was ... defined | ContImported !CurContainerDesc -- ^ Dummy container for imported resources, so that we know we must update the nodename | ContImport !Nodename !CurContainerDesc -- ^ This one is used when finalizing imported resources, and contains the current node name- deriving (Eq, Generic, Ord)+ deriving (Eq, Generic, Ord, Show) data CurContainer = CurContainer { _cctype :: !CurContainerDesc@@ -280,6 +290,7 @@ , _hieraQuery :: HieraQueryFunc m , _ioMethods :: ImpureMethods m , _ignoredModules :: HS.HashSet T.Text+ , _externalModules :: HS.HashSet T.Text , _isStrict :: Bool } @@ -300,6 +311,7 @@ HieraQuery :: Container T.Text -> T.Text -> HieraQueryType -> InterpreterInstr (Maybe PValue) GetCurrentCallStack :: InterpreterInstr [String] IsIgnoredModule :: T.Text -> InterpreterInstr Bool+ IsExternalModule :: T.Text -> InterpreterInstr Bool IsStrict :: InterpreterInstr Bool -- error ErrorThrow :: PrettyError -> InterpreterInstr a@@ -326,16 +338,16 @@ CallLua :: MVar Lua.LuaState -> T.Text -> [PValue] -> InterpreterInstr PValue -type InterpreterLog = Pair Priority Doc+type InterpreterLog = Pair LOG.Priority Doc type InterpreterWriter = [InterpreterLog] warn :: (Monad m, MonadWriter InterpreterWriter m) => Doc -> m ()-warn d = tell [WARNING :!: d]+warn d = tell [LOG.WARNING :!: d] debug :: (Monad m, MonadWriter InterpreterWriter m) => Doc -> m ()-debug d = tell [DEBUG :!: d]+debug d = tell [LOG.DEBUG :!: d] -logWriter :: (Monad m, MonadWriter InterpreterWriter m) => Priority -> Doc -> m ()+logWriter :: (Monad m, MonadWriter InterpreterWriter m) => LOG.Priority -> Doc -> m () logWriter prio d = tell [prio :!: d] -- | The main monad@@ -350,10 +362,6 @@ pass = singleton . WriterPass listen = singleton . WriterListen -instance Error PrettyError where- noMsg = PrettyError empty- strMsg = PrettyError . text- data RIdentifier = RIdentifier { _itype :: !T.Text , _iname :: !T.Text@@ -453,14 +461,14 @@ data PuppetDBAPI m = PuppetDBAPI { pdbInformation :: m Doc- , replaceCatalog :: WireCatalog -> m (S.Either PrettyError ()) -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/commands.html#replace-catalog-version-3>- , replaceFacts :: [(Nodename, Facts)] -> m (S.Either PrettyError ()) -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/commands.html#replace-facts-version-1>- , deactivateNode :: Nodename -> m (S.Either PrettyError ()) -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/commands.html#deactivate-node-version-1>- , getFacts :: Query FactField -> m (S.Either PrettyError [PFactInfo]) -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/query/v3/facts.html#get-v3facts>- , getResources :: Query ResourceField -> m (S.Either PrettyError [Resource]) -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/query/v3/resources.html#get-v3resources>- , getNodes :: Query NodeField -> m (S.Either PrettyError [PNodeInfo])- , commitDB :: m (S.Either PrettyError ()) -- ^ This is only here to tell the test PuppetDB to save its content to disk.- , getResourcesOfNode :: Nodename -> Query ResourceField -> m (S.Either PrettyError [Resource])+ , replaceCatalog :: WireCatalog -> EitherT PrettyError m () -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/commands.html#replace-catalog-version-3>+ , replaceFacts :: [(Nodename, Facts)] -> EitherT PrettyError m () -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/commands.html#replace-facts-version-1>+ , deactivateNode :: Nodename -> EitherT PrettyError m () -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/commands.html#deactivate-node-version-1>+ , getFacts :: Query FactField -> EitherT PrettyError m [PFactInfo] -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/query/v3/facts.html#get-v3facts>+ , getResources :: Query ResourceField -> EitherT PrettyError m [Resource] -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/query/v3/resources.html#get-v3resources>+ , getNodes :: Query NodeField -> EitherT PrettyError m [PNodeInfo]+ , commitDB :: EitherT PrettyError m () -- ^ This is only here to tell the test PuppetDB to save its content to disk.+ , getResourcesOfNode :: Nodename -> Query ResourceField -> EitherT PrettyError m [Resource] } -- | Pretty straightforward way to define the various PuppetDB queries@@ -575,11 +583,12 @@ instance ToRuby PValue where toRuby = toRuby . toJSON instance FromRuby PValue where- fromRuby v = fromRuby v >>= \case- Nothing -> return Nothing- Just x -> case fromJSON x of- Error _ -> return Nothing- Success suc -> return (Just suc)+ fromRuby = fmap chk . fromRuby+ where+ chk (Left x) = Left x+ chk (Right x) = case fromJSON x of+ Error rr -> Left rr+ Success suc -> Right suc eitherDocIO :: IO (S.Either PrettyError a) -> IO (S.Either PrettyError a) eitherDocIO computation = (computation >>= check) `catch` (\e -> return $ S.Left $ PrettyError $ dullred $ text $ show (e :: SomeException))@@ -641,7 +650,7 @@ , ("aliases", toJSON $ r ^. ralias) , ("exported", Bool $ r ^. rvirtuality == Exported) , ("tags", toJSON $ r ^. rtags)- , ("parameters", Object ( (HM.map toJSON $ r ^. rattributes) `HM.union` relations ))+ , ("parameters", Object ( HM.map toJSON (r ^. rattributes) `HM.union` relations )) , ("sourceline", r ^. rpos . _1 . to sourceLine . to toJSON) , ("sourcefile", r ^. rpos . _1 . to sourceName . to toJSON) ]@@ -703,6 +712,9 @@ toJSON (QGE flds val) = toJSON [ ">=", toJSON flds, toJSON val ] toJSON (QEmpty) = Null +instance ToJSON a => ToText (Query a) where+ toText = T.decodeUtf8 . Control.Lens.view strict . encode+ instance FromJSON a => FromJSON (Query a) where parseJSON Null = pure QEmpty parseJSON (Array elems) = case V.toList elems of@@ -849,19 +861,25 @@ dummypos = initialPPos "dummy" -- | Throws an error if we are in strict mode+-- A warning in permissive mode checkStrict :: Doc -- ^ The warning message. -> Doc -- ^ The error message. -> InterpreterMonad () checkStrict wrn err = do+ extMod <- isExternalModule+ let priority = if extMod then LOG.NOTICE else LOG.WARNING str <- singleton IsStrict- if str+ if str && not extMod then throwPosError err- else warn wrn+ else do+ srcname <- use (curPos._1.lSourceName)+ logWriter priority (wrn <+> "at" <+> string srcname) --- | Runs operations depending on the strict flag.-ifStrict :: InterpreterMonad a -- ^ This operation will be run in strict mode.- -> InterpreterMonad a -- ^ This operation will be run in permissive mode.- -> InterpreterMonad a-ifStrict yes no = do- str <- singleton IsStrict- if str then yes else no+isExternalModule :: InterpreterMonad Bool+isExternalModule =+ getScope >>= \case+ ContClass n -> isExternal n+ ContDefine n _ _ -> isExternal n+ _ -> return False+ where+ isExternal = singleton . IsExternalModule . head . T.splitOn "::"
Puppet/Lens.hs view
@@ -66,6 +66,8 @@ , _ConditionalValue , _FunctionApplication , _Terminal+ -- * Prisms for exceptions+ , _PrettyError ) where import Control.Lens@@ -85,6 +87,8 @@ import qualified Data.Maybe.Strict as S import Data.Tuple.Strict hiding (uncurry) import Text.Parser.Combinators (eof)+import Control.Exception (SomeException, toException, fromException)+import Prelude -- Prisms makePrisms ''PValue@@ -103,6 +107,10 @@ makePrisms ''SFC makePrisms ''RColl makePrisms ''Dep+++_PrettyError :: Prism' SomeException PrettyError+_PrettyError = prism' toException fromException _ResourceDeclaration' :: Prism' Statement ResDec _ResourceDeclaration' = prism ResourceDeclaration $ \x -> case x of
Puppet/Manifests.hs view
@@ -1,4 +1,6 @@ {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-} module Puppet.Manifests (filterStatements) where import Puppet.PP@@ -8,7 +10,7 @@ import Text.Regex.PCRE.ByteString.Utils import Control.Lens import Control.Applicative-import Control.Monad.Error+import Control.Monad.Except import qualified Data.Vector as V import qualified Data.Text as T import qualified Data.Text.Encoding as T@@ -27,7 +29,7 @@ triage curstuff n@(Node (Nd NodeDefault _ _ _)) = curstuff & _4 ?~ n triage curstuff x = curstuff & _1 %~ (|> x) bsnodename = T.encodeUtf8 ndename- checkRegexp :: [Pair Regex Statement] -> ErrorT PrettyError IO (Maybe Statement)+ checkRegexp :: [Pair Regex Statement] -> ExceptT PrettyError IO (Maybe Statement) checkRegexp [] = return Nothing checkRegexp ((regexp :!: s):xs) = case execute' regexp bsnodename of@@ -38,7 +40,7 @@ strictEither (Right x) = S.Right x in case directnodes ^. at ndename of -- check if there is a node specifically called after my name Just r -> return (S.Right (TopContainer spurious r))- Nothing -> fmap strictEither $ runErrorT $ do+ Nothing -> fmap strictEither $ runExceptT $ do regexpMatchM <- checkRegexp (V.toList regexpmatches) -- match regexps case regexpMatchM <|> defaultnode of -- check for regexp matches or use the default node Just r -> return (TopContainer spurious r)
Puppet/NativeTypes.hs view
@@ -6,7 +6,7 @@ import Control.Lens import Control.Monad.Operational-import qualified Data.HashMap.Strict as HM+import qualified Data.HashMap.Strict as HM import Puppet.Interpreter.Types import Puppet.NativeTypes.Concat@@ -17,6 +17,7 @@ import Puppet.NativeTypes.Helpers import Puppet.NativeTypes.Host import Puppet.NativeTypes.Mount+import Puppet.NativeTypes.Notify import Puppet.NativeTypes.Package import Puppet.NativeTypes.SshSecure import Puppet.NativeTypes.User@@ -26,23 +27,24 @@ fakeTypes = map faketype ["class"] defaultTypes :: [(NativeTypeName, NativeTypeMethods)]-defaultTypes = map defaulttype ["augeas","computer","filebucket","interface","k5login","macauthorization","mailalias","maillist","mcx","nagios_command","nagios_contact","nagios_contactgroup","nagios_host","nagios_hostdependency","nagios_hostescalation","nagios_hostextinfo","nagios_hostgroup","nagios_service","nagios_servicedependency","nagios_serviceescalation","nagios_serviceextinfo","nagios_servicegroup","nagios_timeperiod","notify","package","resources","router","schedule","scheduledtask","selboolean","selmodule","service","ssh_authorized_key","sshkey","stage","tidy","vlan","yumrepo","zfs","zone","zpool"]+defaultTypes = map defaulttype ["augeas","computer","filebucket","interface","k5login","macauthorization","mailalias","maillist","mcx","nagios_command","nagios_contact","nagios_contactgroup","nagios_host","nagios_hostdependency","nagios_hostescalation","nagios_hostextinfo","nagios_hostgroup","nagios_service","nagios_servicedependency","nagios_serviceescalation","nagios_serviceextinfo","nagios_servicegroup","nagios_timeperiod","resources","router","schedule","scheduledtask","selboolean","selmodule","service","ssh_authorized_key","sshkey","stage","tidy","vlan","yumrepo","zfs","zone","zpool"] -- | The map of native types. They are described in "Puppet.NativeTypes.Helpers". baseNativeTypes :: Container NativeTypeMethods baseNativeTypes = HM.fromList- ( nativeHost- : nativeMount- : nativeGroup- : nativeFile- : nativeZoneRecord+ ( nativeConcat+ : nativeConcatFragment : nativeCron : nativeExec+ : nativeFile+ : nativeGroup+ : nativeHost+ : nativeMount+ : nativeNotify : nativePackage- : nativeUser : nativeSshSecure- : nativeConcat- : nativeConcatFragment+ : nativeUser+ : nativeZoneRecord : fakeTypes ++ defaultTypes) -- | Contrary to the previous iteration, this will let non native types pass.
Puppet/NativeTypes/File.hs view
@@ -1,17 +1,19 @@ module Puppet.NativeTypes.File (nativeFile) where -import Puppet.NativeTypes.Helpers hiding ((<$>))-import Control.Monad.Error-import Puppet.Interpreter.Types-import Data.Char (isDigit)-import qualified Data.Text as T-import Control.Lens-import Control.Applicative-import qualified Data.Map.Strict as M-import qualified Data.Set as S-import Data.Monoid-import qualified Data.Attoparsec.Text as AT+import Puppet.Interpreter.Types+import Puppet.NativeTypes.Helpers +import Control.Applicative+import Control.Lens+import Control.Monad.Except+import Control.Monad.Trans.Except+import qualified Data.Attoparsec.Text as AT+import Data.Char (isDigit)+import qualified Data.Map.Strict as M+import Data.Monoid+import qualified Data.Set as S+import qualified Data.Text as T+ nativeFile :: (NativeTypeName, NativeTypeMethods) nativeFile = ("file", nativetypemethods parameterfunctions (validateSourceOrContent >=> validateMode)) @@ -48,9 +50,9 @@ Just (PString s) -> return s Just x -> throwError $ PrettyError ("Invalide mode type, should be a string " <+> pretty x) Nothing -> throwError "Could not find mode!"- (numeric modestr <|> ugo modestr) & _Right %~ ($ res)+ (numeric modestr <|> except (ugo modestr)) & runExcept & _Right %~ ($ res) -numeric :: T.Text -> Either PrettyError (Resource -> Resource)+numeric :: T.Text -> Except PrettyError (Resource -> Resource) numeric modestr = do when ((T.length modestr /= 3) && (T.length modestr /= 4)) (throwError "Invalid mode size") unless (T.all isDigit modestr) (throwError "The mode should only be made of digits")
Puppet/NativeTypes/Helpers.hs view
@@ -32,20 +32,20 @@ , validateSourceOrContent ) where -import Puppet.PP hiding (string,integer)-import Puppet.Utils-import qualified Text.PrettyPrint.ANSI.Leijen as P-import Puppet.Interpreter.Types-import Puppet.Interpreter.PrettyPrinter()-import qualified Data.HashMap.Strict as HM-import qualified Data.HashSet as HS-import Data.Char (isDigit)-import Control.Monad-import qualified Data.Text as T-import Control.Lens-import qualified Data.Vector as V-import Data.Aeson.Lens (_Number,_Integer)-import Data.Maybe (fromMaybe)+import Control.Lens+import Control.Monad+import Data.Aeson.Lens (_Integer, _Number)+import Data.Char (isDigit)+import qualified Data.HashMap.Strict as HM+import qualified Data.HashSet as HS+import Data.Maybe (fromMaybe)+import qualified Data.Text as T+import qualified Data.Vector as V+import Puppet.Interpreter.PrettyPrinter ()+import Puppet.Interpreter.Types+import Puppet.PP hiding (integer, string)+import Puppet.Utils+import qualified Text.PrettyPrint.ANSI.Leijen as P type NativeTypeName = T.Text
+ Puppet/NativeTypes/Notify.hs view
@@ -0,0 +1,15 @@+module Puppet.NativeTypes.Notify (nativeNotify) where++import Puppet.Interpreter.Types+import Puppet.NativeTypes.Helpers++import qualified Data.Text as T++nativeNotify :: (NativeTypeName, NativeTypeMethods)+nativeNotify = ("notify", nativetypemethods parameterfunctions return)++parameterfunctions :: [(T.Text, [T.Text -> NativeTypeValidate])]+parameterfunctions =+ [("message" , [string])+ ,("withpath" , [string, defaultvalue "false", values ["true","false"]])+ ]
Puppet/NativeTypes/Package.hs view
@@ -3,7 +3,7 @@ import Puppet.NativeTypes.Helpers import Puppet.Interpreter.Types-import Control.Monad.Error+import Control.Monad.Except import qualified Data.HashSet as HS import qualified Data.HashMap.Strict as HM import qualified Data.Text as T@@ -60,7 +60,8 @@ [("adminfile" , [string, fullyQualified]) ,("allowcdrom" , [string, values ["true","false"]]) ,("configfiles" , [string, values ["keep","replace"]])- ,("ensure" , [defaultvalue "present", string, values ["present","absent","latest","held","purged","installed"]])+ --,("ensure" , [defaultvalue "present", string, values ["present","absent","latest","held","purged","installed"]])+ ,("ensure" , [defaultvalue "present", string]) ,("flavor" , []) ,("install_options" , [rarray]) ,("name" , [nameval])
Puppet/NativeTypes/SshSecure.hs view
@@ -2,7 +2,7 @@ import Puppet.NativeTypes.Helpers import Puppet.Interpreter.Types-import Control.Monad.Error+import Control.Monad.Except import qualified Data.Text as T import Control.Lens
Puppet/NativeTypes/ZoneRecord.hs view
@@ -2,7 +2,7 @@ import Puppet.NativeTypes.Helpers import Puppet.Interpreter.Types-import Control.Monad.Error+import Control.Monad.Except import qualified Data.Text as T import Control.Lens
Puppet/OptionalTests.hs view
@@ -1,30 +1,65 @@-{-# LANGUAGE LambdaCase #-}--- | The module works in IO and exits on failure.--- It is meant to be use by a `Daemon`.--- PS: if more flexibility is needed, we can `throwM`--- on failure and let the caller choose what to do.+{-# LANGUAGE LambdaCase #-}+-- | The module works in IO and throws a 'PrettyError' exception at each failure.+-- These exceptions can be caught (see the exceptions package). module Puppet.OptionalTests (testCatalog) where import Control.Applicative import Control.Lens import Control.Monad (unless)+import Control.Monad.Catch import Control.Monad.Trans (liftIO) import Control.Monad.Trans.Except-import Data.Foldable (asum, toList, elem, traverse_)+import Data.Foldable (asum, elem, toList,+ traverse_)+import qualified Data.HashSet as HS import Data.Maybe (mapMaybe) import Data.Monoid ((<>)) import qualified Data.Text as T import Prelude hiding (all, elem)+ import Puppet.Interpreter.PrettyPrinter () import Puppet.Interpreter.Types-import Puppet.PP hiding ((<$>))-import System.Exit (exitFailure)+import Puppet.Lens (_PString)+import Puppet.PP+import Puppet.Preferences import System.Posix.Files + -- | Entry point for all optional tests-testCatalog :: FilePath -> FinalCatalog -> IO ()-testCatalog = testFileSources+testCatalog :: Preferences IO -> FinalCatalog -> IO ()+testCatalog prefs c = testFileSources (prefs^.puppetPaths.baseDir) c >> testUsersGroups (prefs^.knownusers) (prefs^.knowngroups) c +-- | Tests that all users and groups are defined+testUsersGroups :: [T.Text] -> [T.Text] -> FinalCatalog -> IO ()+testUsersGroups kusers kgroups c = do+ let users = HS.fromList $ "" : map (view (rid . iname)) (getResourceFrom "user") ++ kusers+ groups = HS.fromList $ "" : map (view (rid . iname)) (getResourceFrom "group") ++ kgroups+ checkResource lu lg = mapM_ (checkResource' lu lg)+ checkResource' lu lg res = do+ let msg att name = align (vsep [ "Resource" <+> ttext (res^.rid.itype)+ <+> ttext (res^.rid.iname) <+> showPos (res^.rpos._1)+ , "reference the unknown" <+> string att <+> squotes (ttext name)])+ <> line+ case lu of+ Just lu' -> do+ let u = res ^. rattributes . lu' . _PString+ unless (HS.member u users) $ throwM $ PrettyError (msg "user" u)+ Nothing -> pure ()+ case lg of+ Just lg' -> do+ let g = res ^. rattributes . lg' . _PString+ unless (HS.member g groups) $ throwM $ PrettyError (msg "group" g)+ Nothing -> pure ()+ do+ checkResource (Just $ ix "owner") (Just $ ix "group") (getResourceFrom "file")+ checkResource (Just $ ix "user") (Just $ ix "group") (getResourceFrom "exec")+ checkResource (Just $ ix "user") Nothing (getResourceFrom "cron")+ checkResource (Just $ ix "user") Nothing (getResourceFrom "ssh_authorized_key")+ checkResource (Just $ ix "user") Nothing (getResourceFrom "ssh_authorized_key_secure")+ checkResource Nothing (Just $ ix "gid") (getResourceFrom "users")+ where+ getResourceFrom t = c ^.. traverse . filtered (\r -> r ^. rid . itype == t && r ^. rattributes . at "ensure" /= Just "absent")+ -- | Test source for every file resources in the catalog. testFileSources :: FilePath -> FinalCatalog -> IO () testFileSources basedir c = do@@ -45,9 +80,7 @@ Left err -> go xs ((PrettyError $ "Could not find " <+> pretty filesource <> semi <+> align (vsep [getError err, showPos (res^.rpos^._1)])):es) go [] [] = pure ()- go [] es = do- traverse_ (\e -> putDoc $ getError e <> line) es- exitFailure+ go [] es = traverse_ throwM es testFile :: FilePath -> ExceptT PrettyError IO () testFile fp = do
Puppet/PP.hs view
@@ -7,8 +7,8 @@ , module Text.PrettyPrint.ANSI.Leijen ) where -import Text.PrettyPrint.ANSI.Leijen hiding ((<>))-import qualified Data.Text as T+import qualified Data.Text as T+import Text.PrettyPrint.ANSI.Leijen hiding ((<$>), (<>)) ttext :: T.Text -> Doc ttext = text . T.unpack
Puppet/Parser/PrettyPrinter.hs view
@@ -1,14 +1,16 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Puppet.Parser.PrettyPrinter where -import Puppet.PP-import Puppet.Parser.Types-import Puppet.Utils-import qualified Data.Vector as V-import qualified Data.Text as T-import Data.Tuple.Strict (Pair ( (:!:) ))-import qualified Data.Tuple.Strict as S-import qualified Data.Maybe.Strict as S+import qualified Data.Maybe.Strict as S+import qualified Data.Text as T+import Data.Tuple.Strict (Pair ((:!:)))+import qualified Data.Tuple.Strict as S+import qualified Data.Vector as V+import Puppet.Parser.Types+import Puppet.PP+import Puppet.Utils+import Text.PrettyPrint.ANSI.Leijen ((<$>))+import Prelude hiding ((<$>)) capitalize :: T.Text -> Doc capitalize = dullyellow . text . T.unpack . capitalizeRT
Puppet/Plugins.hs view
@@ -38,7 +38,7 @@ import qualified Data.Text.IO as T import qualified Data.Vector as V import Control.Concurrent-import Control.Monad.Error+import Control.Monad.Except import Control.Monad.Operational (singleton) import Data.Scientific @@ -55,8 +55,7 @@ push l (PUndef) = Lua.push l ("undefined" :: T.Text) push l (PNumber b) = Lua.push l (fromRational (toRational b) :: Double) - peek l n = do- Lua.ltype l n >>= \case+ peek l n = Lua.ltype l n >>= \case Lua.TBOOLEAN -> fmap (fmap PBoolean) (Lua.peek l n) Lua.TSTRING -> fmap (fmap PString) (Lua.peek l n) Lua.TNUMBER -> fmap (fmap (PNumber . fromFloatDigits)) (Lua.peek l n :: IO (Maybe Double))
Puppet/Preferences.hs view
@@ -1,14 +1,28 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TemplateHaskell #-} module Puppet.Preferences (- setupPreferences+ dfPreferences , HasPreferences(..) , Preferences(Preferences)+ , PuppetDirPaths , HasPuppetDirPaths(..) ) where +import Control.Applicative+import Control.Lens+import Control.Monad (mzero)+import Data.Aeson+import qualified Data.HashMap.Strict as HM+import qualified Data.HashSet as HS+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import qualified Data.Text as T+import System.Posix (fileExist)+import Prelude+ import Puppet.Interpreter.Types import Puppet.NativeTypes import Puppet.NativeTypes.Helpers@@ -17,49 +31,104 @@ import Puppet.Utils import PuppetDB.Dummy -import Control.Lens-import qualified Data.HashMap.Strict as HM-import qualified Data.HashSet as HS-import qualified Data.Text as T- data PuppetDirPaths = PuppetDirPaths { _baseDir :: FilePath -- ^ Puppet base working directory , _manifestPath :: FilePath -- ^ The path to the manifests. , _modulesPath :: FilePath -- ^ The path to the modules. , _templatesPath :: FilePath -- ^ The path to the template.+ , _testPath :: FilePath -- ^ The path to a tests folders to hold tests files such as the pdbfiles. } makeClassy ''PuppetDirPaths data Preferences m = Preferences- { _puppetPaths :: PuppetDirPaths- , _prefPDB :: PuppetDBAPI m- , _natTypes :: Container NativeTypeMethods -- ^ The list of native types.- , _prefExtFuncs :: Container ( [PValue] -> InterpreterMonad PValue )- , _hieraPath :: Maybe FilePath- , _ignoredmodules :: HS.HashSet T.Text -- ^ The set of ignored modules- , _strictness :: Strictness- , _extraTests :: Bool+ { _puppetPaths :: PuppetDirPaths+ , _prefPDB :: PuppetDBAPI m+ , _natTypes :: Container NativeTypeMethods -- ^ The list of native types.+ , _prefExtFuncs :: Container ( [PValue] -> InterpreterMonad PValue )+ , _hieraPath :: Maybe FilePath+ , _ignoredmodules :: HS.HashSet Text+ , _strictness :: Strictness+ , _extraTests :: Bool+ , _knownusers :: [Text]+ , _knowngroups :: [Text]+ , _externalmodules :: HS.HashSet Text } +data Defaults = Defaults+ { _dfKnownusers :: Maybe [Text]+ , _dfKnowngroups :: Maybe [Text]+ , _dfIgnoredmodules :: Maybe [Text]+ , _dfStrictness :: Maybe Strictness+ , _dfExtratests :: Maybe Bool+ , _dfExternalmodules :: Maybe [Text]+ } deriving Show++ makeClassy ''Preferences -genPreferences :: FilePath+instance FromJSON Defaults where+ parseJSON (Object v) = Defaults+ <$> v .:? "knownusers"+ <*> v .:? "knowngroups"+ <*> v .:? "ignoredmodules"+ <*> v .:? "strict"+ <*> v .:? "extratests"+ <*> v .:? "externalmodules"+ parseJSON _ = mzero++-- | generate default preferences+dfPreferences :: FilePath -> IO (Preferences IO)-genPreferences basedir = do+dfPreferences basedir = do let manifestdir = basedir <> "/manifests" modulesdir = basedir <> "/modules" templatedir = basedir <> "/templates"+ testdir = basedir <> "/tests" typenames <- fmap (map takeBaseName) (getFiles (T.pack modulesdir) "lib/puppet/type" ".rb")+ defaults <- loadDefaults (testdir ++ "/defaults.yaml") let loadedTypes = HM.fromList (map defaulttype typenames)- return $ Preferences (PuppetDirPaths basedir manifestdir modulesdir templatedir) dummyPuppetDB (baseNativeTypes `HM.union` loadedTypes) (stdlibFunctions) (Just (basedir <> "/hiera.yaml")) mempty Strict True+ return $ Preferences (PuppetDirPaths basedir manifestdir modulesdir templatedir testdir)+ dummyPuppetDB (baseNativeTypes `HM.union` loadedTypes)+ stdlibFunctions+ (Just (basedir <> "/hiera.yaml"))+ (getIgnoredmodules defaults)+ (getStrictness defaults)+ (getExtraTests defaults)+ (getKnownusers defaults)+ (getKnowngroups defaults)+ (getExternalmodules defaults) -{-| Use lens with the set operator and composition to set external/custom params. -Ex.: @ setupPreferences workingDir ((hieraPath.~mypath) . (prefPDB.~pdbapi)) @--}-setupPreferences :: FilePath -- ^ The base working directory- -> (Preferences IO -> Preferences IO) -- ^ Preference setting- -> IO (Preferences IO)-setupPreferences basedir k =- fmap k (genPreferences basedir)+loadDefaults :: FilePath -> IO (Maybe Defaults)+loadDefaults fp = do+ p <- fileExist fp+ if p then loadYamlFile fp else return Nothing++-- Utilities for getting default values from the yaml file+-- It provides (the same) static defaults (see the 'Nothing' case) when+-- no default yaml file or+-- not key/value for the option has been provided+getKnownusers :: Maybe Defaults -> [Text]+getKnownusers (Just df) = fromMaybe (getKnownusers Nothing) (_dfKnownusers df)+getKnownusers Nothing = ["mysql", "vagrant","nginx", "nagios", "postgres", "puppet", "root", "syslog", "www-data"]++getKnowngroups :: Maybe Defaults -> [Text]+getKnowngroups (Just df) = fromMaybe (getKnowngroups Nothing) (_dfKnowngroups df)+getKnowngroups Nothing = ["adm", "syslog", "mysql", "nagios","postgres", "puppet", "root", "www-data"]++getStrictness :: Maybe Defaults -> Strictness+getStrictness (Just df) = fromMaybe (getStrictness Nothing) (_dfStrictness df)+getStrictness Nothing = Permissive++getIgnoredmodules :: Maybe Defaults -> HS.HashSet Text+getIgnoredmodules (Just df) = maybe (getIgnoredmodules Nothing) HS.fromList (_dfIgnoredmodules df)+getIgnoredmodules Nothing = mempty++getExtraTests :: Maybe Defaults -> Bool+getExtraTests (Just df) = fromMaybe (getExtraTests Nothing) (_dfExtratests df)+getExtraTests Nothing = True++getExternalmodules :: Maybe Defaults -> HS.HashSet Text+getExternalmodules (Just df) = maybe (getExternalmodules Nothing) HS.fromList (_dfExternalmodules df)+getExternalmodules Nothing = mempty
Puppet/Stdlib.hs view
@@ -1,24 +1,25 @@ {-# LANGUAGE LambdaCase #-} module Puppet.Stdlib (stdlibFunctions) where -import Puppet.PP-import Puppet.Interpreter.Resolve-import Puppet.Interpreter.Types+import Puppet.Interpreter.Resolve+import Puppet.Interpreter.Types+import Puppet.PP -import Control.Lens-import Data.Aeson.Lens-import Puppet.Lens-import Data.Char-import Data.Monoid-import Control.Monad-import Data.Vector.Lens (toVectorOf)-import Text.Regex.PCRE.ByteString.Utils-import Data.Traversable (for)-import qualified Data.Vector as V-import qualified Data.HashMap.Strict as HM-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import qualified Data.ByteString.Base16 as B16+import Control.Lens+import Control.Monad+import Data.Aeson.Lens+import qualified Data.ByteString.Base16 as B16+import Data.Char+import qualified Data.HashMap.Strict as HM+import Data.Monoid+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Data.Traversable (for)+import qualified Data.Vector as V+import Data.Vector.Lens (toVectorOf)+import Puppet.Lens+import qualified Text.PrettyPrint.ANSI.Leijen as PP+import Text.Regex.PCRE.ByteString.Utils -- | Contains the implementation of the StdLib functions. stdlibFunctions :: Container ( [PValue] -> InterpreterMonad PValue )@@ -324,7 +325,7 @@ rest <- mapM (resolvePValueString >=> compileRE >=> flip matchRE rstr) (V.toList v) if or rest then return PUndef- else throwPosError (pretty msg <$> "Source string:" <+> pretty str <> comma <+> "regexps:" <+> pretty (V.toList v))+ else throwPosError (pretty msg PP.<$> "Source string:" <+> pretty str <> comma <+> "regexps:" <+> pretty (V.toList v)) validateRe [_, r, _] = throwPosError ("validate_re(): expected a regexp or an array of regexps, but not" <+> pretty r) validateRe _ = throwPosError "validate_re(): wrong number of arguments (#{args.length}; must be 2 or 3)"
Puppet/Utils.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE LambdaCase #-} -- | Those are utility functions, most of them being pretty much self -- explanatory. module Puppet.Utils@@ -8,6 +9,7 @@ , takeDirectory , strictifyEither , nameThread+ , loadYamlFile , scientific2text ) where @@ -22,6 +24,7 @@ import Data.Scientific import Control.Lens import Data.Aeson.Lens+import qualified Data.Yaml as Y scientific2text :: Scientific -> T.Text scientific2text n = T.pack $ case n ^? _Integer of@@ -96,3 +99,8 @@ where (a,b) = T.break (=='/') $ T.reverse y +-- | Read a yaml file and throw a runtime error if the parsing fails+loadYamlFile :: Y.FromJSON a => FilePath -> IO a+loadYamlFile fp = Y.decodeFileEither fp >>= \case+ Left rr -> error ("Error when parsing " ++ fp ++ ": " ++ show rr)+ Right x -> return x
PuppetDB/Common.hs view
@@ -13,6 +13,7 @@ import System.Environment import qualified Data.Either.Strict as S import Data.Vector.Lens+import Servant.Common.BaseUrl -- | The supported PuppetDB implementations. data PDBType = PDBRemote -- ^ Your standard PuppetDB, queried through the HTTP interface.@@ -39,7 +40,8 @@ -- | Given a 'PDBType', will try return a sane default implementation. getDefaultDB :: PDBType -> IO (S.Either PrettyError (PuppetDBAPI IO)) getDefaultDB PDBDummy = return (S.Right dummyPuppetDB)-getDefaultDB PDBRemote = pdbConnect "http://localhost:8080"+getDefaultDB PDBRemote = let Right url = parseBaseUrl "http://localhost:8080"+ in pdbConnect url getDefaultDB PDBTest = lookupEnv "HOME" >>= \case Just h -> loadTestDB (h ++ "/.testdb") Nothing -> fmap S.Right initTestDB
PuppetDB/Dummy.hs view
@@ -3,17 +3,17 @@ module PuppetDB.Dummy where import Puppet.Interpreter.Types-import qualified Data.Either.Strict as S+import Control.Monad.Trans.Either dummyPuppetDB :: Monad m => PuppetDBAPI m dummyPuppetDB = PuppetDBAPI (return "dummy")- (const (return (S.Right () )))- (const (return (S.Right () )))- (const (return (S.Right () )))- (const (return (S.Left "not implemented")))- (const (return (S.Right [] )))- (const (return (S.Right [] )))- (return (S.Left "not implemented"))- (\_ _ -> return (S.Right [] ))+ (const (return ()))+ (const (return ()))+ (const (return ()))+ (const (left "not implemented"))+ (const (return [] ))+ (const (return [] ))+ (left "not implemented")+ (\_ _ -> return [] )
PuppetDB/Remote.hs view
@@ -1,60 +1,57 @@-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE OverloadedStrings #-} module PuppetDB.Remote (pdbConnect) where -import Puppet.Utils import Puppet.PP import Puppet.Interpreter.Types--import Network.HTTP.Conduit-import qualified Network.HTTP.Types as W-import qualified Data.ByteString.Lazy.Char8 as L-import qualified Data.ByteString.Char8 as BC-import Data.Aeson-import qualified Codec.Text.IConv as IConv-import qualified Control.Exception as X-import Control.Monad.Error-import qualified Data.Text as T-import qualified Data.Text.Encoding as T+import Data.Text (Text)+import Control.Monad.Trans.Either import qualified Data.Either.Strict as S+import Servant.API+import Servant.Client+import Servant.Common.Text+import Data.Aeson+import Data.Proxy -runRequest :: (Monad m, MonadIO m, FromJSON b, MonadError PrettyError m) => Request -> m b-runRequest req = do- let doRequest = withManager (fmap responseBody . httpLbs req) :: IO L.ByteString- eHandler :: X.SomeException -> IO (Either PrettyError L.ByteString)- eHandler e = return $ Left $ PrettyError $ string (show e) <> ", with queryString " <+> string (BC.unpack (queryString req))- liftIO (fmap Right doRequest `X.catch` eHandler) >>= \case- Right o -> do- let utf8 = IConv.convert "LATIN1" "UTF-8" o- case decode' utf8 of- Just x -> return x- Nothing -> throwError (PrettyError ("Json decoding has failed " <> string (show utf8)))- Left err -> throwError err+type PDBAPIv3 = "nodes" :> QueryParam "query" (Query NodeField) :> Get [PNodeInfo]+ :<|> "nodes" :> Capture "resourcename" Text :> "resources" :> QueryParam "query" (Query ResourceField) :> Get [Resource]+ :<|> "facts" :> QueryParam "query" (Query FactField) :> Get [PFactInfo]+ :<|> "resources" :> QueryParam "query" (Query ResourceField) :> Get [Resource] -pdbRequest :: (FromJSON a, ToJSON b) => T.Text -> T.Text -> b -> IO (S.Either PrettyError a)-pdbRequest url querytype query = fmap strictifyEither $ runErrorT $ do- let jsonquery = L.toStrict (encode query)- q = case toJSON query of- Null -> ""- _ -> T.decodeUtf8 $ "?" <> W.renderSimpleQuery False [("query", jsonquery)]- let fullurl = url <> "/v3/" <> querytype <> q- initReq <- case parseUrl (T.unpack fullurl) of- Right r -> return (r :: Request)- Left rr -> throwError (PrettyError ("Something failed when parsing the PuppetDB URL" <+> string (show rr)))- let req = initReq { requestHeaders = [("Accept", "application/json")] }- runRequest req+type PDBAPI = "v3" :> PDBAPIv3 +spdbAPI :: Proxy PDBAPI+spdbAPI = Proxy++sgetNodes :: Maybe (Query NodeField) -> BaseUrl -> EitherT String IO [PNodeInfo]+sgetNodeResources :: Text -> Maybe (Query ResourceField) -> BaseUrl -> EitherT String IO [Resource]+sgetFacts :: Maybe (Query FactField) -> BaseUrl -> EitherT String IO [PFactInfo]+sgetResources :: Maybe (Query ResourceField) -> BaseUrl -> EitherT String IO [Resource]+( sgetNodes+ :<|> sgetNodeResources+ :<|> sgetFacts+ :<|> sgetResources+ ) = client spdbAPI+ -- | Given an URL (ie. @http://localhost:8080@), will return an incomplete 'PuppetDBAPI'.-pdbConnect :: T.Text -> IO (S.Either PrettyError (PuppetDBAPI IO))+pdbConnect :: BaseUrl -> IO (S.Either PrettyError (PuppetDBAPI IO)) pdbConnect url = return $ S.Right $ PuppetDBAPI- (return (ttext url))- (const (return (S.Left "operation not supported")))- (const (return (S.Left "operation not supported")))- (const (return (S.Left "operation not supported")))- (pdbRequest url "facts")- (pdbRequest url "resources")- (pdbRequest url "nodes")- (return (S.Left "operation not supported"))- (\ndename -> pdbRequest url ("nodes/" <> ndename <> "/resources"))+ (return (string $ show url))+ (const (left "operation not supported"))+ (const (left "operation not supported"))+ (const (left "operation not supported"))+ (q1 sgetFacts)+ (q1 sgetResources)+ (q1 sgetNodes)+ (left "operation not supported")+ (\ndename q -> prettyError $ sgetNodeResources ndename (Just q) url)+ where+ prettyError :: EitherT String IO b -> EitherT PrettyError IO b+ prettyError = bimapEitherT (PrettyError . string) id+ q1 :: (ToText a, FromJSON b) => (Maybe a -> BaseUrl -> EitherT String IO b) -> a -> EitherT PrettyError IO b+ q1 f x = prettyError $ f (Just x) url
PuppetDB/TestDB.hs view
@@ -3,29 +3,37 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TemplateHaskell #-}+ -- | A stub implementation of PuppetDB, backed by a YAML file.-module PuppetDB.TestDB (loadTestDB,initTestDB) where+module PuppetDB.TestDB+ ( loadTestDB+ , initTestDB+) where import Control.Applicative import Control.Concurrent.STM import Control.Exception import Control.Lens+import Control.Monad.IO.Class+import Control.Monad.Trans.Either import Data.Aeson.Lens import Data.CaseInsensitive import qualified Data.Either.Strict as S import qualified Data.HashMap.Strict as HM import qualified Data.HashSet as HS import Data.List (foldl')+import qualified Data.Maybe.Strict as S import Data.Monoid import qualified Data.Text as T import qualified Data.Vector as V import Data.Yaml import Text.Parsec.Pos+import Prelude import Puppet.Interpreter.Types import Puppet.Lens import Puppet.Parser.Types-import Puppet.PP hiding ((<$>))+import Puppet.PP data DBContent = DBContent { _dbcontentResources :: Container WireCatalog@@ -85,7 +93,7 @@ | ESet (HS.HashSet T.Text) | ENil -resolveQuery :: (a -> b -> Extracted) -> Query a -> (b -> Bool)+resolveQuery :: (a -> b -> Extracted) -> Query a -> b -> Bool resolveQuery _ QEmpty = const True resolveQuery f (QEqual a t) = \v -> case f a v of EText tt -> mk tt == mk t@@ -107,29 +115,26 @@ Nothing -> return "TestDB" Just v -> return ("TestDB" <+> string v) -ncompare :: (Integer -> Integer -> Bool) -> (a -> b -> Extracted) -> a -> Integer -> (b -> Bool)+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 ^? _Integer of Just ii -> operation i ii _ -> False _ -> False -mustWork :: IO () -> IO (S.Either PrettyError ())-mustWork a = a >> return (S.Right ())--replCat :: DB -> WireCatalog -> IO (S.Either PrettyError ())-replCat db wc = mustWork $ atomically $ modifyTVar db (resources . at (wc ^. nodename) ?~ wc)+replCat :: DB -> WireCatalog -> EitherT PrettyError IO ()+replCat db wc = liftIO $ atomically $ modifyTVar db (resources . at (wc ^. nodename) ?~ wc) -replFacts :: DB -> [(Nodename, Facts)] -> IO (S.Either PrettyError ())-replFacts db lst = mustWork $ atomically $ modifyTVar db $+replFacts :: DB -> [(Nodename, Facts)] -> EitherT PrettyError IO ()+replFacts db lst = liftIO $ atomically $ modifyTVar db $ facts %~ (\r -> foldl' (\curr (n,f) -> curr & at n ?~ f) r lst) -deactivate :: DB -> Nodename -> IO (S.Either PrettyError ())-deactivate db n = mustWork $ atomically $ modifyTVar db $+deactivate :: DB -> Nodename -> EitherT PrettyError IO ()+deactivate db n = liftIO $ atomically $ modifyTVar db $ (resources . at n .~ Nothing) . (facts . at n .~ Nothing) -getFcts :: DB -> Query FactField -> IO (S.Either PrettyError [PFactInfo])-getFcts db f = fmap (S.Right . filter (resolveQuery factQuery f) . toFactInfo) (readTVarIO db)+getFcts :: DB -> Query FactField -> EitherT PrettyError IO [PFactInfo]+getFcts db f = fmap (filter (resolveQuery factQuery f) . toFactInfo) (liftIO $ readTVarIO db) where toFactInfo :: DBContent -> [PFactInfo] toFactInfo = concatMap gf . HM.toList . _dbcontentFacts@@ -159,25 +164,33 @@ resourceQuery RFile r = r ^. rpos . _1 . to sourceName . to T.pack . to EText resourceQuery RLine r = r ^. rpos . _1 . to sourceLine . to show . to T.pack . to EText -getRes :: DB -> Query ResourceField -> IO (S.Either PrettyError [Resource])-getRes db f = fmap (S.Right . filter (resolveQuery resourceQuery f) . toResources) (readTVarIO db)+getRes :: DB -> Query ResourceField -> EitherT PrettyError IO [Resource]+getRes db f = fmap (filter (resolveQuery resourceQuery f) . toResources) (liftIO $ readTVarIO db) where toResources :: DBContent -> [Resource] toResources = concatMap (V.toList . view wResources) . HM.elems . view resources -getResNode :: DB -> Nodename -> Query ResourceField -> IO (S.Either PrettyError [Resource])+getResNode :: DB -> Nodename -> Query ResourceField -> EitherT PrettyError IO [Resource] getResNode db nn f = do- c <- readTVarIO db- return $ case c ^. resources . at nn of- Just cnt -> S.Right $ filter (resolveQuery resourceQuery f) $ V.toList $ cnt ^. wResources- Nothing -> S.Left "Unknown node"+ c <- liftIO $ readTVarIO db+ case c ^. resources . at nn of+ Just cnt -> return $ filter (resolveQuery resourceQuery f) $ V.toList $ cnt ^. wResources+ Nothing -> left "Unknown node" -commit :: DB -> IO (S.Either PrettyError ())+commit :: DB -> EitherT PrettyError IO () commit db = do- dbc <- atomically $ readTVar db+ dbc <- liftIO $ atomically $ readTVar db case dbc ^. backingFile of- Nothing -> return (S.Left "No backing file defined")- Just bf -> fmap S.Right (encodeFile bf dbc) `catches` [ ]+ Nothing -> left "No backing file defined"+ Just bf -> liftIO (encodeFile bf dbc `catches` [ ]) -getNds :: DB -> Query NodeField -> IO (S.Either PrettyError [PNodeInfo])-getNds _ _ = return (S.Left "getNds not implemented")+getNds :: DB -> Query NodeField -> EitherT PrettyError IO [PNodeInfo]+getNds db QEmpty = fmap toNodeInfo (liftIO $ readTVarIO db)+ where+ toNodeInfo :: DBContent -> [PNodeInfo]+ toNodeInfo = fmap g . HM.keys . _dbcontentFacts+ where+ g :: Nodename -> PNodeInfo+ g = \n -> PNodeInfo n False S.Nothing S.Nothing S.Nothing++getNds _ _ = left "getNds with query not implemented"
README.adoc view
@@ -15,7 +15,7 @@ cabal install -j -p ``` -There are also http://lpuppet.banquise.net/download/[binary packages available] and https://registry.hub.docker.com/u/pierrer/puppetresources[a 400M docker images].+There are also http://lpuppet.banquise.net/download/[binary packages available] and https://registry.hub.docker.com/u/pierrer/puppetresources[a docker images]. == Puppetresources @@ -64,7 +64,7 @@ `--loglevel` or `-v`:: -Possible values are : DEBUG, INFO, NOTICE, WARNING, ERROR, CRITICAL, ALERT, EMERGENCY.+Possible values are : DEBUG, INFO, NOTICE, WARNING, ERROR `--pdburl`:: @@ -78,7 +78,7 @@ Expects the path to the `hiera.yaml` file. -`--ignoremodules`::+`--ignoredmodules`:: Expects a list of comma-separated modules. The interpreter will not try to evaluate the defined types and classes from this module. This is useful for using modules that use bad practices forbidden by `puppetresources`.@@ -116,6 +116,12 @@ `--parse`:: Enable `parse mode`. Specify the puppet file to be parsed. Variables are not resolved. No interpretation.++=== Settings defaults using a yaml file++Defaults for some of these options can be set using a `/yourworkingdirectory/tests/defaults.yaml` file. For instance `OptionalTests` is checking that all users and groups are known. Because some of these users and groups might be defined outside puppet, a list of known ones is used internally. This can be overridden in that file using the key `knownusers` and `knowngroups`.++Please look at https://github.com/bartavelle/language-puppet/blob/master/tests/defaults.yaml[the template file] for a list of possible defaults. == pdbQuery
language-puppet.cabal view
@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: language-puppet-version: 1.1.0+version: 1.1.1 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/@@ -18,6 +18,7 @@ extra-source-files: CHANGELOG.markdown README.adoc+ HLint.hs Data-Files: ruby/hrubyerb.rb@@ -54,6 +55,7 @@ , Puppet.Stats , Puppet.Stdlib , Puppet.OptionalTests+ , Puppet.Utils , SafeProcess other-modules: Erb.Compute , Paths_language_puppet@@ -66,16 +68,16 @@ , Puppet.NativeTypes.Group , Puppet.NativeTypes.Host , Puppet.NativeTypes.Mount+ , Puppet.NativeTypes.Notify , Puppet.NativeTypes.Package , Puppet.NativeTypes.SshSecure , Puppet.NativeTypes.User , Puppet.NativeTypes.ZoneRecord , Puppet.Plugins- , Puppet.Utils extensions: OverloadedStrings, BangPatterns ghc-options: -Wall -funbox-strict-fields ghc-prof-options: -auto-all -caf-all- build-depends: base >=4.6 && < 4.8+ build-depends: base >=4.6 && < 4.9 , aeson >= 0.7 && < 0.9 , ansi-wl-pprint == 0.6.* , attoparsec >= 0.11 && < 0.13@@ -85,31 +87,32 @@ , containers == 0.5.* , cryptohash >= 0.10 && < 0.12 , directory == 1.2.*- , filecache >= 0.2.5 && < 0.3+ , either == 4.3.*+ , exceptions >= 0.8 && < 0.9+ , filecache >= 0.2.8 && < 0.3 , hashable == 1.2.*- , hruby >= 0.2.5 && <0.3+ , hruby >= 0.3 && <0.4 , hslogger == 1.2.* , hslua >= 0.3.10 && < 0.4- , http-conduit >= 2.1 && < 2.2- , http-types == 0.8.*- , iconv == 0.4.*- , lens >= 4.6 && < 4.9+ , lens >= 4.9 && < 5 , lens-aeson >= 1.0 , luautils >= 0.1.3 && < 0.1.4- , mtl == 2.1.*- , operational+ , mtl >= 2.2 && < 2.3+ , operational >= 0.2.3 && < 0.3 , parsec == 3.1.* , parsers >= 0.11 && < 0.13 , pcre-utils >= 0.1.4 && < 0.2 , process >= 1.1 && < 1.3 , regex-pcre-builtin >= 0.94.4 , scientific >= 0.2 && < 0.4+ , servant == 0.2.*+ , servant-client == 0.2.* , split == 0.2.* , stm == 2.4.* , strict-base-types >= 0.2.2 , text >= 0.11- , time == 1.4.*- , transformers-compat == 0.4.*+ , time >= 1.4 && < 2+ , transformers == 0.4.* , unix >= 2.6 && < 2.8 , unordered-containers == 0.2.* , vector == 0.10.*@@ -162,7 +165,7 @@ extensions: BangPatterns, OverloadedStrings ghc-options: -Wall -rtsopts -threaded -with-rtsopts "-A2M" -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 >=0.11,regex-pcre-builtin,lens,aeson,yaml,parallel-io,containers,Glob,hspec >= 1.9+ build-depends: language-puppet,base,text,parsec,vector,ansi-wl-pprint,bytestring,mtl,hslogger,Diff,unordered-containers,strict-base-types,optparse-applicative >=0.11,regex-pcre-builtin,lens,aeson,yaml,parallel-io,containers,Glob,hspec >= 1.9, either, servant-client main-is: PuppetResources.hs executable pdbquery@@ -170,5 +173,5 @@ extensions: BangPatterns, OverloadedStrings ghc-options: -Wall -rtsopts -threaded ghc-prof-options: -auto-all -caf-all -fprof-auto- build-depends: language-puppet,base,optparse-applicative >= 0.11,text,yaml,bytestring,strict-base-types,lens,unordered-containers,vector+ build-depends: language-puppet,base,optparse-applicative >= 0.11,text,yaml,bytestring,strict-base-types,lens,unordered-containers,vector,either,servant-client main-is: pdbQuery.hs
progs/PuppetResources.hs view
@@ -1,10 +1,12 @@-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RecordWildCards #-} module Main where import Control.Concurrent.ParallelIO (parallel) import Control.Lens import Control.Monad+import Control.Monad.Trans.Either import Data.Aeson (encode) import qualified Data.ByteString.Lazy.Char8 as BSL import Data.Either (partitionEithers)@@ -13,25 +15,26 @@ import qualified Data.HashMap.Strict as HM import qualified Data.HashSet as HS import Data.List (isInfixOf)-import Data.Maybe (isNothing, mapMaybe)+import Data.Maybe (fromMaybe, isNothing, mapMaybe) import Data.Monoid hiding (First) import qualified Data.Set as Set+import Data.String (fromString) import qualified Data.Text as T import qualified Data.Text.IO as T import Data.Text.Strict.Lens import Data.Tuple (swap) import qualified Data.Vector as V-import Data.Yaml (decodeFileEither) import Options.Applicative+import Servant.Common.BaseUrl import System.Exit (exitFailure, exitSuccess) import qualified System.FilePath.Glob as G import System.IO import qualified System.Log.Logger as LOG import qualified Text.Parsec as P import Text.Regex.PCRE.String+import Prelude import Facter- import Puppet.Daemon import Puppet.Interpreter.PrettyPrinter () import Puppet.Interpreter.Types@@ -39,9 +42,10 @@ import Puppet.Parser import Puppet.Parser.PrettyPrinter (ppStatements) import Puppet.Parser.Types-import Puppet.PP hiding ((<$>))+import Puppet.PP import Puppet.Preferences import Puppet.Stats+import Puppet.Utils import PuppetDB.Common import PuppetDB.Dummy import PuppetDB.Remote@@ -57,34 +61,31 @@ in [(MultNodes os, "")] data Options = Options- { _pdb :: Maybe String- , _showjson :: Bool- , _showContent :: Bool- , _resourceType :: Maybe T.Text- , _resourceName :: Maybe T.Text- , _puppetdir :: Maybe FilePath- , _nodename :: Maybe Nodename- , _multnodes :: Maybe MultNodes- , _deadcode :: Bool- , _pdbfile :: Maybe FilePath- , _loglevel :: LOG.Priority- , _hieraFile :: Maybe FilePath- , _factsOverr :: Maybe FilePath- , _factsDefault :: Maybe FilePath- , _commitDB :: Bool- , _checkExport :: Bool- , _ignoredMods :: HS.HashSet T.Text- , _parse :: Maybe FilePath- , _strictMode :: Strictness- , _noExtraTests :: Bool+ { _optShowjson :: Bool+ , _optShowContent :: Bool+ , _optResourceType :: Maybe T.Text+ , _optResourceName :: Maybe T.Text+ , _optPuppetdir :: Maybe FilePath+ , _optNodename :: Maybe Nodename+ , _optMultnodes :: Maybe MultNodes+ , _optDeadcode :: Bool+ , _optPdburl :: Maybe String+ , _optPdbfile :: Maybe FilePath+ , _optLoglevel :: LOG.Priority+ , _optHieraFile :: Maybe FilePath+ , _optFactsOverr :: Maybe FilePath+ , _optFactsDefault :: Maybe FilePath+ , _optCommitDB :: Bool+ , _optCheckExport :: Bool+ , _optIgnoredMods :: Maybe (HS.HashSet T.Text)+ , _optParse :: Maybe FilePath+ , _optStrictMode :: Bool+ , _optNoExtraTests :: Bool } deriving (Show) options :: Parser Options options = Options- <$> optional (strOption- ( long "pdburl"- <> help "URL of the puppetdb (ie. http://localhost:8080/)."))- <*> switch+ <$> switch ( long "JSON" <> short 'j' <> help "Shows the output as a JSON document (useful for full catalog views)")@@ -116,12 +117,15 @@ ( long "deadcode" <> help "Show deadcode when the --all option is used") <*> optional (strOption+ ( long "pdburl"+ <> help "URL of the puppetdb (ie. http://localhost:8080/)."))+ <*> optional (strOption ( long "pdbfile" <> help "Path to the testing PuppetDB file.")) <*> option auto ( long "loglevel" <> short 'v'- <> help "Values are : DEBUG, INFO, NOTICE, WARNING, ERROR, CRITICAL, ALERT, EMERGENCY"+ <> help "Values are : DEBUG, INFO, NOTICE, WARNING, ERROR" <> value LOG.WARNING) <*> optional (strOption ( long "hiera"@@ -139,15 +143,14 @@ <*> switch ( long "checkExported" <> help "Save exported resources in the puppetDB")- <*> (HS.fromList . T.splitOn "," . T.pack <$>+ <*> optional (HS.fromList . T.splitOn "," . T.pack <$> strOption- ( long "ignoremodules"- <> help "Specify a comma-separated list of modules to ignore"- <> value ""))+ ( long "ignoredmodules"+ <> help "Specify a comma-separated list of modules to ignore")) <*> optional (strOption ( long "parse" <> help "Parse a single file"))- <*> flag Permissive Strict+ <*> switch ( long "strict" <> help "Strict mode diverges from vanillia Puppet and enforces good practices") <*> flag False True@@ -169,26 +172,34 @@ Be aware it uses the locale computer to generate a set of `facts` (this is a bit hackish). These facts can be overriden at the command line (see 'Options'). -}-initializedaemonWithPuppet :: FilePath -> Options- -> IO (QueryFunc, PuppetDBAPI IO, MStats, MStats, MStats)-initializedaemonWithPuppet workingdir (Options {_pdb, _pdbfile, _loglevel, _hieraFile, _factsOverr, _factsDefault, _ignoredMods, _strictMode, _noExtraTests}) = do- pdbapi <- case (_pdb, _pdbfile) of+initializedaemonWithPuppet :: FilePath+ -> Options+ -> IO (QueryFunc, PuppetDBAPI IO, MStats, MStats, MStats)+initializedaemonWithPuppet workingdir (Options {..}) = do+ LOG.updateGlobalLogger "Puppet.Daemon" (LOG.setLevel _optLoglevel)+ LOG.updateGlobalLogger "Hiera.Server" (LOG.setLevel _optLoglevel)+ pdbapi <- case (_optPdburl, _optPdbfile) of (Nothing, Nothing) -> return dummyPuppetDB (Just _, Just _) -> error "You must choose between a testing PuppetDB and a remote one"- (Just url, _) -> pdbConnect (T.pack url) >>= checkError "Error when connecting to the remote PuppetDB"+ (Just url, _) -> checkError "Error when parsing url" (parseBaseUrl url & either (S.Left . fromString) S.Right)+ >>= pdbConnect+ >>= checkError "Error when connecting to the remote PuppetDB" (_, Just file) -> loadTestDB file >>= checkError "Error when initializing the PuppetDB API"- !factsOverrides <- case (_factsOverr, _factsDefault) of+ !factsOverrides <- case (_optFactsOverr, _optFactsDefault) of (Just _, Just _) -> error "You can't use --facts-override and --facts-defaults at the same time"- (Just p, Nothing) -> HM.union `fmap` loadFactsOverrides p- (Nothing, Just p) -> flip HM.union `fmap` loadFactsOverrides p+ (Just p, Nothing) -> HM.union `fmap` loadYamlFile p+ (Nothing, Just p) -> flip HM.union `fmap` loadYamlFile p (Nothing, Nothing) -> return id- LOG.updateGlobalLogger "Puppet.Daemon" (LOG.setLevel _loglevel)- LOG.updateGlobalLogger "Hiera.Server" (LOG.setLevel _loglevel)- q <- initDaemon =<< setupPreferences- workingdir ((prefPDB.~ pdbapi) . (hieraPath.~ _hieraFile) . (ignoredmodules.~ _ignoredMods) . (strictness.~ _strictMode) . (extraTests.~ not _noExtraTests))+ prf <- dfPreferences workingdir <&> prefPDB .~ pdbapi+ <&> hieraPath .~ _optHieraFile+ <&> ignoredmodules %~ (`fromMaybe` _optIgnoredMods)+ <&> (if _optStrictMode then strictness .~ Strict else id)+ <&> (if _optNoExtraTests then extraTests .~ False else id)+ q <- initDaemon prf let queryfunc = \node -> fmap factsOverrides (puppetDBFacts node pdbapi) >>= _dGetCatalog q node return (queryfunc, pdbapi, _dParserStats q, _dCatalogStats q, _dTemplateStats q) + parseFile :: FilePath -> IO (Either P.ParseError (V.Vector Statement)) parseFile = fmap . runPParser puppetParser <*> T.readFile @@ -233,11 +244,6 @@ $ w -loadFactsOverrides :: FilePath -> IO Facts-loadFactsOverrides fp = decodeFileEither fp >>= \case- Left rr -> error ("Error when parsing " ++ fp ++ ": " ++ show rr)- Right x -> return x- -- | Finds the dead code findDeadCode :: String -> [Resource] -> Set.Set FilePath -> IO () findDeadCode puppetdir catalogs allfiles = do@@ -284,9 +290,9 @@ -- | For each node, queryfunc the catalog and return stats computeStats :: FilePath -> Options -> QueryFunc -> (MStats, MStats, MStats) -> [Nodename] -> IO ()-computeStats workingdir (Options {_loglevel, _deadcode})- queryfunc (parsingStats, catalogStats, templateStats)- topnodes = do+computeStats workingdir (Options {..})+ queryfunc (parsingStats, catalogStats, templateStats)+ topnodes = do -- the parsing statistics, so that we known which files (cats, Sum failures) <- catMaybesCount <$> parallel (map (computeCatalog queryfunc) topnodes) pStats <- getStats parsingStats@@ -294,7 +300,7 @@ tStats <- getStats templateStats let allres = (cats ^.. folded . _1 . folded) ++ (cats ^.. folded . _2 . folded) allfiles = Set.fromList $ map T.unpack $ HM.keys pStats- when _deadcode $ findDeadCode workingdir allres allfiles+ when _optDeadcode $ findDeadCode workingdir allres allfiles -- compute statistics let (parsing, Just (wPName, wPMean)) = worstAndSum pStats (cataloging, Just (wCName, wCMean)) = worstAndSum cStats@@ -306,10 +312,10 @@ worstAndSum = (_1 %~ getSum) . (_2 %~ fmap swap . getMaximum) . ifoldMap (\k (StatsPoint cnt total _ _) -> (Sum total, Maximum $ Just (total / fromIntegral cnt, k)))- putStr ("Tested " ++ show nbnodes ++ " nodes. ")+ putStr ("\nTested " ++ show nbnodes ++ " nodes. ") unless (nbnodes == 0) $ do putStrLn (formatDouble parserShare <> "% of total CPU time spent parsing, " <> formatDouble templateShare <> "% spent computing templates")- when (_loglevel <= LOG.INFO) $ do+ when (_optLoglevel <= LOG.INFO) $ do putStrLn ("Slowest template: " <> T.unpack wTName <> ", taking " <> formatDouble wTMean <> "s on average") putStrLn ("Slowest file to parse: " <> T.unpack wPName <> ", taking " <> formatDouble wPMean <> "s on average") putStrLn ("Slowest catalog to compute: " <> T.unpack wCName <> ", taking " <> formatDouble wCMean <> "s on average")@@ -322,34 +328,33 @@ computeCatalog :: QueryFunc -> Nodename -> IO (Maybe (FinalCatalog, [Resource])) computeCatalog func node = func node >>= \case- S.Left err -> putDoc ("Problem with" <+> ttext node <+> ":" <+> getError err </> mempty) >> return Nothing+ S.Left err -> putDoc (line <> red "ERROR:" <+> parens (ttext node) <+> ":" <+> getError err) >> return Nothing S.Right (rawcatalog, _ , rawexported, knownRes) -> return (Just (rawcatalog <> rawexported, knownRes)) -- | Queryfunc the catalog for the node and PP the result computeNodeCatalog :: Options -> QueryFunc -> PuppetDBAPI IO -> Nodename -> IO ()-computeNodeCatalog (Options {_showjson, _showContent, _resourceType, _resourceName, _checkExport })- queryfunc pdbapi node =+computeNodeCatalog (Options {..}) queryfunc pdbapi node = queryfunc node >>= \case S.Left rr -> do- putDoc ("Problem with" <+> ttext node <+> ":" <+> getError rr </> mempty)+ putDoc (line <> red "ERROR:" <+> parens (ttext node) <+> getError rr) exitFailure S.Right (rawcatalog, edgemap, rawexported, _) -> do printFunc <- hIsTerminalDevice stdout >>= \isterm -> return $ \x -> if isterm then putDoc x >> putStrLn "" else displayIO stdout (renderCompact x) >> putStrLn ""- catalog <- filterCatalog _resourceType _resourceName rawcatalog- exported <- filterCatalog _resourceType _resourceName rawexported+ catalog <- filterCatalog _optResourceType _optResourceName rawcatalog+ exported <- filterCatalog _optResourceType _optResourceName rawexported let wireCatalog = generateWireCatalog node (catalog <> exported ) edgemap rawWireCatalog = generateWireCatalog node (rawcatalog <> rawexported) edgemap- when _checkExport $ void $ replaceCatalog pdbapi rawWireCatalog- case (_showContent, _showjson) of+ when _optCheckExport $ void $ runEitherT $ replaceCatalog pdbapi rawWireCatalog+ case (_optShowContent, _optShowjson) of (_, True) -> BSL.putStrLn (encode (prepareForPuppetApply wireCatalog)) (True, _) -> do- unless (_resourceType == Just "file" || isNothing _resourceType) $ do+ unless (_optResourceType == Just "file" || isNothing _optResourceType) $ do putDoc "Show content only works with resource of type file. It is an error to provide another filter type" exitFailure- case _resourceName of+ case _optResourceName of Just f -> printContent f catalog Nothing -> putDoc "You should supply a resource name when using showcontent" >> exitFailure _ -> do@@ -376,27 +381,27 @@ run :: Options -> IO () -- | Parse mode-run (Options {_parse = Just fp}) = parseFile fp >>= \case+run (Options {_optParse = Just fp}) = parseFile fp >>= \case Left rr -> error ("parse error:" ++ show rr) Right s -> putDoc $ ppStatements s -run (Options {_puppetdir = Nothing, _parse = Nothing }) =+run (Options {_optPuppetdir = Nothing, _optParse = Nothing }) = error "Without a puppet dir, only the `--parse` option can be supported"-run (Options {_puppetdir = Just _, _nodename = Nothing, _multnodes = Nothing}) =+run (Options {_optPuppetdir = Just _, _optNodename = Nothing, _optMultnodes = Nothing}) = error "You need to choose between single or multiple node" -- | Single node mode (`--node` option)-run cmd@(Options {_nodename = Just node, _commitDB, _puppetdir = Just workingdir}) = do+run cmd@(Options {_optNodename = Just node, _optPuppetdir = Just workingdir, ..}) = do (queryfunc, pdbapi, _, _, _ ) <- initializedaemonWithPuppet workingdir cmd computeNodeCatalog cmd queryfunc pdbapi node- when _commitDB $ void $ commitDB pdbapi+ when _optCommitDB $ void $ runEitherT $ commitDB pdbapi -- | Multiple nodes mode (`--all`) option-run cmd@(Options {_nodename = Nothing , _multnodes = Just nodes, _puppetdir = Just workingdir}) = do+run cmd@(Options {_optNodename = Nothing , _optMultnodes = Just nodes, _optPuppetdir = Just workingdir}) = do -- it would be really noisy to run this mode with loglevel < LOG.ERROR; -- even the default LOG.WARNING would clutter the output. -- That's why we force LOG.ERROR for the puppet daemon.- (queryfunc, _, mPStats,mCStats,mTStats) <- initializedaemonWithPuppet workingdir (cmd {_loglevel = LOG.ERROR})+ (queryfunc, _, mPStats,mCStats,mTStats) <- initializedaemonWithPuppet workingdir (cmd {_optLoglevel = LOG.ERROR}) computeStats workingdir cmd queryfunc (mPStats, mCStats, mTStats) =<< retrieveNodes nodes where
progs/pdbQuery.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE GADTs #-} module Main where import Puppet.Interpreter.Types@@ -8,7 +9,8 @@ import Facter import Control.Lens-import Control.Monad (forM_,unless)+import Control.Monad (forM_,unless,(>=>))+import Control.Monad.Trans.Either import qualified Data.ByteString.Char8 as BS import qualified Data.Either.Strict as S import qualified Data.HashMap.Strict as HM@@ -18,6 +20,7 @@ import qualified Data.Vector as V import Data.Yaml hiding (Parser) import Options.Applicative as O+import Servant.Common.BaseUrl data Options = Options { _pdbloc :: Maybe FilePath , _pdbtype :: PDBType@@ -71,54 +74,59 @@ addfacts = AddFacts <$> O.argument auto mempty -display :: (Show r, ToJSON a) => String -> S.Either r a -> IO ()-display s (S.Left rr) = error (s <> " " <> show rr)-display _ (S.Right a) = BS.putStrLn (encode a)+display :: (Show r, ToJSON a) => String -> Either r a -> IO ()+display s (Left rr) = error (s <> " " <> show rr)+display _ (Right a) = BS.putStrLn (encode a) -checkError :: (Show r) => String -> S.Either r a -> IO a-checkError s (S.Left rr) = error (s <> " " <> show rr)-checkError _ (S.Right a) = return a+checkErrorS :: (Show r) => String -> S.Either r a -> IO a+checkErrorS s (S.Left rr) = error (s <> " " <> show rr)+checkErrorS _ (S.Right a) = return a +checkError :: (Show r) => String -> Either r a -> IO a+checkError s (Left rr) = error (s <> " " <> show rr)+checkError _ (Right a) = return a++runCheck :: Show r => String -> EitherT r IO a -> IO a+runCheck s = runEitherT >=> checkError s+ run :: Options -> IO () run cmdl = do epdbapi <- case (_pdbloc cmdl, _pdbtype cmdl) of- (Just l, PDBRemote) -> pdbConnect (T.pack l)+ (Just l, PDBRemote) -> pdbConnect $ either error id $ parseBaseUrl l (Just l, PDBTest) -> loadTestDB l (_, x) -> getDefaultDB x pdbapi <- case epdbapi of S.Left r -> error (show r) S.Right x -> return x- let getOrError s (S.Left rr) = error (s <> " " <> show rr)- getOrError _ (S.Right x) = return x case _pdbcmd cmdl of DumpFacts -> if _pdbtype cmdl == PDBDummy then puppetDBFacts "dummy" pdbapi >>= mapM_ print . HM.toList else do- allfacts <- getFacts pdbapi QEmpty >>= checkError "get facts"- tmpdb <- loadTestDB "/tmp/allfacts.yaml" >>= checkError "load test db"+ allfacts <- runCheck "get facts" (getFacts pdbapi QEmpty)+ tmpdb <- loadTestDB "/tmp/allfacts.yaml" >>= checkErrorS "load test db" let groupfacts = foldl' groupfact HM.empty allfacts groupfact curmap (PFactInfo ndname fctname fctval) = curmap & at ndname . non HM.empty %~ (at fctname ?~ fctval)- replaceFacts tmpdb (HM.toList groupfacts) >>= checkError "replace facts in dummy db"- commitDB tmpdb >>= checkError "commit db"- DumpNodes -> getNodes pdbapi QEmpty >>= display "dump nodes"+ runCheck "replace facts in dummy db" (replaceFacts tmpdb (HM.toList groupfacts))+ runCheck "commit db" (commitDB tmpdb)+ DumpNodes -> runEitherT (getNodes pdbapi QEmpty) >>= display "dump nodes" AddFacts n -> do unless (_pdbtype cmdl == PDBTest) (error "This option only works with the test puppetdb") fcts <- puppetDBFacts n pdbapi- replaceFacts pdbapi [(n, fcts)] >>= getOrError "replace facts"- commitDB pdbapi >>= getOrError "commit db"+ runCheck "replace facts" (replaceFacts pdbapi [(n, fcts)])+ runCheck "commit db" (commitDB pdbapi) CreateTestDB destfile -> do- ndb <- loadTestDB destfile >>= getOrError "puppetdb load"- allnodes <- getNodes pdbapi QEmpty >>= getOrError "get nodes"- allfacts <- getFacts pdbapi QEmpty >>= getOrError "get facts"+ ndb <- loadTestDB destfile >>= checkErrorS "puppetdb load"+ allnodes <- runCheck "get nodes" (getNodes pdbapi QEmpty)+ allfacts <- runCheck "get facts" (getFacts pdbapi QEmpty) let factsGrouped = HM.toList $ HM.fromListWith (<>) $ map (\x -> (x ^. nodename, HM.singleton (x ^. factname) (x ^. factval))) allfacts- replaceFacts ndb factsGrouped >>= getOrError "replace facts"+ runCheck "replace facts" (replaceFacts ndb factsGrouped) forM_ allnodes $ \pnodename -> do let ndename = pnodename ^. nodename- res <- getResourcesOfNode pdbapi ndename QEmpty >>= getOrError ("get resources for " ++ show ndename)+ res <- runCheck ("get resources for " ++ show ndename) (getResourcesOfNode pdbapi ndename QEmpty) let wirecatalog = WireCatalog ndename "version" V.empty (V.fromList res) ndename- replaceCatalog ndb wirecatalog- commitDB ndb >>= getOrError "commit db"+ runCheck "replace catalog" (replaceCatalog ndb wirecatalog)+ runCheck "commit db" (commitDB ndb) _ -> error "Not yet implemented" main :: IO ()