diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -1,3 +1,20 @@ +# v1.1.5 (TBA) + +## New features + +* Added the `pick_default` function +* `merge` now works with an arbitrary number of hashes +* Added the `hash` function +* puppet native type `file` resource accept selinux parameters +* Added the `shellquote` function + +## Bugs fixed + +* `create_resources` can now create virtual and exported resources +* puppet native type `file` fix for parameters `sourceselect` and `recurselimit` +* Hiera array merge now only keeps unique values +* `merge` now properly priorizes the lastest arguments + # v1.1.4.1 (2015/11/15) ## New features diff --git a/Erb/Compute.hs b/Erb/Compute.hs --- a/Erb/Compute.hs +++ b/Erb/Compute.hs @@ -1,17 +1,13 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} -module Erb.Compute(computeTemplate, initTemplateDaemon) where - -import Puppet.Interpreter.Types -import Puppet.Interpreter.IO -import Puppet.Interpreter.Resolve -import Puppet.PP -import Puppet.Preferences -import Puppet.Stats -import Puppet.Utils +module Erb.Compute ( + computeTemplate + , initTemplateDaemon +) where import Control.Concurrent +import Control.Exception import Control.Monad.Except import Data.Aeson.Lens import qualified Data.Either.Strict as S @@ -30,13 +26,22 @@ import Text.Parsec hiding (string) import Text.Parsec.Error import Text.Parsec.Pos - import Control.Lens + import Data.Tuple.Strict import qualified Foreign.Ruby.Helpers as FR import qualified Foreign.Ruby.Bindings as FR import Foreign.Ruby +import GHC.Conc (labelThread) +import Puppet.Interpreter.Types +import Puppet.Interpreter.IO +import Puppet.Interpreter.Resolve +import Puppet.PP +import Puppet.Preferences +import Puppet.Stats +import Puppet.Utils + instance IsString TemplateParseError where fromString s = TemplateParseError $ newErrorMessage (Message s) (initialPos "dummy") @@ -76,7 +81,10 @@ templateDaemon :: RubyInterpreter -> T.Text -> T.Text -> Chan TemplateQuery -> MStats -> FileCacheR TemplateParseError [RubyStatement] -> IO () templateDaemon intr modpath templatepath qchan mvstats filecache = do + let nameThread :: String -> IO () + nameThread n = myThreadId >>= flip labelThread n nameThread "RubyTemplateDaemon" + (respchan, fileinfo, stt, rdr) <- readChan qchan case fileinfo of Right filename -> do @@ -216,3 +224,9 @@ Right r -> FR.fromRuby r >>= \case Right result -> return (S.Right result) Left rr -> return (S.Left $ PrettyError ("Could not deserialiaze ruby output" <+> text rr)) + +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)) + where + check (S.Left r) = return (S.Left r) + check (S.Right x) = return (S.Right x) diff --git a/Erb/Evaluate.hs b/Erb/Evaluate.hs --- a/Erb/Evaluate.hs +++ b/Erb/Evaluate.hs @@ -2,22 +2,25 @@ -- | Evaluates a ruby template from what's generated by "Erb.Parser". module Erb.Evaluate (rubyEvaluate, getVariable, extractFromState) where -import Puppet.PP -import qualified Text.PrettyPrint.ANSI.Leijen as P -import Puppet.Interpreter.PrettyPrinter() -import Puppet.Interpreter.Types -import Puppet.Interpreter.Resolve -import Erb.Ruby -import qualified Data.Text as T -import Puppet.Utils -import Control.Lens -import qualified Data.Vector as V -import Data.Char (isSpace) -import Data.Aeson.Lens -import Data.Tuple.Strict -import qualified Data.HashMap.Strict as HM -import Data.Maybe (fromMaybe) +import Control.Lens +import Data.Aeson.Lens +import Data.Char (isSpace) +import qualified Data.HashMap.Strict as HM +import Data.Maybe (fromMaybe) +import qualified Data.Text as T +import Data.Tuple.Strict +import qualified Data.Vector as V +import Erb.Ruby +import Puppet.Interpreter.PrettyPrinter () +import Puppet.Interpreter.Resolve +import Puppet.Interpreter.Types +import Puppet.Interpreter.Utils +import Puppet.Parser.Utils +import Puppet.PP +import Puppet.Utils +import qualified Text.PrettyPrint.ANSI.Leijen as P + extractFromState :: InterpreterState -> Maybe (T.Text, Container ScopeInformation) extractFromState stt = let cs = stt ^. curScope @@ -27,7 +30,7 @@ classes = (PArray . V.fromList . map PString . HM.keys) (stt ^. loadedClasses) scps = stt ^. scopes cd = fromMaybe ContRoot (scps ^? ix scp . scopeContainer . cctype) -- get the current containder description - cscps = scps & ix scp . scopeVariables . at "classes" ?~ ( classes :!: dummypos :!: cd ) + cscps = scps & ix scp . scopeVariables . at "classes" ?~ ( classes :!: dummyppos :!: cd ) in Just (scp, cscps) rubyEvaluate :: Container ScopeInformation -> T.Text -> [RubyStatement] -> Either Doc T.Text diff --git a/Facter.hs b/Facter.hs --- a/Facter.hs +++ b/Facter.hs @@ -167,10 +167,10 @@ modelnames = mapMaybe (fmap (dropWhile (`elem` ("\t :" :: String))) . stripPrefix "model name") (lines cpuinfo) return $ ("processorcount", show (length cpuinfos)) : cpuinfos -puppetDBFacts :: Nodename -> PuppetDBAPI IO -> IO (Container PValue) +puppetDBFacts :: NodeName -> PuppetDBAPI IO -> IO (Container PValue) puppetDBFacts node pdbapi = runEitherT (getFacts pdbapi (QEqual FCertname node)) >>= \case - Right facts@(_:_) -> return (HM.fromList (map (\f -> (f ^. factname, f ^. factval)) facts)) + Right facts@(_:_) -> return (HM.fromList (map (\f -> (f ^. factInfoName, f ^. factInfoVal)) 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 diff --git a/Hiera/Server.hs b/Hiera/Server.hs --- a/Hiera/Server.hs +++ b/Hiera/Server.hs @@ -14,7 +14,7 @@ startHiera , dummyHiera , hieraLoggerName - -- * Re-export (query API) + -- * Query API , HieraQueryFunc ) where @@ -31,7 +31,7 @@ import qualified Data.FileCache as F import qualified Data.HashMap.Strict as HM import qualified Data.List as L -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, catMaybes) import qualified Data.Text as T import qualified Data.Vector as V import qualified Data.Yaml as Y @@ -121,28 +121,29 @@ -- | The combinator for "normal" queries queryCombinator :: HieraQueryType -> [IO (Maybe PValue)] -> IO (Maybe PValue) -queryCombinator Priority = foldr (liftA2 mplus) (pure mzero) -queryCombinator ArrayMerge = fmap rejoin . sequence - where - rejoin = Just . PArray . V.concat . map toA - toA Nothing = V.empty - toA (Just (PArray r)) = r - toA (Just a) = V.singleton a -queryCombinator HashMerge = fmap (Just . PHash . mconcat . map toH) . sequence +queryCombinator qt = fmap (createOutput . catMaybes) . sequence where - toH Nothing = mempty - toH (Just (PHash h)) = h - toH _ = error "The hiera value was not a hash" + createOutput :: [PValue] -> Maybe PValue + createOutput [] = Nothing + createOutput xs = case qt of + Priority -> return (head xs) + ArrayMerge -> return (rejoin xs) + HashMerge -> PHash . mconcat <$> mapM toH xs + rejoin = PArray . V.fromList . L.nub . concatMap toA + toA (PArray r) = V.toList r + toA a = [a] + toH (PHash h) = Just h + toH _ = Nothing interpolateText :: Container T.Text -> T.Text -> T.Text interpolateText vars t = fromMaybe t ((parseInterpolableString t ^? _Right) >>= resolveInterpolable vars) resolveInterpolable :: Container T.Text -> [HieraStringPart] -> Maybe T.Text resolveInterpolable vars = fmap T.concat . mapM resolvePart - where - resolvePart :: HieraStringPart -> Maybe T.Text - resolvePart (HString x) = Just x - resolvePart (HVariable v) = vars ^. at v + where + resolvePart :: HieraStringPart -> Maybe T.Text + resolvePart (HString x) = Just x + resolvePart (HVariable v) = vars ^. at v interpolatePValue :: Container T.Text -> PValue -> PValue interpolatePValue v (PHash h) = PHash . HM.fromList . map ( (_1 %~ interpolateText v) . (_2 %~ interpolatePValue v) ) . HM.toList $ h diff --git a/Puppet/Daemon.hs b/Puppet/Daemon.hs --- a/Puppet/Daemon.hs +++ b/Puppet/Daemon.hs @@ -2,7 +2,9 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} module Puppet.Daemon ( - initDaemon + Daemon(..) + , initDaemon + -- * Utils , checkError -- * Re-exports , module Puppet.Interpreter.Types @@ -11,10 +13,9 @@ import Control.Exception import Control.Exception.Lens -import qualified Control.Lens as L -import Control.Lens.Operators +import Control.Lens hiding (Strict) import qualified Data.Either.Strict as S -import Data.FileCache +import Data.FileCache as FileCache import qualified Data.HashMap.Strict as HM import qualified Data.Text as T import qualified Data.Text.IO as T @@ -45,54 +46,66 @@ import Puppet.Stats import Puppet.Utils -{-| This is a high level function, that will initialize the parsing and -interpretation infrastructure from the 'Preferences', and will return 'DaemonMethods'. -From there, you have access to 'getCatalog', a function that take a node name, -and the 'Facts' to return the result of the catalog computation. 'DaemonMethods' also returns -a few IO functions that can be used to query for statistics (see "Puppet.Stats"). +{-| API for the Daemon. +The main method is `getCatalog`: given a node and a list of facts, it returns the result of the compilation. +This will be either an error, or a tuple containing: +- all the resources in this catalog +- the dependency map +- the exported resources +- a list of known resources, that might not be up to date, but are here for code coverage tests. -It will internaly initialize a thread for the LUA interpreter, and a thread for the Ruby one. +Notes : + +* 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, 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. +-} +data Daemon = Daemon + { getCatalog :: NodeName -> Facts -> IO (S.Either PrettyError (FinalCatalog, EdgeMap, FinalCatalog, [Resource])) + , parserStats :: MStats + , catalogStats :: MStats + , templateStats :: MStats + } + +{-| Entry point to get a Daemon +It will initialize the parsing and interpretation infrastructure from the 'Preferences'. + +Internally it initializes a thread for the LUA interpreter, and a thread for the Ruby one. It should cache the AST of every .pp file, and could use a bit of memory. As a comparison, it fits in 60 MB with the author's manifests, but really breathes when given 300 MB of heap space. In this configuration, even if it spawns a ruby process for every template evaluation, it is way faster than the puppet stack. -It can optionnaly talk with PuppetDB, by setting an URL via the 'prefPDB'. +It can optionally talk with PuppetDB, by setting an URL via the 'prefPDB'. The recommended way to set it to http://localhost:8080 and set a SSH tunnel : > ssh -L 8080:localhost:8080 puppet.host - -Canveats : - -* 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, 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 - setupLogger (prefs ^. prefLogLevel) +initDaemon :: Preferences IO -> IO Daemon +initDaemon pref0 = do + setupLogger (pref0 ^. prefLogLevel) logDebug "initDaemon" traceEventIO "initDaemon" - templateStats <- newStats - parserStats <- newStats - catalogStats <- newStats - pfilecache <- newFileCache - intr <- startRubyInterpreter - hquery <- case prefs ^. prefHieraPath of - Just p -> either error id <$> startHiera p - Nothing -> return dummyHiera - luacontainer <- initLuaMaster (T.pack (prefs ^. prefPuppetPaths.modulesPath)) - let myprefs = prefs & prefExtFuncs %~ HM.union luacontainer - getStatements = parseFunction myprefs pfilecache parserStats - getTemplate <- initTemplateDaemon intr myprefs templateStats - return (DaemonMethods (gCatalog myprefs getStatements getTemplate catalogStats hquery) parserStats catalogStats templateStats) + luacontainer <- initLuaMaster (T.pack (pref0 ^. prefPuppetPaths.modulesPath)) + let pref = pref0 & prefExtFuncs %~ HM.union luacontainer + hquery <- case pref ^. prefHieraPath of + Just p -> either error id <$> startHiera p + Nothing -> return dummyHiera + fcache <- newFileCache + intr <- startRubyInterpreter + templStats <- newStats + getTemplate <- initTemplateDaemon intr pref templStats + catStats <- newStats + parseStats <- newStats + return (Daemon + (getCatalog' pref (parseFunc (pref ^. prefPuppetPaths) fcache parseStats) getTemplate catStats hquery) + parseStats + catStats + templStats + ) --- Public utils func to work with the daemon -- - -- | In case of a Left value, print the error and exit immediately checkError :: Show e => Doc -> Either e a -> IO a checkError desc = either exit return @@ -101,73 +114,73 @@ display err = red desc <> ": " <+> (string . show) err --- Some utils func internal to this module -- +-- Internal functions -gCatalog :: Preferences IO +getCatalog' :: Preferences IO -> ( TopLevelType -> T.Text -> IO (S.Either PrettyError Statement) ) -> (Either T.Text T.Text -> InterpreterState -> InterpreterReader IO -> IO (S.Either PrettyError T.Text)) -> MStats -> HieraQueryFunc IO - -> Nodename + -> NodeName -> Facts -> IO (S.Either PrettyError (FinalCatalog, EdgeMap, FinalCatalog, [Resource])) -gCatalog prefs getStatements getTemplate stats hquery node facts = do +getCatalog' pref parsingfunc getTemplate stats hquery node facts = do logDebug ("Received query for node " <> node) - traceEventIO ("START gCatalog " <> T.unpack node) - let catalogComputation = getCatalog (InterpreterReader - (prefs ^. prefNatTypes) - getStatements - getTemplate - (prefs ^. prefPDB) - (prefs ^. prefExtFuncs) - node - hquery - defaultImpureMethods - (prefs ^. prefIgnoredmodules) - (prefs ^. prefExternalmodules) - (prefs ^. prefStrictness == Strict) - (prefs ^. prefPuppetPaths) - ) - node - facts - (prefs ^. prefPuppetSettings) + traceEventIO ("START getCatalog' " <> T.unpack node) + let catalogComputation = interpretCatalog (InterpreterReader + (pref ^. prefNatTypes) + parsingfunc + getTemplate + (pref ^. prefPDB) + (pref ^. prefExtFuncs) + node + hquery + defaultImpureMethods + (pref ^. prefIgnoredmodules) + (pref ^. prefExternalmodules) + (pref ^. prefStrictness == Strict) + (pref ^. prefPuppetPaths) + ) + node + facts + (pref ^. prefPuppetSettings) (stmts :!: warnings) <- measure stats node catalogComputation mapM_ (\(p :!: m) -> LOG.logM daemonLoggerName p (displayS (renderCompact (ttext node <> ":" <+> m)) "")) warnings - traceEventIO ("STOP gCatalog " <> T.unpack node) - if prefs ^. prefExtraTests + traceEventIO ("STOP getCatalog' " <> T.unpack node) + if pref ^. prefExtraTests then runOptionalTests stmts else return stmts where - runOptionalTests stm = case stm^?S._Right.L._1 of - Nothing -> return stm - (Just c) -> catching _PrettyError - (do {testCatalog prefs c; return stm}) + runOptionalTests stm = case stm ^? S._Right._1 of + Nothing -> return stm + (Just c) -> catching _PrettyError + (do {testCatalog pref 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 = - case compileFileList prefs topleveltype toplevelname of - S.Left rr -> return (S.Left rr) - S.Right fname -> do +-- | Return an HOF that would parse the file associated with a toplevel. +-- The toplevel is defined by the tuple (type, name) +-- The result of the parsing is a single Statement (which recursively contains others statements) +parseFunc :: PuppetDirPaths -> FileCache (V.Vector Statement) -> MStats -> TopLevelType -> T.Text -> IO (S.Either PrettyError Statement) +parseFunc ppath filecache stats = \toptype topname -> + let nameparts = T.splitOn "::" topname in + let topLevelFilePath :: TopLevelType -> T.Text -> Either PrettyError T.Text + topLevelFilePath TopNode _ = Right $ T.pack (ppath^.manifestPath <> "/site.pp") + topLevelFilePath _ name + | length nameparts == 1 = Right $ T.pack (ppath^.modulesPath) <> "/" <> name <> "/manifests/init.pp" + | null nameparts = Left $ PrettyError ("Invalid toplevel" <+> squotes (ttext name)) + | otherwise = Right $ T.pack (ppath^.modulesPath) <> "/" <> head nameparts <> "/manifests/" <> T.intercalate "/" (tail nameparts) <> ".pp" + in + case topLevelFilePath toptype topname of + Left rr -> return (S.Left rr) + Right fname -> do let sfname = T.unpack fname handleFailure :: SomeException -> IO (S.Either String (V.Vector Statement)) handleFailure e = return (S.Left (show e)) - x <- measure stats fname (query filecache sfname (parseFile sfname `catch` handleFailure)) + x <- measure stats fname (FileCache.query filecache sfname (parseFile sfname `catch` handleFailure)) case x of - S.Right stmts -> filterStatements topleveltype toplevelname stmts + S.Right stmts -> filterStatements toptype topname stmts S.Left rr -> return (S.Left (PrettyError (red (text rr)))) --- TODO this is wrong, see --- http://docs.puppetlabs.com/puppet/3/reference/lang_namespaces.html#behavior -compileFileList :: Preferences IO -> TopLevelType -> T.Text -> S.Either PrettyError T.Text -compileFileList prefs TopNode _ = S.Right (T.pack (prefs ^. prefPuppetPaths.manifestPath) <> "/site.pp") -compileFileList prefs _ name = moduleInfo - where - moduleInfo | length nameparts == 1 = S.Right (mpath <> "/" <> name <> "/manifests/init.pp") - | null nameparts = S.Left "no name parts, error in compilefilelist" - | otherwise = S.Right (mpath <> "/" <> head nameparts <> "/manifests/" <> T.intercalate "/" (tail nameparts) <> ".pp") - mpath = T.pack (prefs ^. prefPuppetPaths.modulesPath) - nameparts = T.splitOn "::" name parseFile :: FilePath -> IO (S.Either String (V.Vector Statement)) parseFile fname = do @@ -178,7 +191,6 @@ Left rr -> traceEventIO ("Stopped parsing " ++ fname ++ " (failure: " ++ show rr ++ ")") >> return (S.Left (show rr)) traceEventIO ("STOP parsing " ++ fname) return o - daemonLoggerName :: String daemonLoggerName = "Puppet.Daemon" diff --git a/Puppet/Interpreter.hs b/Puppet/Interpreter.hs --- a/Puppet/Interpreter.hs +++ b/Puppet/Interpreter.hs @@ -2,22 +2,13 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} module Puppet.Interpreter - ( getCatalog + ( interpretCatalog + , evaluateStatement + , computeCatalog ) where -import Puppet.Interpreter.PrettyPrinter (containerComma) -import Puppet.Interpreter.Resolve -import Puppet.Interpreter.Types -import Puppet.Interpreter.IO -import Puppet.Lens -import Puppet.NativeTypes -import Puppet.Parser.PrettyPrinter -import Puppet.Parser.Types -import Puppet.PP -import Puppet.Utils - import Control.Applicative -import Control.Lens +import Control.Lens hiding (ignored) import Control.Monad.Except import Control.Monad.Operational hiding (view) import Control.Monad.Trans.Except @@ -31,6 +22,7 @@ import qualified Data.Maybe.Strict as S import Data.Ord (comparing) import Data.Semigroup (Max(..)) +import Data.Text (Text) import qualified Data.Text as T import Data.Traversable (for) import qualified Data.Tree as T @@ -38,23 +30,18 @@ import qualified Data.Vector as V import System.Log.Logger --- helpers -vmapM :: (Monad m, Foldable t) => (a -> m b) -> t a -> m [b] -vmapM f = mapM f . toList - -normalizeRIdentifier :: T.Text -> T.Text -> RIdentifier -normalizeRIdentifier t = RIdentifier rt - where - rt = fromMaybe t (T.stripPrefix "::" t) - -getModulename :: RIdentifier -> T.Text -getModulename (RIdentifier t n) = - let gm x = case T.splitOn "::" x of - [] -> x - (y:_) -> y - in case t of - "class" -> gm n - _ -> gm t +import Puppet.Interpreter.PrettyPrinter (containerComma) +import Puppet.Interpreter.Resolve +import Puppet.Interpreter.Types +import Puppet.Interpreter.Utils +import Puppet.Interpreter.IO +import Puppet.Lens +import Puppet.NativeTypes +import Puppet.Parser.PrettyPrinter +import Puppet.Parser.Types +import Puppet.Parser.Utils +import Puppet.PP +import Puppet.Utils {-| Call the operational 'interpretMonad' function to compute the catalog. @@ -66,17 +53,17 @@ 'InterpreterState' and might not be up to date. There are only useful for coverage testing (checking dependencies for instance). -} -getCatalog :: (Functor m, Monad m) +interpretCatalog :: (Functor m, Monad m) => InterpreterReader m -- ^ The whole environment required for computing catalog. - -> Nodename + -> NodeName -> Facts - -> Container T.Text -- ^ Server settings + -> Container Text -- ^ Server settings -> m (Pair (S.Either PrettyError (FinalCatalog, EdgeMap, FinalCatalog, [Resource])) [Pair Priority Doc]) -getCatalog interpretReader node facts settings = do +interpretCatalog interpretReader node facts settings = do (output, _, warnings) <- interpretMonad interpretReader (initialState facts settings) (computeCatalog node) return (strictifyEither output :!: warnings) -isParent :: T.Text -> CurContainerDesc -> InterpreterMonad Bool +isParent :: Text -> CurContainerDesc -> InterpreterMonad Bool isParent cur (ContClass possibleparent) = preuse (scopes . ix cur . scopeParent) >>= \case Nothing -> throwPosError ("Internal error: could not find scope" <+> ttext cur <+> "possible parent" <+> ttext possibleparent) Just S.Nothing -> return False @@ -85,14 +72,14 @@ else isParent p (ContClass possibleparent) isParent _ _ = return False +-- | Apply resource defaults, references overrides and expand defines finalize :: [Resource] -> InterpreterMonad [Resource] -finalize rlist = do - -- step 1, apply defaults +finalize rx = do scp <- getScopeName - defs <- use (scopes . ix scp . scopeDefaults) + resdefaults <- use (scopes . ix scp . scopeResDefaults) let getOver = use (scopes . ix scp . scopeOverrides) -- retrieves current overrides - addDefaults r = ifoldlM (addAttribute CantReplace) r thisresdefaults - where thisresdefaults = defs ^. ix (r ^. rid . itype) . defValues + addResDefaults r = ifoldlM (addAttribute CantReplace) r resdefval + where resdefval = resdefaults ^. ix (r ^. rid . itype) . resDefValues addOverrides r = getOver >>= foldlM addOverrides' r . view (at (r ^. rid)) addOverrides' r (ResRefOverride _ prms p) = do -- we used this override, so we discard it @@ -114,12 +101,12 @@ then return Replace -- we can override what's defined in a parent else forb "Can't override something that was not defined in the parent." ifoldlM (addAttribute overrideType) r prms - withDefaults <- mapM (addOverrides >=> addDefaults) rlist + -- step 1, apply resDefaults and resRefOverride + withDefaults <- mapM (addOverrides >=> addResDefaults) rx -- There might be some overrides that could not be applied. The only -- valid reason is that they override something in exported resources. -- - -- This will probably do something unexpected on defines, but let's do - -- it that way for now. + -- it probably do something unexpected on defines, but let's keep it that way for now. let keepforlater (ResRefOverride resid resprms ropos) = resMod %= (appended : ) where appended = ResourceModifier (resid ^. itype) ModifierMustMatch DontRealize (REqualitySearch "title" (PString (resid ^. iname))) overrider ropos @@ -135,40 +122,77 @@ if n || r ^. rvirtuality /= Normal then return [r] else expandDefine r + -- Now that all defaults / override have been applied, the defines can + -- finally be expanded. + -- The reason it has to be there is that parameters of the define could + -- be affected. concat <$> mapM expandableDefine withDefaults - -popScope :: InterpreterMonad () -popScope = curScope %= tail - -pushScope :: CurContainerDesc -> InterpreterMonad () -pushScope s = curScope %= (s :) - -evalTopLevel :: Statement -> InterpreterMonad ([Resource], Statement) -evalTopLevel (TopContainer tops s) = do - pushScope ContRoot - r <- vmapM evaluateStatement tops >>= finalize . concat - -- popScope - (nr, ns) <- evalTopLevel s - popScope - return (r <> nr, ns) -evalTopLevel x = return ([], x) + where + expandDefine :: Resource -> InterpreterMonad [Resource] + expandDefine r = do + let deftype = dropInitialColons (r ^. rid . itype) + defname = r ^. rid . iname + modulename = getModulename (r ^. rid) + curContType = ContDefine deftype defname (r ^. rpos) + p <- use curPos + -- we add the relations of this define to the global list of relations + -- before dropping it, so that they are stored for the final + -- relationship resolving + let extr = do + (dstid, linkset) <- itoList (r ^. rrelations) + link <- toList linkset + return (LinkInformation (r ^. rid) dstid link p) + extraRelations <>= extr + void $ enterScope SENormal curContType modulename p + (spurious, stmt) <- interpretTopLevel TopDefine deftype + DefineDecl _ defineParams stmts cp <- extractPrism "expandDefine" _DefineDecl stmt + let isImported (ContImported _) = True + isImported _ = False + isImportedDefine <- isImported <$> getScope + curPos .= r ^. rpos + curscp <- getScope + when isImportedDefine (pushScope (ContImport (r ^. rnode) curscp )) + pushScope curContType + ignored <- isIgnoredModule modulename + out <- if ignored + then return mempty + else do + loadVariable "title" (PString defname) + loadVariable "name" (PString defname) + -- not done through loadvariable because of override errors + loadParameters (r ^. rattributes) defineParams cp S.Nothing + curPos .= cp + res <- evaluateStatementsFoldable stmts + finalize (spurious ++ res) + when isImportedDefine popScope + popScope + return out -getstt :: TopLevelType -> T.Text -> InterpreterMonad ([Resource], Statement) -getstt topleveltype toplevelname = - -- check if this is a known class (spurious or inner class) - use (nestedDeclarations . at (topleveltype, toplevelname)) >>= \case +-- | Given a toplevel (type, name), +-- return the associated parsed statement together with its evaluated resources +interpretTopLevel :: TopLevelType -> Text -> InterpreterMonad ([Resource], Statement) +interpretTopLevel toptype topname = + -- check if this is a known toplevel + use (nestedDeclarations . at (toptype, topname)) >>= \case Just x -> return ([], x) -- it is known ! - Nothing -> singleton (GetStatement topleveltype toplevelname) >>= evalTopLevel - -extractPrism :: Prism' a b -> Doc -> a -> InterpreterMonad b -extractPrism p t a = case preview p a of - Just b -> return b - Nothing -> throwPosError ("Could not extract prism in " <> t) + Nothing -> singleton (GetStatement toptype topname) >>= evalTopLevel + where + evalTopLevel :: Statement -> InterpreterMonad ([Resource], Statement) + evalTopLevel (TopContainer tops s) = do + pushScope ContRoot + r <- mapM evaluateStatement tops >>= finalize . concat + -- popScope + (nr, ns) <- evalTopLevel s + popScope + return (r <> nr, ns) + evalTopLevel x = return ([], x) -computeCatalog :: Nodename -> InterpreterMonad (FinalCatalog, EdgeMap, FinalCatalog, [Resource]) -computeCatalog ndename = do - (restop, node') <- getstt TopNode ndename - node <- extractPrism _Node' "computeCatalog" node' +-- | Main internal entry point, this function completes the interpretation +-- TODO: add some doc here +computeCatalog :: NodeName -> InterpreterMonad (FinalCatalog, EdgeMap, FinalCatalog, [Resource]) +computeCatalog nodename = do + (topres, stmt) <- interpretTopLevel TopNode nodename + nd <- extractPrism "computeCatalog" _NodeDecl stmt let finalStep [] = return [] finalStep allres = do -- collect stuff and apply thingies @@ -179,9 +203,18 @@ -- replace the modified stuff let res = foldl' (\curm e -> curm & at (e ^. rid) ?~ e) realized refinalized return (toList res) - mainstage = Resource (RIdentifier "stage" "main") mempty mempty mempty [ContRoot] Normal mempty dummypos ndename - resnode <- evaluateNode node >>= finalStep . (++ (mainstage : restop)) - let (real :!: exported) = foldl' classify (mempty :!: mempty) resnode + + mainstage = Resource (RIdentifier "stage" "main") mempty mempty mempty [ContRoot] Normal mempty dummyppos nodename + + evaluateNode :: NodeDecl -> InterpreterMonad [Resource] + evaluateNode (NodeDecl _ sx inheritnode p) = do + curPos .= p + pushScope ContRoot + unless (S.isNothing inheritnode) $ throwPosError "Node inheritance is not handled yet, and will probably never be" + mapM evaluateStatement sx >>= finalize . concat + + noderes <- evaluateNode nd >>= finalStep . (++ (mainstage : topres)) + let (real :!: exported) = foldl' classify (mempty :!: mempty) noderes -- Classify sorts resources between exported and normal ones. It -- drops virtual resources, and puts in both categories resources -- that are at the same time exported and realized. @@ -195,14 +228,14 @@ Exported -> curr :!: i cure ExportedRealized -> i curr :!: i cure _ -> curr :!: cure - verified <- ifromList . map (\r -> (r ^. rid, r)) <$> mapM validateNativeType (toList real) - mp <- makeEdgeMap verified + verified <- HM.fromList . map (\r -> (r ^. rid, r)) <$> mapM validateNativeType (HM.elems real) + edgemap <- makeEdgeMap verified definedRes <- use definedResources - return (verified, mp, exported, HM.elems definedRes) + return (verified, edgemap, exported, HM.elems definedRes) makeEdgeMap :: FinalCatalog -> InterpreterMonad EdgeMap makeEdgeMap ct = do - -- merge the looaded classes and resources + -- merge the loaded classes and resources defs' <- HM.map (view rpos) <$> use definedResources clss' <- use loadedClasses let defs = defs' <> classes' <> aliases' <> names' @@ -210,7 +243,7 @@ -- generate fake resources for all extra aliases aliases' = ifromList $ do r <- ct ^.. traversed :: [Resource] - extraAliases <- r ^.. ralias . folded . filtered (/= r ^. rid . iname) :: [T.Text] + extraAliases <- r ^.. ralias . folded . filtered (/= r ^. rid . iname) :: [Text] return (r ^. rid & iname .~ extraAliases, r ^. rpos) classes' = ifromList $ do (cn, _ :!: cp) <- itoList clss' @@ -247,8 +280,8 @@ checkResDef (ri, lifs) = do let checkExists r msg = do let modulename = getModulename r - ign <- singleton (IsIgnoredModule modulename) - unless (has (ix r) defs || ign) (throwPosError msg) + ignored <- isIgnoredModule modulename + unless (has (ix r) defs || ignored) (throwPosError msg) errmsg = "Unknown resource" <+> pretty ri <+> "used in the following relationships:" <+> vcat (map pretty lifs) checkExists ri errmsg let genlnk :: LinkInformation -> InterpreterMonad RIdentifier @@ -268,8 +301,8 @@ mkp (a,_,links) = resdesc <+> lnks where resdesc = case ct ^. at a of - Just r -> pretty r - _ -> pretty a + Just r -> pretty r + _ -> pretty a lnks = pretty links throwPosError $ "Dependency error, the following resources are strongly connected!" trees -- let edgePairs = concatMap (\(_,k,ls) -> [(k,l) | l <- ls]) edgeList @@ -294,9 +327,9 @@ let filtrd = curmap ^.. folded . filtered fmod -- all the resources that match the selector/realize criteria vcheck f r = f (r ^. rvirtuality) (isGoodvirtuality, alterVirtuality) = case rmod ^. rmType of - RealizeVirtual -> (vcheck (/= Exported), \r -> return (r & rvirtuality .~ Normal)) - RealizeCollected -> (vcheck (`elem` [Exported, ExportedRealized]), \r -> return (r & rvirtuality .~ ExportedRealized)) - DontRealize -> (vcheck (`elem` [Normal, ExportedRealized]), return) + RealizeVirtual -> (vcheck (/= Exported), \r -> return (r & rvirtuality .~ Normal)) + RealizeCollected -> (vcheck (`elem` [Exported, ExportedRealized]), \r -> return (r & rvirtuality .~ ExportedRealized)) + DontRealize -> (vcheck (`elem` [Normal, ExportedRealized]), return) fmod r = (r ^. rid . itype == rmod ^. rmResType) && checkSearchExpression (rmod ^. rmSearch) r && isGoodvirtuality r mutation = alterVirtuality >=> rmod ^. rmMutation applyModification :: Pair FinalCatalog FinalCatalog -> Resource -> InterpreterMonad (Pair FinalCatalog FinalCatalog) @@ -314,25 +347,17 @@ resMod .= [] return result -evaluateNode :: Nd -> InterpreterMonad [Resource] -evaluateNode (Nd _ stmts inheritance p) = do - curPos .= p - pushScope ContRoot - unless (S.isNothing inheritance) $ throwPosError "Node inheritance is not handled yet, and will probably never be" - vmapM evaluateStatement stmts >>= finalize . concat - -evaluateStatementsFoldable :: Foldable f => f Statement -> InterpreterMonad [Resource] -evaluateStatementsFoldable = fmap concat . vmapM evaluateStatement - --- | Converts a list of pairs into a container, checking there is no --- duplicate -fromArgumentList :: [Pair T.Text a] -> InterpreterMonad (Container a) -fromArgumentList = foldM insertArgument mempty +-- | Fold all attribute declarations +-- checking for duplicates key locally inside a same resource. +fromAttributeDecls :: V.Vector AttributeDecl -> InterpreterMonad (Container PValue) +fromAttributeDecls = foldM resolve mempty where - insertArgument curmap (k :!: v) = - case curmap ^. at k of + resolve acc (AttributeDecl k _ v) = + case acc ^. at k of Just _ -> throwPosError ("Parameter" <+> dullyellow (ttext k) <+> "already defined!") - Nothing -> return (curmap & at k ?~ v) + Nothing -> do + pv <- resolveExpression v + return (acc & at k ?~ pv) evaluateStatement :: Statement -> InterpreterMonad [Resource] evaluateStatement r@(ClassDeclaration (ClassDecl cname _ _ _ _)) = @@ -345,7 +370,7 @@ else scp <> "::" <> cname nestedDeclarations . at (TopClass, rcname) ?= r return [] -evaluateStatement r@(DefineDeclaration (DefineDec dname _ _ _)) = +evaluateStatement r@(DefineDeclaration (DefineDecl dname _ _ _)) = if "::" `T.isInfixOf` dname then nestedDeclarations . at (TopDefine, dname) ?= r >> return [] else do @@ -353,19 +378,19 @@ if scp == "::" then nestedDeclarations . at (TopDefine, dname) ?= r >> return [] else nestedDeclarations . at (TopDefine, scp <> "::" <> dname) ?= r >> return [] -evaluateStatement r@(ResourceCollection (RColl e resType searchExp mods p)) = do +evaluateStatement r@(ResourceCollectionDeclaration (ResCollDecl ct rtype searchexp mods p)) = do curPos .= p - unless (fnull mods || e == Collector) (throwPosError ("It doesnt seem possible to amend attributes with an exported resource collector:" pretty r)) - rsearch <- resolveSearchExpression searchExp - let et = case e of - Collector -> RealizeVirtual + unless (isEmpty mods || ct == Collector) (throwPosError ("It doesnt seem possible to amend attributes with an exported resource collector:" pretty r)) + rsearch <- resolveSearchExpression searchexp + let et = case ct of + Collector -> RealizeVirtual ExportedCollector -> RealizeCollected - resMod %= (ResourceModifier resType ModifierCollector et rsearch return p : ) - -- Now collectd from the PuppetDB ! + resMod %= (ResourceModifier rtype ModifierCollector et rsearch (\r' -> foldM modifyCollectedAttribute r' mods) p : ) + -- Now collected from the PuppetDB ! if et == RealizeCollected then do - let q = searchExpressionToPuppetDB resType rsearch - fqdn <- singleton GetNodeName + let q = searchExpressionToPuppetDB rtype rsearch + fqdn <- getNodeName -- we must filter the resources that originated from this host -- here ! They are also turned into "normal" resources res <- toListOf (folded @@ -379,26 +404,26 @@ popScope return o else return [] -evaluateStatement (Dependency (Dep (t1 :!: n1) (t2 :!: n2) lt p)) = do +evaluateStatement (DependencyDeclaration (DepDecl (t1 :!: n1) (t2 :!: n2) lt p)) = do curPos .= p rn1 <- map (fixResourceName t1) <$> resolveExpressionStrings n1 rn2 <- map (fixResourceName t2) <$> resolveExpressionStrings n2 extraRelations <>= [ LinkInformation (normalizeRIdentifier t1 an1) (normalizeRIdentifier t2 an2) lt p | an1 <- rn1, an2 <- rn2 ] return [] -evaluateStatement (ResourceDeclaration (ResDec rt ern eargs virt p)) = do +evaluateStatement (ResourceDeclaration (ResDecl t ern eargs virt p)) = do curPos .= p resnames <- resolveExpressionStrings ern - args <- vmapM resolveArgument eargs >>= fromArgumentList - concat <$> mapM (\n -> registerResource rt n args virt p) resnames -evaluateStatement (MainFunctionCall (MFC funcname funcargs p)) = do + args <- fromAttributeDecls eargs + concat <$> mapM (\n -> registerResource t n args virt p) resnames +evaluateStatement (MainFunctionDeclaration (MainFuncDecl funcname funcargs p)) = do curPos .= p - vmapM resolveExpression funcargs >>= mainFunctionCall funcname -evaluateStatement (VariableAssignment (VarAss varname varexpr p)) = do + mapM resolveExpression (toList funcargs) >>= mainFunctionCall funcname +evaluateStatement (VarAssignmentDeclaration (VarAssignDecl varname varexpr p)) = do curPos .= p varval <- resolveExpression varexpr loadVariable varname varval return [] -evaluateStatement (ConditionalStatement (CondStatement conds p)) = do +evaluateStatement (ConditionalDeclaration (ConditionalDecl conds p)) = do curPos .= p let checkCond [] = return [] checkCond ((e :!: stmts) : xs) = do @@ -407,47 +432,59 @@ then evaluateStatementsFoldable stmts else checkCond xs checkCond (toList conds) -evaluateStatement (DefaultDeclaration (DefaultDec resType decls p)) = do +evaluateStatement (ResourceDefaultDeclaration (ResDefaultDecl rtype decls p)) = do curPos .= p - let resolveDefaultValue (prm :!: v) = (prm :!:) <$> resolveExpression v - rdecls <- vmapM resolveDefaultValue decls >>= fromArgumentList + rdecls <- fromAttributeDecls decls scp <- getScopeName - -- invariant that must be respected : the current scope must me create + -- invariant that must be respected : the current scope must be created -- in "scopes", or nothing gets saved - let newDefaults = ResDefaults resType scp rdecls p - addDefaults x = scopes . ix scp . scopeDefaults . at resType ?= x + preuse (scopes . ix scp) >>= maybe (throwPosError ("INTERNAL ERROR in evaluateStatement ResourceDefaultDeclaration: scope wasn't created - " <> pretty scp)) (const (return ())) + let newDefaults = ResDefaults rtype scp rdecls p + addDefaults x = scopes . ix scp . scopeResDefaults . at rtype ?= x -- default merging with parent - mergedDefaults curdef = newDefaults & defValues .~ (rdecls <> (curdef ^. defValues)) - preuse (scopes . ix scp . scopeDefaults . ix resType) >>= \case + mergedDefaults curdef = newDefaults & resDefValues .~ (rdecls <> (curdef ^. resDefValues)) + preuse (scopes . ix scp . scopeResDefaults . ix rtype) >>= \case Nothing -> addDefaults newDefaults - Just de -> if de ^. defSrcScope == scp - then throwPosError ("Defaults for resource" <+> ttext resType <+> "already declared at" <+> showPPos (de ^. defPos)) - else addDefaults (mergedDefaults de) + Just d -> if d ^. resDefSrcScope == scp + then throwPosError ("Defaults for resource" <+> ttext rtype <+> "already declared at" <+> showPPos (d ^. resDefPos)) + else addDefaults (mergedDefaults d) return [] -evaluateStatement (ResourceOverride (ResOver rt urn eargs p)) = do +evaluateStatement (ResourceOverrideDeclaration (ResOverrideDecl t urn eargs p)) = do curPos .= p - raassignements <- vmapM resolveArgument eargs >>= fromArgumentList + raassignements <- fromAttributeDecls eargs rn <- resolveExpressionString urn scp <- getScopeName curoverrides <- use (scopes . ix scp . scopeOverrides) - let rident = normalizeRIdentifier rt rn + let rident = normalizeRIdentifier t rn -- check that we didn't already override those values withAssignements <- case curoverrides ^. at rident of Just (ResRefOverride _ prevass prevpos) -> do let cm = prevass `HM.intersection` raassignements - unless (fnull cm) (throwPosError ("The following parameters were already overriden at" <+> showPPos prevpos <+> ":" <+> containerComma cm)) + unless (isEmpty cm) (throwPosError ("The following parameters were already overriden at" <+> showPPos prevpos <+> ":" <+> containerComma cm)) return (prevass <> raassignements) Nothing -> return raassignements scopes . ix scp . scopeOverrides . at rident ?= ResRefOverride rident withAssignements p return [] -evaluateStatement (SHFunctionCall (SFC c p)) = curPos .= p >> evaluateHFC c +evaluateStatement (HigherOrderLambdaDeclaration (HigherOrderLambdaDecl c p)) = curPos .= p >> evaluateHFC c + where + evaluateHFC :: HOLambdaCall -> InterpreterMonad [Resource] + evaluateHFC hf = do + varassocs <- hfGenerateAssociations hf + let runblock :: [(Text, PValue)] -> InterpreterMonad [Resource] + runblock assocs = do + saved <- hfSetvars assocs + res <- evaluateStatementsFoldable (hf ^. hoLambdaStatements) + hfRestorevars saved + return res + results <- mapM runblock varassocs + return (concat results) evaluateStatement r = throwError (PrettyError ("Do not know how to evaluate this statement:" pretty r)) ----------------------------------------------------------- -- Class evaluation ----------------------------------------------------------- -loadVariable :: T.Text -> PValue -> InterpreterMonad () +loadVariable :: Text -> PValue -> InterpreterMonad () loadVariable varname varval = do curcont <- getCurContainer scp <- getScopeName @@ -477,7 +514,7 @@ -- -- It is able to fill unset parameters with values from Hiera (for classes -- only) or default values. -loadParameters :: Foldable f => Container PValue -> f (Pair T.Text (S.Maybe Expression)) -> PPosition -> S.Maybe T.Text -> InterpreterMonad () +loadParameters :: Foldable f => Container PValue -> f (Pair Text (S.Maybe Expression)) -> PPosition -> S.Maybe T.Text -> InterpreterMonad () loadParameters params classParams defaultPos wHiera = do p <- use curPos curPos .= defaultPos @@ -504,7 +541,7 @@ checkDefault S.Nothing = throwE (Max False) checkDefault (S.Just expr) = lift (resolveExpression expr) - unless (fnull spuriousParams) $ throwPosError ("The following parameters are unknown:" <+> tupled (map (dullyellow . ttext) $ toList spuriousParams) <> mclassdesc) + unless (isEmpty spuriousParams) $ throwPosError ("The following parameters are unknown:" <+> tupled (map (dullyellow . ttext) $ toList spuriousParams) <> mclassdesc) -- try to set a value to all parameters -- The order of evaluation is defined / hiera / default @@ -515,11 +552,7 @@ Left (Max True) -> loadVariable k PUndef >> return [] Left (Max False) -> return [k] curPos .= p - unless (fnull unsetParams) $ throwPosError ("The following mandatory parameters were not set:" <+> tupled (map ttext $ toList unsetParams) <> mclassdesc) - -data ScopeEnteringContext = SENormal - | SEChild !T.Text -- ^ We enter the scope as the child of another class - | SEParent !T.Text -- ^ We enter the scope as the parent of another class + unless (isEmpty unsetParams) $ throwPosError ("The following mandatory parameters were not set:" <+> tupled (map ttext $ toList unsetParams) <> mclassdesc) -- | Enters a new scope, checks it is not already defined, and inherits the -- defaults from the current scope @@ -529,9 +562,9 @@ -- expanding the defines without the defaults applied enterScope :: ScopeEnteringContext -> CurContainerDesc - -> T.Text + -> Text -> PPosition - -> InterpreterMonad T.Text + -> InterpreterMonad Text enterScope secontext cont modulename p = do let scopename = scopeName cont -- This is a special hack for inheritance, because at this time we @@ -555,7 +588,7 @@ let Just psc = parentscope return (psc & scopeParent .~ S.Just prt) _ -> do - curdefs <- use (scopes . ix scp . scopeDefaults) + curdefs <- use (scopes . ix scp . scopeResDefaults) return $ ScopeInformation mempty curdefs mempty (CurContainer cont mempty) mempty S.Nothing scopes . at scopename ?= basescope scopes . ix scopename . scopeVariables . at "caller_module_name" ?= (curcaller :!: p :!: cont) @@ -564,108 +597,62 @@ debug ("enterScope, scopename=" <> ttext scopename <+> "caller_module_name=" <> pretty curcaller <+> "module_name=" <> ttext modulename) return scopename -dropInitialColons :: T.Text -> T.Text -dropInitialColons t = fromMaybe t (T.stripPrefix "::" t) - -expandDefine :: Resource -> InterpreterMonad [Resource] -expandDefine r = do - let deftype = dropInitialColons (r ^. rid . itype) - defname = r ^. rid . iname - modulename = getModulename (r ^. rid) - let curContType = ContDefine deftype defname (r ^. rpos) - p <- use curPos - -- we add the relations of this define to the global list of relations - -- before dropping it, so that they are stored for the final - -- relationship resolving - let extr = do - (dstid, linkset) <- itoList (r ^. rrelations) - link <- toList linkset - return (LinkInformation (r ^. rid) dstid link p) - extraRelations <>= extr - void $ enterScope SENormal curContType modulename p - (spurious, dls') <- getstt TopDefine deftype - DefineDec _ defineParams stmts cp <- extractPrism _DefineDeclaration' "expandDefine" dls' - let isImported (ContImported _) = True - isImported _ = False - isImportedDefine <- isImported <$> getScope - curPos .= r ^. rpos - curscp <- getScope - when isImportedDefine (pushScope (ContImport (r ^. rnode) curscp )) - pushScope curContType - imods <- singleton (IsIgnoredModule modulename) - out <- if imods - then return mempty - else do - loadVariable "title" (PString defname) - loadVariable "name" (PString defname) - -- not done through loadvariable because of override - -- errors - loadParameters (r ^. rattributes) defineParams cp S.Nothing - curPos .= cp - res <- evaluateStatementsFoldable stmts - finalize (spurious ++ res) - when isImportedDefine popScope - popScope - return out - - -loadClass :: T.Text - -> S.Maybe T.Text -- ^ Set if this is an inheritance load, so that we can set calling module properly +loadClass :: Text + -> S.Maybe Text -- ^ Set if this is an inheritance load, so that we can set calling module properly -> Container PValue -> ClassIncludeType -> InterpreterMonad [Resource] -loadClass rclassname loadedfrom params cincludetype = do - let classname = dropInitialColons rclassname - ndn <- singleton GetNodeName - singleton (TraceEvent ('[' : T.unpack ndn ++ "] loadClass " ++ T.unpack classname)) +loadClass name loadedfrom params incltype = do + let name' = dropInitialColons name + ndn <- getNodeName + singleton (TraceEvent ('[' : T.unpack ndn ++ "] loadClass " ++ T.unpack name')) p <- use curPos -- check if the class has already been loaded -- http://docs.puppetlabs.com/puppet/3/reference/lang_classes.html#using-resource-like-declarations - use (loadedClasses . at classname) >>= \case - Just (prv :!: pp) -> do - when ( (cincludetype == IncludeResource) - || (prv == IncludeResource) - ) - (throwPosError ("Can't include class" <+> ttext classname <+> "twice when using the resource-like syntax (first occurence at" <+> showPPos pp <> ")")) + use (loadedClasses . at name') >>= \case + Just (loadedincltype :!: pp) -> do + when ((incltype == ClassResourceLike) || (loadedincltype == ClassResourceLike)) $ + throwPosError ("Can't include class" <+> ttext name' <+> "twice when using the resource-like syntax (first occurence at" + <+> showPPos pp <> ")") + -- already loaded, go on return [] - -- already loaded, go on Nothing -> do - loadedClasses . at classname ?= (cincludetype :!: p) - -- load the actual class, note we are not changing the current position - -- right now - (spurious, cls') <- getstt TopClass classname - ClassDecl _ classParams inh stmts cp <- extractPrism _ClassDeclaration' "loadClass" cls' + loadedClasses . at name' ?= (incltype :!: p) + -- load the actual class, note we are not changing the current position right now + (spurious, stmt) <- interpretTopLevel TopClass name' + ClassDecl _ classParams inh stmts cp <- extractPrism "loadClass" _ClassDecl stmt -- check if we need to define a resource representing the class -- This will be the case for the first standard include inhstmts <- case inh of S.Nothing -> return [] - S.Just ihname -> loadClass ihname (S.Just classname) mempty IncludeStandard - let !scopedesc = ContClass classname - modulename = getModulename (RIdentifier "class" classname) + S.Just ihname -> loadClass ihname (S.Just name') mempty ClassIncludeLike + let !scopedesc = ContClass name' + modulename = getModulename (RIdentifier "class" name') secontext = case (inh, loadedfrom) of (S.Just x,_) -> SEChild (dropInitialColons x) (_,S.Just x) -> SEParent (dropInitialColons x) _ -> SENormal void $ enterScope secontext scopedesc modulename p - classresource <- if cincludetype == IncludeStandard + classresource <- if incltype == ClassIncludeLike then do scp <- use curScope - fqdn <- singleton GetNodeName - return [Resource (RIdentifier "class" classname) (HS.singleton classname) mempty mempty scp Normal mempty p fqdn] + fqdn <- getNodeName + return [Resource (RIdentifier "class" name') (HS.singleton name') mempty mempty scp Normal mempty p fqdn] else return [] pushScope scopedesc - imods <- singleton (IsIgnoredModule modulename) - out <- if imods + ignored <- isIgnoredModule modulename + out <- if ignored then return mempty else do - loadVariable "title" (PString classname) - loadVariable "name" (PString classname) - loadParameters params classParams cp (S.Just classname) + loadVariable "title" (PString name') + loadVariable "name" (PString name') + loadParameters params classParams cp (S.Just name') curPos .= cp res <- evaluateStatementsFoldable stmts finalize (classresource ++ spurious ++ inhstmts ++ res) popScope return out + ----------------------------------------------------------- -- Resource stuff ----------------------------------------------------------- @@ -678,10 +665,10 @@ addRelationship _ PUndef r = return r addRelationship _ notrr _ = throwPosError ("Expected a resource reference, not:" <+> pretty notrr) -addTagResource :: Resource -> T.Text -> Resource +addTagResource :: Resource -> Text -> Resource addTagResource r rv = r & rtags . contains rv .~ True -addAttribute :: OverrideType -> T.Text -> Resource -> PValue -> InterpreterMonad Resource +addAttribute :: OverrideType -> 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 _ "loglevel" r _ = use curPos >>= \p -> warn ("Metaparameter loglevel ignored at" <+> showPPos p) >> return r @@ -693,37 +680,71 @@ addAttribute _ "notify" r d = addRelationship RNotify d r addAttribute _ "require" r d = addRelationship RRequire d r addAttribute _ "subscribe" r d = addRelationship RSubscribe d r -addAttribute b t r v = case (r ^. rattributes . at t, b) of - (_, Replace) -> return (r & rattributes . at t ?~ v) - (Nothing, _) -> return (r & rattributes . at t ?~ v) - (_, CantReplace) -> return r - (Just curval, _) -> do - -- we must check if the resource scope is - -- a parent of the current scope - curscope <- getScopeName - i <- isParent curscope (rcurcontainer r) - if i - then return (r & rattributes . at t ?~ v) - else do - -- We will not bark if the same attribute - -- is defined multiple times with distinct - -- values. - let errmsg = "Attribute" <+> dullmagenta (ttext t) <+> "defined multiple times for" <+> pretty r - if curval == v - then checkStrict errmsg errmsg - else throwPosError errmsg - return r +addAttribute b t r v = go t r v + where + go = case b of + CantOverride -> setAttribute + Replace -> overrideAttribute + CantReplace -> defaultAttribute + AppendAttribute -> appendAttribute -registerResource :: T.Text -> T.Text -> Container PValue -> Virtuality -> PPosition -> InterpreterMonad [Resource] +setAttribute :: Text -> Resource -> PValue -> InterpreterMonad Resource +setAttribute attributename res value = case res ^. rattributes . at attributename of + Nothing -> return (res & rattributes . at attributename ?~ value) + Just curval -> do + -- we must check if the resource scope is + -- a parent of the current scope + curscope <- getScopeName + i <- isParent curscope (rcurcontainer res) + if i + -- TODO check why this is set + then return (res & rattributes . at attributename ?~ value) + else do + -- We will not bark if the same attribute + -- is defined multiple times with identical + -- values. + let errmsg = "Attribute" <+> dullmagenta (ttext attributename) <+> "defined multiple times for" <+> pretty res + if curval == value + then checkStrict errmsg errmsg + else throwPosError errmsg + return res + +overrideAttribute :: Text -> Resource -> PValue -> InterpreterMonad Resource +overrideAttribute attributename res value = return (res & rattributes . at attributename ?~ value) + +appendAttribute :: Text -> Resource -> PValue -> InterpreterMonad Resource +appendAttribute attributename res value = do + nvalue <- case (res ^. rattributes . at attributename, value) of + (Nothing, _) -> return value + (Just (PArray a), PArray b) -> return (PArray (a <> b)) + (Just (PArray a), b) -> return (PArray (V.snoc a b)) + (Just a, PArray b) -> return (PArray (V.cons a b)) + (Just a, b) -> return (PArray (V.fromList [a,b])) + return (res & rattributes . at attributename ?~ nvalue) + +defaultAttribute :: Text -> Resource -> PValue -> InterpreterMonad Resource +defaultAttribute attributename res value = return $ case res ^. rattributes . at attributename of + Nothing -> res & rattributes . at attributename ?~ value + Just _ -> res + +modifyCollectedAttribute :: Resource -> AttributeDecl -> InterpreterMonad Resource +modifyCollectedAttribute res (AttributeDecl attributename arrowop expr) = do + value <- resolveExpression expr + let optype = case arrowop of + AppendArrow -> AppendAttribute + AssignArrow -> Replace + addAttribute optype attributename res value + +registerResource :: Text -> T.Text -> Container PValue -> Virtuality -> PPosition -> InterpreterMonad [Resource] registerResource "class" _ _ Virtual p = curPos .= p >> throwPosError "Cannot declare a virtual class (or perhaps you can, but I do not know what this means)" registerResource "class" _ _ Exported p = curPos .= p >> throwPosError "Cannot declare an exported class (or perhaps you can, but I do not know what this means)" -registerResource rt rn arg vrt p = do +registerResource t rn arg vrt p = do curPos .= p CurContainer cnt tgs <- getCurContainer -- default tags -- http://docs.puppetlabs.com/puppet/3/reference/lang_tags.html#automatic-tagging -- http://docs.puppetlabs.com/puppet/3/reference/lang_tags.html#containment - let !defaulttags = {-# SCC "rrGetTags" #-} HS.fromList (rt : classtags) <> tgs + let !defaulttags = {-# SCC "rrGetTags" #-} HS.fromList (t : classtags) <> tgs allsegs x = x : T.splitOn "::" x (!classtags, !defaultLink) = getClassTags cnt getClassTags (ContClass cn ) = (allsegs cn,RIdentifier "class" cn) @@ -733,17 +754,17 @@ getClassTags (ContImport _ _ ) = ([],RIdentifier "class" "::") defaultRelation = HM.singleton defaultLink (HS.singleton RRequire) allScope <- use curScope - fqdn <- singleton GetNodeName - let baseresource = Resource (normalizeRIdentifier rt rn) (HS.singleton rn) mempty defaultRelation allScope vrt defaulttags p fqdn + fqdn <- getNodeName + let baseresource = Resource (normalizeRIdentifier t rn) (HS.singleton rn) mempty defaultRelation allScope vrt defaulttags p fqdn r <- ifoldlM (addAttribute CantOverride) baseresource arg - let resid = normalizeRIdentifier rt rn - case rt of + let resid = normalizeRIdentifier t rn + case t of "class" -> {-# SCC "rrClass" #-} do definedResources . at resid ?= r let attrs = r ^. rattributes fmap (r:) $ loadClass rn S.Nothing attrs $ if HM.null attrs - then IncludeStandard - else IncludeResource + then ClassIncludeLike + else ClassResourceLike _ -> {-# SCC "rrGeneralCase" #-} use (definedResources . at resid) >>= \case Just otheres -> throwPosError ("Resource" <+> pretty resid <+> "already defined:" @@ -754,18 +775,10 @@ definedResources . at resid ?= r return [r] --- A helper function for the various loggers -logWithModifier :: Priority -> (Doc -> Doc) -> [PValue] -> InterpreterMonad [Resource] -logWithModifier prio m [t] = do - p <- use curPos - rt <- resolvePValueString t - logWriter prio (m (ttext rt) <+> showPPos p) - return [] -logWithModifier _ _ _ = throwPosError "This function takes a single argument" -- functions : this can't really be exported as it uses a lot of stuff from -- this module ... -mainFunctionCall :: T.Text -> [PValue] -> InterpreterMonad [Resource] +mainFunctionCall :: Text -> [PValue] -> InterpreterMonad [Resource] mainFunctionCall "showscope" _ = use curScope >>= warn . pretty >> return [] -- The logging functions mainFunctionCall "alert" a = logWithModifier ALERT red a @@ -780,26 +793,32 @@ where doContain e = do classname <- resolvePValueString e use (loadedClasses . at classname) >>= \case - Nothing -> loadClass classname S.Nothing mempty IncludeStandard + Nothing -> loadClass classname S.Nothing mempty ClassIncludeLike Just _ -> return [] -- TODO check that this happened after class declaration mainFunctionCall "include" includes = concat <$> mapM doInclude includes where doInclude e = do classname <- resolvePValueString e - loadClass classname S.Nothing mempty IncludeStandard -mainFunctionCall "create_resources" [rtype, hs] = mainFunctionCall "create_resources" [rtype, hs, PHash mempty] -mainFunctionCall "create_resources" [PString rtype, PHash hs, PHash defs] = do + loadClass classname S.Nothing mempty ClassIncludeLike +mainFunctionCall "create_resources" [t, hs] = mainFunctionCall "create_resources" [t, hs, PHash mempty] +mainFunctionCall "create_resources" [PString t, PHash hs, PHash defparams] = do + let (ats, t') = T.span (== '@') t + virtuality <- case T.length ats of + 0 -> return Normal + 1 -> return Virtual + 2 -> return Exported + _ -> throwPosError "Too many @'s" p <- use curPos - let genRes rname (PHash rargs) = registerResource rtype rname (rargs <> defs) Normal p + let genRes rname (PHash rargs) = registerResource t' rname (rargs <> defparams) virtuality p 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 : ) - realiz x = throwPosError ("realize(): all arguments must be resource references, not" <+> pretty x) - mapM_ realiz args + pos <- use curPos + let updateMod (PResourceReference t rn) = resMod %= (ResourceModifier t ModifierMustMatch RealizeVirtual (REqualitySearch "title" (PString rn)) return pos : ) + updateMod x = throwPosError ("realize(): all arguments must be resource references, not" <+> pretty x) + mapM_ updateMod args return [] mainFunctionCall "tag" args = do scp <- getScopeName @@ -830,7 +849,7 @@ return [] mainFunctionCall fname args = do p <- use curPos - let representation = MainFunctionCall (MFC fname mempty p) + let representation = MainFunctionDeclaration (MainFuncDecl fname mempty p) rs <- singleton (ExternalFunction fname args) unless (rs == PUndef) $ throwPosError ("This function call should return" <+> pretty PUndef <+> "and not" <+> pretty rs pretty representation) return [] @@ -838,41 +857,47 @@ 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 +ensurePackages [PArray packages, PHash defparams] = 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)) + concat <$> for packages (resolvePValueString >=> ensureResource' "package" (HM.singleton "ensure" "present" <> defparams)) 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." +-- | Takes a resource type, title, and a hash of attributes that describe the resource +-- Create the resource if it does not exist alreadyTakes a resource type, title, and a hash of attributes that describe the resource(s). ensureResource :: [PValue] -> InterpreterMonad [Resource] -ensureResource [PString tp, PString ttl, PHash params] = do +ensureResource [PString t, PString title, 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' t params title +ensureResource [t,title] = ensureResource [t,title,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 (normalizeRIdentifier tp ttl)) <$> use definedResources - if def +ensureResource' :: Text -> HM.HashMap T.Text PValue -> T.Text -> InterpreterMonad [Resource] +ensureResource' t params title = do + isdefined <- has (ix (normalizeRIdentifier t title)) <$> use definedResources + if isdefined then return [] - else use curPos >>= registerResource tp ttl params Normal + else use curPos >>= registerResource t title params Normal --- Method stuff -evaluateHFC :: HFunctionCall -> InterpreterMonad [Resource] -evaluateHFC hf = do - varassocs <- hfGenerateAssociations hf - let runblock :: [(T.Text, PValue)] -> InterpreterMonad [Resource] - runblock assocs = do - saved <- hfSetvars assocs - res <- evaluateStatementsFoldable (hf ^. hfstatements) - hfRestorevars saved - return res - results <- mapM runblock varassocs - return (concat results) + +----------------------------------------------------------- +-- Specific utils functions that depends on this modules +----------------------------------------------------------- + +evaluateStatementsFoldable :: Foldable f => f Statement -> InterpreterMonad [Resource] +evaluateStatementsFoldable = fmap concat . mapM evaluateStatement . toList + +-- A helper function for the various loggers +logWithModifier :: Priority -> (Doc -> Doc) -> [PValue] -> InterpreterMonad [Resource] +logWithModifier prio m [v] = do + p <- use curPos + v' <- resolvePValueString v + logWriter prio (m (ttext v') <+> showPPos p) + return [] +logWithModifier _ _ _ = throwPosError "This function takes a single argument" diff --git a/Puppet/Interpreter/IO.hs b/Puppet/Interpreter/IO.hs --- a/Puppet/Interpreter/IO.hs +++ b/Puppet/Interpreter/IO.hs @@ -10,11 +10,6 @@ , interpretMonad ) where -import Puppet.Interpreter.PrettyPrinter () -import Puppet.Interpreter.Types -import Puppet.Plugins () -import Puppet.PP - import Control.Concurrent.MVar import Control.Exception import Control.Lens @@ -29,8 +24,13 @@ import GHC.Stack import qualified Scripting.Lua as Lua -defaultImpureMethods :: (Functor m, MonadIO m) => ImpureMethods m -defaultImpureMethods = ImpureMethods (liftIO currentCallStack) +import Puppet.Interpreter.PrettyPrinter () +import Puppet.Interpreter.Types +import Puppet.Plugins () +import Puppet.PP + +defaultImpureMethods :: (Functor m, MonadIO m) => IoMethods m +defaultImpureMethods = IoMethods (liftIO currentCallStack) (liftIO . file) (liftIO . traceEventIO) (\c fname args -> liftIO (runlua c fname args)) @@ -60,7 +60,7 @@ eval r s (a :>>= k) = let runInstr = interpretMonad r s . k -- run one instruction thpe = interpretMonad r s . throwPosError . getError - pdb = r^.pdbAPI + pdb = r^.readerPdbApi strFail iof errf = iof >>= \case Left rr -> thpe (errf (string rr)) Right x -> runInstr x @@ -72,22 +72,22 @@ Right x -> runInstr x logStuff x c = (_3 %~ (x <>)) <$> c in case a of - IsStrict -> runInstr (r ^. isStrict) - ExternalFunction fname args -> case r ^. externalFunctions . at fname of + IsStrict -> runInstr (r ^. readerIsStrict) + ExternalFunction fname args -> case r ^. readerExternalFunc . at fname of Just fn -> interpretMonad r s ( fn args >>= k) Nothing -> thpe (PrettyError ("Unknown function: " <> ttext fname)) GetStatement topleveltype toplevelname - -> canFail ((r ^. getStatement) topleveltype toplevelname) - ComputeTemplate fn stt -> canFail ((r ^. computeTemplateFunction) fn stt r) + -> canFail ((r ^. readerGetStatement) topleveltype toplevelname) + ComputeTemplate fn stt -> canFail ((r ^. readerGetTemplate) fn stt r) WriterTell t -> logStuff t (runInstr ()) WriterPass _ -> thpe "WriterPass" WriterListen _ -> thpe "WriterListen" - PuppetPathes -> runInstr (r ^. ppathes) - GetNativeTypes -> runInstr (r ^. nativeTypes) + PuppetPaths -> runInstr (r ^. readerPuppetPaths) + GetNativeTypes -> runInstr (r ^. readerNativeTypes) ErrorThrow d -> return (Left d, s, mempty) ErrorCatch _ _ -> thpe "ErrorCatch" - GetNodeName -> runInstr (r ^. thisNodename) - HieraQuery scps q t -> canFail ((r ^. hieraQuery) scps q t) + GetNodeName -> runInstr (r ^. readerNodename) + HieraQuery scps q t -> canFail ((r ^. readerHieraQuery) scps q t) PDBInformation -> pdbInformation pdb >>= runInstr PDBReplaceCatalog w -> canFailE (replaceCatalog pdb w) PDBReplaceFacts fcts -> canFailE (replaceFacts pdb fcts) @@ -97,11 +97,11 @@ 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 + GetCurrentCallStack -> (r ^. readerIoMethods . ioGetCurrentCallStack) >>= runInstr + ReadFile fls -> strFail ((r ^. readerIoMethods . ioReadFile) fls) (const $ PrettyError ("No file found in " <> list (map ttext fls))) + TraceEvent e -> (r ^. readerIoMethods . ioTraceEvent) e >>= runInstr + IsIgnoredModule m -> runInstr (r ^. readerIgnoredModules . contains m) + IsExternalModule m -> runInstr (r ^. readerExternalModules . contains m) + CallLua c fname args -> (r ^. readerIoMethods . ioCallLua) c fname args >>= \case Right x -> runInstr x Left rr -> thpe (PrettyError (string rr)) diff --git a/Puppet/Interpreter/PrettyPrinter.hs b/Puppet/Interpreter/PrettyPrinter.hs --- a/Puppet/Interpreter/PrettyPrinter.hs +++ b/Puppet/Interpreter/PrettyPrinter.hs @@ -14,13 +14,14 @@ import qualified Data.HashMap.Strict as HM import qualified Data.HashSet as HS import Data.List +import Data.Text (Text) import qualified Data.Text as T import qualified Data.Vector as V import GHC.Exts import Data.Aeson (ToJSON, encode) -import Text.PrettyPrint.ANSI.Leijen ((<$>)) import Prelude hiding ((<$>)) +import Text.PrettyPrint.ANSI.Leijen ((<$>)) containerComma'' :: Pretty a => [(Doc, a)] -> Doc containerComma'' x = indent 2 ins @@ -32,11 +33,14 @@ containerComma' = braces . containerComma'' containerComma :: Pretty a => Container a -> Doc -containerComma hm = containerComma' (map (\(a,b) -> (fill maxalign (ttext a), b)) hml) +containerComma hm = containerComma' (map (\(a,b) -> (fill maxalign (pretty a), b)) hml) where hml = HM.toList hm maxalign = maximum (map (T.length . fst) hml) +instance Pretty Text where + pretty = ttext + instance Pretty PValue where pretty (PBoolean True) = dullmagenta $ text "true" pretty (PBoolean False) = dullmagenta $ text "false" @@ -51,7 +55,6 @@ pretty TopNode = dullyellow (text "node") pretty TopDefine = dullyellow (text "define") pretty TopClass = dullyellow (text "class") - pretty TopSpurious = dullyellow (text "spurious") instance Pretty RIdentifier where pretty (RIdentifier t n) = pretty (PResourceReference t n) @@ -83,11 +86,16 @@ maxalign' [] = 0 maxalign' x = maximum . map (T.length . fst) $ x +resourceRelations :: Resource -> [(RIdentifier, LinkType)] +resourceRelations = concatMap expandSet . HM.toList . view rrelations + where + expandSet (ri, lts) = [(ri, lt) | lt <- HS.toList lts] + instance Pretty Resource where prettyList lst = - let grouped = HM.toList $ HM.fromListWith (++) [ (r ^. rid . itype, [r]) | r <- lst ] :: [ (T.Text, [Resource]) ] + let grouped = HM.toList $ HM.fromListWith (++) [ (r ^. rid . itype, [r]) | r <- lst ] :: [ (Text, [Resource]) ] sorted = sortWith fst (map (second (sortWith (view (rid.iname)))) grouped) - showGroup :: (T.Text, [Resource]) -> Doc + showGroup :: (Text, [Resource]) -> Doc showGroup (rt, res) = dullyellow (ttext rt) <+> lbrace <$> indent 2 (vcat (map resourceBody res)) <$> rbrace in vcat (map showGroup sorted) pretty r = dullyellow (ttext (r ^. rid . itype)) <+> lbrace <$> indent 2 (resourceBody r) <$> rbrace @@ -104,6 +112,7 @@ instance Pretty ResourceModifier where pretty (ResourceModifier rt ModifierMustMatch RealizeVirtual (REqualitySearch "title" (PString x)) _ p) = "realize" <> parens (pretty (PResourceReference rt x)) <+> showPPos p + -- pretty (ResourceModifier rt ModifierCollector ct (REqualitySearch _ (PString x)) _ p) = "collect" <> parens (pretty (PResourceReference rt x)) <+> showPPos p pretty _ = "TODO pretty ResourceModifier" instance Pretty RSearchExpression where @@ -120,7 +129,7 @@ showQuery = string . BSL.unpack . encode instance Pretty (InterpreterInstr a) where - pretty PuppetPathes = pf "PuppetPathes" [] + pretty PuppetPaths = pf "PuppetPathes" [] pretty IsStrict = pf "IsStrict" [] pretty GetNativeTypes = pf "GetNativeTypes" [] pretty (GetStatement tlt nm) = pf "GetStatement" [pretty tlt,ttext nm] diff --git a/Puppet/Interpreter/Pure.hs b/Puppet/Interpreter/Pure.hs --- a/Puppet/Interpreter/Pure.hs +++ b/Puppet/Interpreter/Pure.hs @@ -7,31 +7,45 @@ -- > Right (PString "3") module Puppet.Interpreter.Pure where +import Control.Lens +import qualified Data.Either.Strict as S +import qualified Data.HashMap.Strict as HM +import qualified Data.Text as T + import Erb.Evaluate import Erb.Parser import Puppet.Interpreter.IO import Puppet.Interpreter.Types +import Puppet.Interpreter.Utils import Puppet.NativeTypes import Puppet.Parser.Types -import Puppet.Pathes +import Puppet.Paths import Puppet.PP import PuppetDB.Dummy -import Control.Lens -import qualified Data.Either.Strict as S -import qualified Data.HashMap.Strict as HM -import qualified Data.Text as T -- | Worst name ever, this is a set of pure stub for the 'ImpureMethods' -- type. -impurePure :: ImpureMethods Identity -impurePure = ImpureMethods (return []) (const (return (Left "Can't read file"))) (\_ -> return ()) (\_ _ _ -> return (Left "Can't call lua")) +impurePure :: IoMethods Identity +impurePure = IoMethods (return []) (const (return (Left "Can't read file"))) (\_ -> return ()) (\_ _ _ -> return (Left "Can't call lua")) -- | A pure 'InterpreterReader', that can only evaluate a subset of the -- 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 mempty True (defaultPathes "/etc/puppet") +pureReader sttmap = InterpreterReader + baseNativeTypes + getstatementdummy + templatedummy + dummyPuppetDB + mempty + "dummy" + hieradummy + impurePure + mempty + mempty + True + (puppetPaths "/etc/puppet") where templatedummy (Right _) _ _ = return (S.Left "Can't interpret files") templatedummy (Left cnt) stt _ = return $ case extractFromState stt of @@ -55,7 +69,6 @@ where startingState = initialState facts $ HM.fromList [ ("confdir", "/etc/puppet") ] - -- | A bunch of facts that can be used for pure evaluation. dummyFacts :: Facts diff --git a/Puppet/Interpreter/Resolve.hs b/Puppet/Interpreter/Resolve.hs --- a/Puppet/Interpreter/Resolve.hs +++ b/Puppet/Interpreter/Resolve.hs @@ -13,7 +13,6 @@ resolvePValueString, resolveExpressionString, resolveExpressionStrings, - resolveArgument, resolveFunction', runHiera, isNativeType, @@ -32,8 +31,9 @@ import Puppet.Interpreter.PrettyPrinter () import Puppet.Interpreter.RubyRandom import Puppet.Interpreter.Types +import Puppet.Interpreter.Utils import Puppet.Parser.Types -import Puppet.Pathes +import Puppet.Paths import Puppet.PP import Puppet.Utils @@ -49,6 +49,7 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Base16 as B16 import Data.CaseInsensitive (mk) +import Data.Char (isAlphaNum) import qualified Data.HashMap.Strict as HM import qualified Data.HashSet as HS import Data.Maybe (mapMaybe,fromMaybe) @@ -302,15 +303,15 @@ case (ra, rb) of (PArray ha, v) -> return (PArray (V.snoc ha v)) _ -> integerOperation a b (\x -> shiftL x . fromIntegral) -resolveExpression a@(FunctionApplication e (Terminal (UHFunctionCall hf))) = do - 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 a@(FunctionApplication e (Terminal (UHOLambdaCall hol))) = do + unless (S.isNothing (hol ^. hoLambdaExpr)) (throwPosError ("You can't combine chains of higher order functions (with .) and giving them parameters, in:" <+> pretty a)) + resolveValue (UHOLambdaCall (hol & hoLambdaExpr .~ S.Just e)) resolveExpression (FunctionApplication _ x) = throwPosError ("Expected function application here, not" <+> pretty x) resolveExpression (Negate x) = PNumber . negate <$> resolveExpressionNumber x --- | Resolves an 'UValue' (terminal for the 'Expression' data type) into +-- | Resolves an 'UnresolvedValue' (terminal for the 'Expression' data type) into -- a 'PValue' -resolveValue :: UValue -> InterpreterMonad PValue +resolveValue :: UnresolvedValue -> InterpreterMonad PValue resolveValue (UNumber n) = return (PNumber n) resolveValue n@(URegexp _) = throwPosError ("Regular expressions are not allowed in this context: " <+> pretty n) resolveValue (UBoolean x) = return (PBoolean x) @@ -328,7 +329,7 @@ resPair (k :!: v) = (,) `fmap` resolveExpressionString k <*> resolveExpression v resolveValue (UVariableReference v) = resolveVariable v resolveValue (UFunctionCall fname args) = resolveFunction fname args -resolveValue (UHFunctionCall hf) = evaluateHFCPure hf +resolveValue (UHOLambdaCall hol) = evaluateHFCPure hol -- | Turns strings, numbers and booleans into 'T.Text', or throws an error. resolvePValueString :: PValue -> InterpreterMonad T.Text @@ -364,10 +365,6 @@ PArray a -> mapM resolvePValueString (V.toList a) y -> fmap return (resolvePValueString y) --- | A special helper function for argument like argument like pairs. -resolveArgument :: Pair T.Text Expression -> InterpreterMonad (Pair T.Text PValue) -resolveArgument (argname :!: argval) = (:!:) `fmap` pure argname <*> resolveExpression argval - -- | Turns a 'PValue' into a 'Bool', as explained in the reference -- documentation. pValue2Bool :: PValue -> Bool @@ -451,6 +448,21 @@ Right x -> fmap (PArray . V.fromList) (mapM (fmap PString . safeDecodeUtf8) x) resolveFunction' "sha1" [pstr] = fmap (PString . T.decodeUtf8 . B16.encode . sha1 . T.encodeUtf8) (resolvePValueString pstr) resolveFunction' "sha1" _ = throwPosError "sha1(): Expects a single argument" +resolveFunction' "shellquote" args = do + sargs <- forM args $ \arg -> case arg of + PArray vals -> mapM resolvePValueString vals + _ -> V.singleton <$> resolvePValueString arg + let escape str | T.all isSafe str = str + | not (T.any isDangerous str) = between "\"" str + | T.any (== '\'') str = between "\"" (T.concatMap escapeDangerous str) + | otherwise = between "'" str + isSafe x = isAlphaNum x || x `elem` ("@%_+=:,./-" :: String) + isDangerous x = x `elem` ("!\"`$\\" :: String) + escapeDangerous x | isDangerous x = T.snoc "\\" x + | otherwise = T.singleton x + between c s = c <> s <> c + return $ PString $ T.unwords $ V.toList $ fmap escape $ mconcat sargs + resolveFunction' "mysql_password" [pstr] = fmap (PString . T.decodeUtf8 . B16.encode . sha1 . sha1 . T.encodeUtf8) (resolvePValueString pstr) resolveFunction' "mysql_password" _ = throwPosError "mysql_password(): Expects a single argument" resolveFunction' "file" args = mapM (resolvePValueString >=> fixFilePath) args >>= fmap PString . singleton . ReadFile @@ -459,7 +471,7 @@ | T.head s == '/' = return s | otherwise = case T.splitOn "/" s of (md:x:rst) -> do - moduledir <- view modulesPath <$> getPuppetPathes + moduledir <- view modulesPath <$> getPuppetPaths return (T.intercalate "/" (T.pack moduledir : md : "files" : x : rst)) _ -> throwPosError ("file() argument invalid: " <> ttext s) resolveFunction' "tagged" ptags = do @@ -575,13 +587,13 @@ -- | Generates variable associations for evaluation of blocks. Each item -- corresponds to an iteration in the calling block. -hfGenerateAssociations :: HFunctionCall -> InterpreterMonad [[(T.Text, PValue)]] -hfGenerateAssociations hf = do - sourceexpression <- case hf ^. hfexpr of +hfGenerateAssociations :: HOLambdaCall -> InterpreterMonad [[(T.Text, PValue)]] +hfGenerateAssociations hol = do + sourceexpression <- case hol ^. hoLambdaExpr of S.Just x -> return x - S.Nothing -> throwPosError ("No expression to run the function on" <+> pretty hf) + S.Nothing -> throwPosError ("No expression to run the function on" <+> pretty hol) sourcevalue <- resolveExpression sourceexpression - case (sourcevalue, hf ^. hfparams) of + case (sourcevalue, hol ^. hoLambdaParams) of (PArray pr, BPSingle varname) -> return (map (\x -> [(varname, x)]) (V.toList pr)) (PArray pr, BPPair idx var) -> return $ do (i,v) <- Prelude.zip ([0..] :: [Int]) (V.toList pr) @@ -622,44 +634,44 @@ evalPureStatement :: Statement -> InterpreterMonad () evalPureStatement _ = throwPosError "So called 'pure' statements are not yet supported" --- | This extracts the final expression from an HFunctionCall. +-- | This extracts the final expression from an HOLambdaCall. -- When it does not exists, it checks if the last statement is in fact -- a function call -transformPureHf :: HFunctionCall -> InterpreterMonad (HFunctionCall, Expression) -transformPureHf hf = - case hf ^. hfexpression of - S.Just x -> return (hf, x) +transformPureHf :: HOLambdaCall -> InterpreterMonad (HOLambdaCall, Expression) +transformPureHf hol = + case hol ^. hoLambdaLastExpr of + S.Just x -> return (hol, x) S.Nothing -> do - let statements = hf ^. hfstatements + let statements = hol ^. hoLambdaStatements if V.null statements - then throwPosError ("The statement block must not be empty" <+> pretty hf) + then throwPosError ("The statement block must not be empty" <+> pretty hol) else case V.last statements of - (MainFunctionCall (MFC fn args _)) -> + (MainFunctionDeclaration (MainFuncDecl fn args _)) -> let expr = Terminal (UFunctionCall fn args) - in return (hf & hfstatements %~ V.init - & hfexpression .~ S.Just expr + in return (hol & hoLambdaStatements %~ V.init + & hoLambdaLastExpr .~ S.Just expr , expr) - _ -> throwPosError ("The statement block must end with an expression" <+> pretty hf) + _ -> throwPosError ("The statement block must end with an expression" <+> pretty hol) -- | All the "higher order function" stuff, for "value" mode. In this case -- we are in "pure" mode, and only a few statements are allowed. -evaluateHFCPure :: HFunctionCall -> InterpreterMonad PValue -evaluateHFCPure hf' = do - (hf, finalexpression) <- transformPureHf hf' - varassocs <- hfGenerateAssociations hf +evaluateHFCPure :: HOLambdaCall -> InterpreterMonad PValue +evaluateHFCPure hol' = do + (hol, finalexpression) <- transformPureHf hol' + varassocs <- hfGenerateAssociations hol let runblock :: [(T.Text, PValue)] -> InterpreterMonad PValue runblock assocs = do saved <- hfSetvars assocs - V.mapM_ evalPureStatement (hf ^. hfstatements) + V.mapM_ evalPureStatement (hol ^. hoLambdaStatements) r <- resolveExpression finalexpression hfRestorevars saved return r - case hf ^. hftype of - HFEach -> throwPosError "The 'each' function can't be used at the value level in language-puppet. Please use map." - HFMap -> fmap (PArray . V.fromList) (mapM runblock varassocs) - HFFilter -> do + case hol ^. hoLambdaFunc of + LambEach -> throwPosError "The 'each' function can't be used at the value level in language-puppet. Please use map." + LambMap -> fmap (PArray . V.fromList) (mapM runblock varassocs) + LambFilter -> do res <- mapM (fmap pValue2Bool . runblock) varassocs - sourcevalue <- case hf ^. hfexpr of + sourcevalue <- case hol ^. hoLambdaExpr of S.Just x -> resolveExpression x S.Nothing -> throwPosError "Internal error evaluateHFCPure 1" case sourcevalue of diff --git a/Puppet/Interpreter/Types.hs b/Puppet/Interpreter/Types.hs --- a/Puppet/Interpreter/Types.hs +++ b/Puppet/Interpreter/Types.hs @@ -20,28 +20,26 @@ , RIdentifier(RIdentifier) , HasScopeInformation(..) , ScopeInformation(ScopeInformation) + , ScopeEnteringContext(..) , HasResourceModifier(..) , ResourceModifier(ResourceModifier) - , HasImpureMethods(..) - , ImpureMethods(ImpureMethods) + , HasIoMethods(..) + , IoMethods(IoMethods) , HasCurContainer(..) , CurContainer(CurContainer) , HasNativeTypeMethods(..) , NativeTypeMethods(NativeTypeMethods) + , NodeInfo(NodeInfo) + , HasNodeInfo(..) + , FactInfo(FactInfo) + , HasFactInfo(..) + , HasWireCatalog(..) -- ** Operational instructions , InterpreterInstr(..) , HasInterpreterReader(..) , InterpreterReader(InterpreterReader) , HasInterpreterState(..) - , InterpreterState - -- * Record & field lenses - , PNodeInfo(PNodeInfo) - , nodename - , PFactInfo(PFactInfo) - , factname - , wResources - , wEdges - , factval + , InterpreterState(InterpreterState) -- * Sum types , PValue(..) , CurContainerDesc(..) @@ -58,7 +56,6 @@ , ResRefOverride(..) , ResourceField(..) , OverrideType(..) - , DaemonMethods(..) , ClassIncludeType(..) -- ** PuppetDB , PuppetEdge(PuppetEdge) @@ -69,7 +66,7 @@ , InterpreterWriter , FinalCatalog , NativeTypeValidate - , Nodename + , NodeName , Container , HieraQueryFunc , Scope @@ -77,32 +74,9 @@ , EdgeMap -- * Classes , MonadThrowPos(..) - -- * Utils + -- * definitions , metaparameters - , initialState - , getCurContainer - , text2Scientific - , safeDecodeUtf8 - , getScope - , getScopeName - , getPuppetPathes - , scopeName - , resourceRelations - , checkStrict - , dummypos - , iinsertWith - , ikeys - , isingleton - , ifromListWith - , ifromList - , iunionWith , showPos - , fnull - , rcurcontainer - , logWriter - , warn - , debug - , eitherDocIO ) where import Control.Concurrent.MVar (MVar) @@ -115,18 +89,15 @@ import Control.Monad.Writer.Class import Data.Aeson as A import Data.Aeson.Lens -import Data.Attoparsec.Text (parseOnly, rational) -import qualified Data.ByteString as BS import qualified Data.Either.Strict as S -import qualified Data.Foldable as F import Data.Hashable import qualified Data.HashMap.Strict as HM import qualified Data.HashSet as HS -import Data.Maybe (fromMaybe) import qualified Data.Maybe.Strict as S import Data.Monoid import Data.Scientific import Data.String (IsString (..)) +import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T import Data.Time.Clock @@ -143,16 +114,17 @@ import Puppet.Parser.PrettyPrinter import Puppet.Parser.Types -import Puppet.Pathes +import Puppet.Paths import Puppet.PP hiding (rational) -import Puppet.Stats +import Puppet.Utils -metaparameters :: HS.HashSet T.Text +metaparameters :: HS.HashSet Text metaparameters = HS.fromList ["tag","stage","name","title","alias","audit","check","loglevel","noop","schedule", "EXPORTEDSOURCE", "require", "before", "register", "notify"] -type Nodename = T.Text - -type Container = HM.HashMap T.Text +type NodeName = Text +type Container = HM.HashMap Text +type Scope = Text +type Facts = Container PValue newtype PrettyError = PrettyError { getError :: Doc } @@ -168,55 +140,66 @@ 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 - | PResourceReference !T.Text !T.Text + | PString !Text -- integers and doubles are internally serialized as strings by puppet + | PResourceReference !Text !T.Text | PArray !(V.Vector PValue) | PHash !(Container PValue) | PNumber !Scientific deriving (Eq, Show) +instance IsString PValue where + fromString = PString . T.pack + +instance AsNumber PValue where + _Number = prism num2PValue toNumber + where + num2PValue :: Scientific -> PValue + num2PValue = PNumber + toNumber :: PValue -> Either PValue Scientific + toNumber (PNumber n) = Right n + toNumber p@(PString x) = case text2Scientific x of + Just o -> Right o + _ -> Left p + toNumber p = Left p + -- | The different kind of hiera queries data HieraQueryType = Priority -- ^ standard hiera query | ArrayMerge -- ^ hiera_array | HashMerge -- ^ hiera_hash -- | The type of the Hiera API function -type HieraQueryFunc m = Container T.Text -- ^ All the variables that Hiera can interpolate, the top level ones being prefixed with :: - -> T.Text -- ^ The query +type HieraQueryFunc m = Container Text -- ^ All the variables that Hiera can interpolate, the top level ones being prefixed with :: + -> Text -- ^ The query -> HieraQueryType -> m (S.Either PrettyError (Maybe PValue)) -data RSearchExpression = REqualitySearch !T.Text !PValue - | RNonEqualitySearch !T.Text !PValue +-- | 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 RSearchExpression = REqualitySearch !Text !PValue + | RNonEqualitySearch !Text !PValue | RAndSearch !RSearchExpression !RSearchExpression | ROrSearch !RSearchExpression !RSearchExpression | RAlwaysTrue - deriving Eq - -instance IsString PValue where - fromString = PString . T.pack + deriving (Show, Eq) -data ClassIncludeType = IncludeStandard | IncludeResource +-- | Puppet has two main ways to declare classes: include-like and resource-like +-- https://docs.puppetlabs.com/puppet/latest/reference/lang_classes.html#include-like-vs-resource-like +data ClassIncludeType = ClassIncludeLike -- ^ using the include or contain function + | ClassResourceLike -- ^ resource like declaration deriving (Eq) -type Scope = T.Text - -type Facts = Container PValue - -- |This type is used to differenciate the distinct top level types that are -- exposed by the DSL. data TopLevelType @@ -226,47 +209,49 @@ | TopDefine -- |This is for classes. | TopClass - -- |This one is special. It represents top level statements that are not - -- part of a node, define or class. It is defined as spurious because it is - -- not what you are supposed to be. Also the caching system doesn't like - -- them too much right now. - | TopSpurious deriving (Generic,Eq) instance Hashable TopLevelType +-- | From the evaluation of Resource Default Declaration data ResDefaults = ResDefaults - { _defType :: !T.Text - , _defSrcScope :: !T.Text - , _defValues :: !(Container PValue) - , _defPos :: !PPosition + { _resDefType :: !Text + , _resDefSrcScope :: !Text + , _resDefValues :: !(Container PValue) + , _resDefPos :: !PPosition } +-- | From the evaluation of Resource Override Declaration +data ResRefOverride = ResRefOverride + { _rrid :: !RIdentifier + , _rrparams :: !(Container PValue) + , _rrpos :: !PPosition + } deriving (Eq) + data CurContainerDesc = ContRoot -- ^ Contained at node or root level - | ContClass !T.Text -- ^ Contained in a class - | ContDefine !T.Text !T.Text !PPosition -- ^ Contained in a define, along with the position where this define was ... defined + | ContClass !Text -- ^ Contained in a class + | ContDefine !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 + | ContImport !NodeName !CurContainerDesc -- ^ This one is used when finalizing imported resources, and contains the current node name deriving (Eq, Generic, Ord, Show) +data ScopeEnteringContext = SENormal + | SEChild !Text -- ^ We enter the scope as the child of another class + | SEParent !Text -- ^ We enter the scope as the parent of another class + +-- | TODO related to Scope: explain ... data CurContainer = CurContainer { _cctype :: !CurContainerDesc - , _cctags :: !(HS.HashSet T.Text) - } deriving (Eq) - -data ResRefOverride = ResRefOverride - { _rrid :: !RIdentifier - , _rrparams :: !(Container PValue) - , _rrpos :: !PPosition + , _cctags :: !(HS.HashSet Text) } deriving (Eq) data ScopeInformation = ScopeInformation - { _scopeVariables :: !(Container (Pair (Pair PValue PPosition) CurContainerDesc)) - , _scopeDefaults :: !(Container ResDefaults) - , _scopeExtraTags :: !(HS.HashSet T.Text) - , _scopeContainer :: !CurContainer - , _scopeOverrides :: !(HM.HashMap RIdentifier ResRefOverride) - , _scopeParent :: !(S.Maybe T.Text) + { _scopeVariables :: !(Container (Pair (Pair PValue PPosition) CurContainerDesc)) + , _scopeResDefaults :: !(Container ResDefaults) + , _scopeExtraTags :: !(HS.HashSet Text) + , _scopeContainer :: !CurContainer + , _scopeOverrides :: !(HM.HashMap RIdentifier ResRefOverride) + , _scopeParent :: !(S.Maybe Text) } data InterpreterState = InterpreterState @@ -275,46 +260,46 @@ , _definedResources :: !(HM.HashMap RIdentifier Resource) , _curScope :: ![CurContainerDesc] , _curPos :: !PPosition - , _nestedDeclarations :: !(HM.HashMap (TopLevelType,T.Text) Statement) + , _nestedDeclarations :: !(HM.HashMap (TopLevelType,Text) Statement) , _extraRelations :: ![LinkInformation] , _resMod :: ![ResourceModifier] } data InterpreterReader m = InterpreterReader - { _nativeTypes :: !(Container NativeTypeMethods) - , _getStatement :: TopLevelType -> T.Text -> m (S.Either PrettyError Statement) - , _computeTemplateFunction :: Either T.Text T.Text -> InterpreterState -> InterpreterReader m -> m (S.Either PrettyError T.Text) - , _pdbAPI :: PuppetDBAPI m - , _externalFunctions :: Container ([PValue] -> InterpreterMonad PValue) - , _thisNodename :: T.Text - , _hieraQuery :: HieraQueryFunc m - , _ioMethods :: ImpureMethods m - , _ignoredModules :: HS.HashSet T.Text - , _externalModules :: HS.HashSet T.Text - , _isStrict :: Bool - , _ppathes :: PuppetDirPaths + { _readerNativeTypes :: !(Container NativeTypeMethods) + , _readerGetStatement :: TopLevelType -> Text -> m (S.Either PrettyError Statement) + , _readerGetTemplate :: Either Text T.Text -> InterpreterState -> InterpreterReader m -> m (S.Either PrettyError T.Text) + , _readerPdbApi :: PuppetDBAPI m + , _readerExternalFunc :: Container ([PValue] -> InterpreterMonad PValue) + , _readerNodename :: Text + , _readerHieraQuery :: HieraQueryFunc m + , _readerIoMethods :: IoMethods m + , _readerIgnoredModules :: HS.HashSet Text + , _readerExternalModules :: HS.HashSet Text + , _readerIsStrict :: Bool + , _readerPuppetPaths :: PuppetDirPaths } -data ImpureMethods m = ImpureMethods - { _imGetCurrentCallStack :: m [String] - , _imReadFile :: [T.Text] -> m (Either String T.Text) - , _imTraceEvent :: String -> m () - , _imCallLua :: MVar Lua.LuaState -> T.Text -> [PValue] -> m (Either String PValue) +data IoMethods m = IoMethods + { _ioGetCurrentCallStack :: m [String] + , _ioReadFile :: [Text] -> m (Either String T.Text) + , _ioTraceEvent :: String -> m () + , _ioCallLua :: MVar Lua.LuaState -> Text -> [PValue] -> m (Either String PValue) } data InterpreterInstr a where -- Utility for using what's in "InterpreterReader" GetNativeTypes :: InterpreterInstr (Container NativeTypeMethods) - GetStatement :: TopLevelType -> T.Text -> InterpreterInstr Statement - ComputeTemplate :: Either T.Text T.Text -> InterpreterState -> InterpreterInstr T.Text - ExternalFunction :: T.Text -> [PValue] -> InterpreterInstr PValue - GetNodeName :: InterpreterInstr T.Text - HieraQuery :: Container T.Text -> T.Text -> HieraQueryType -> InterpreterInstr (Maybe PValue) + GetStatement :: TopLevelType -> Text -> InterpreterInstr Statement + ComputeTemplate :: Either Text T.Text -> InterpreterState -> InterpreterInstr T.Text + ExternalFunction :: Text -> [PValue] -> InterpreterInstr PValue + GetNodeName :: InterpreterInstr Text + HieraQuery :: Container Text -> T.Text -> HieraQueryType -> InterpreterInstr (Maybe PValue) GetCurrentCallStack :: InterpreterInstr [String] - IsIgnoredModule :: T.Text -> InterpreterInstr Bool - IsExternalModule :: T.Text -> InterpreterInstr Bool + IsIgnoredModule :: Text -> InterpreterInstr Bool + IsExternalModule :: Text -> InterpreterInstr Bool IsStrict :: InterpreterInstr Bool - PuppetPathes :: InterpreterInstr PuppetDirPaths + PuppetPaths :: InterpreterInstr PuppetDirPaths -- error ErrorThrow :: PrettyError -> InterpreterInstr a ErrorCatch :: InterpreterMonad a -> (PrettyError -> InterpreterMonad a) -> InterpreterInstr a @@ -325,164 +310,147 @@ -- puppetdb wrappers, see 'PuppetDBAPI' for details PDBInformation :: InterpreterInstr Doc PDBReplaceCatalog :: WireCatalog -> InterpreterInstr () - PDBReplaceFacts :: [(Nodename, Facts)] -> InterpreterInstr () - PDBDeactivateNode :: Nodename -> InterpreterInstr () - PDBGetFacts :: Query FactField -> InterpreterInstr [PFactInfo] + PDBReplaceFacts :: [(NodeName, Facts)] -> InterpreterInstr () + PDBDeactivateNode :: NodeName -> InterpreterInstr () + PDBGetFacts :: Query FactField -> InterpreterInstr [FactInfo] PDBGetResources :: Query ResourceField -> InterpreterInstr [Resource] - PDBGetNodes :: Query NodeField -> InterpreterInstr [PNodeInfo] + PDBGetNodes :: Query NodeField -> InterpreterInstr [NodeInfo] PDBCommitDB :: InterpreterInstr () - PDBGetResourcesOfNode :: Nodename -> Query ResourceField -> InterpreterInstr [Resource] + PDBGetResourcesOfNode :: NodeName -> Query ResourceField -> InterpreterInstr [Resource] -- Reading the first file that can be read in a list - ReadFile :: [T.Text] -> InterpreterInstr T.Text + ReadFile :: [Text] -> InterpreterInstr T.Text -- Tracing events TraceEvent :: String -> InterpreterInstr () -- Calling Lua - CallLua :: MVar Lua.LuaState -> T.Text -> [PValue] -> InterpreterInstr PValue + CallLua :: MVar Lua.LuaState -> Text -> [PValue] -> InterpreterInstr PValue -type InterpreterLog = Pair LOG.Priority Doc -type InterpreterWriter = [InterpreterLog] - -getPuppetPathes :: InterpreterMonad PuppetDirPaths -getPuppetPathes = singleton PuppetPathes - -warn :: (Monad m, MonadWriter InterpreterWriter m) => Doc -> m () -warn d = tell [LOG.WARNING :!: d] - -debug :: (Monad m, MonadWriter InterpreterWriter m) => Doc -> m () -debug d = tell [LOG.DEBUG :!: d] - -logWriter :: (Monad m, MonadWriter InterpreterWriter m) => LOG.Priority -> Doc -> m () -logWriter prio d = tell [prio :!: d] - -- | The main monad type InterpreterMonad = ProgramT InterpreterInstr (State InterpreterState) - instance MonadError PrettyError InterpreterMonad where throwError = singleton . ErrorThrow catchError a c = singleton (ErrorCatch a c) +-- | Log +type InterpreterWriter = [Pair LOG.Priority Doc] instance MonadWriter InterpreterWriter InterpreterMonad where tell = singleton . WriterTell pass = singleton . WriterPass listen = singleton . WriterListen data RIdentifier = RIdentifier - { _itype :: !T.Text - , _iname :: !T.Text + { _itype :: !Text + , _iname :: !Text } deriving (Show,Eq,Generic,Ord) instance Hashable RIdentifier +data ResourceModifier = ResourceModifier + { _rmResType :: !Text + , _rmModifierType :: !ModifierType + , _rmType :: !ResourceCollectorType + , _rmSearch :: !RSearchExpression + , _rmMutation :: !(Resource -> InterpreterMonad Resource) + , _rmDeclaration :: !PPosition + } + +instance Show ResourceModifier where + show (ResourceModifier rt mt ct se _ p) = unwords ["ResourceModifier", show rt, show mt, show ct, "(" ++ show se ++ ")", "???", show p] + data ModifierType = ModifierCollector -- ^ For collectors, optional resources | ModifierMustMatch -- ^ For stuff like realize - deriving Eq + deriving (Show, Eq) data OverrideType = CantOverride -- ^ Overriding forbidden, will throw an error | Replace -- ^ Can silently replace | CantReplace -- ^ Silently ignore errors + | AppendAttribute -- ^ Can append values + deriving (Show, Eq) data ResourceCollectorType = RealizeVirtual | RealizeCollected | DontRealize - deriving Eq - - -data ResourceModifier = ResourceModifier - { _rmResType :: !T.Text - , _rmModifierType :: !ModifierType - , _rmType :: !ResourceCollectorType - , _rmSearch :: !RSearchExpression - , _rmMutation :: !(Resource -> InterpreterMonad Resource) - , _rmDeclaration :: !PPosition - } + deriving (Show, Eq) data LinkInformation = LinkInformation { _linksrc :: !RIdentifier , _linkdst :: !RIdentifier , _linkType :: !LinkType , _linkPos :: !PPosition - } + } deriving Show type EdgeMap = HM.HashMap RIdentifier [LinkInformation] {-| A fully resolved puppet resource that will be used in the 'FinalCatalog'. -} data Resource = Resource { _rid :: !RIdentifier -- ^ Resource name. - , _ralias :: !(HS.HashSet T.Text) -- ^ All the resource aliases + , _ralias :: !(HS.HashSet Text) -- ^ All the resource aliases , _rattributes :: !(Container PValue) -- ^ Resource parameters. , _rrelations :: !(HM.HashMap RIdentifier (HS.HashSet LinkType)) -- ^ Resource relations. , _rscope :: ![CurContainerDesc] -- ^ Resource scope when it was defined, the real container will be the first item , _rvirtuality :: !Virtuality - , _rtags :: !(HS.HashSet T.Text) + , _rtags :: !(HS.HashSet Text) , _rpos :: !PPosition -- ^ Source code position of the resource definition. - , _rnode :: !Nodename -- ^ The node were this resource was created, if remote + , _rnode :: !NodeName -- ^ The node were this resource was created, if remote } - deriving Eq + deriving (Eq, Show) type NativeTypeValidate = Resource -> Either PrettyError Resource -- | Attributes (and providers) of a puppet resource type bundled with validation rules data NativeTypeMethods = NativeTypeMethods { _puppetValidate :: NativeTypeValidate - , _puppetFields :: HS.HashSet T.Text + , _puppetFields :: HS.HashSet Text } type FinalCatalog = HM.HashMap RIdentifier Resource -data DaemonMethods = DaemonMethods - { -- | The most important function, computing catalogs. - -- Given a node name and a list of facts, it returns the result of the catalog compilation : either an error, or a tuple containing all the resources in this catalog, the dependency map, the exported resources, and a list of known resources, that might not be up to date, but are here for code coverage tests. - _dGetCatalog :: Nodename -> Facts -> IO (S.Either PrettyError (FinalCatalog, EdgeMap, FinalCatalog, [Resource])) - , _dParserStats :: MStats - , _dCatalogStats :: MStats - , _dTemplateStats :: MStats - } - -data PuppetEdge = PuppetEdge RIdentifier RIdentifier LinkType +-- | Used to represent a relationship between two resources within the wired format (json). +-- See +data PuppetEdge = PuppetEdge RIdentifier RIdentifier LinkType deriving Show -- | Wire format, see . data WireCatalog = WireCatalog - { _wireCatalogNodename :: !Nodename - , _wireCatalogWVersion :: !T.Text - , _wireCatalogWEdges :: !(V.Vector PuppetEdge) - , _wireCatalogWResources :: !(V.Vector Resource) - , _wireCatalogTransactionUUID :: !T.Text - } + { _wireCatalogNodename :: !NodeName + , _wireCatalogVersion :: !Text + , _wireCatalogEdges :: !(V.Vector PuppetEdge) + , _wireCatalogResources :: !(V.Vector Resource) + , _wireCatalogTransactionUUID :: !Text + } deriving Show -data PFactInfo = PFactInfo - { _pFactInfoNodename :: !T.Text - , _pFactInfoFactname :: !T.Text - , _pFactInfoFactval :: !PValue +data FactInfo = FactInfo + { _factInfoNodename :: !NodeName + , _factInfoName :: !Text + , _factInfoVal :: !PValue } -data PNodeInfo = PNodeInfo - { _pNodeInfoNodename :: !Nodename - , _pNodeInfoDeactivated :: !Bool - , _pNodeInfoCatalogT :: !(S.Maybe UTCTime) - , _pNodeInfoFactsT :: !(S.Maybe UTCTime) - , _pNodeInfoReportT :: !(S.Maybe UTCTime) +data NodeInfo = NodeInfo + { _nodeInfoName :: !NodeName + , _nodeInfoDeactivated :: !Bool + , _nodeInfoCatalogT :: !(S.Maybe UTCTime) + , _nodeInfoFactsT :: !(S.Maybe UTCTime) + , _nodeInfoReportT :: !(S.Maybe UTCTime) } data PuppetDBAPI m = PuppetDBAPI { pdbInformation :: m Doc , replaceCatalog :: WireCatalog -> EitherT PrettyError m () -- ^ - , replaceFacts :: [(Nodename, Facts)] -> EitherT PrettyError m () -- ^ - , deactivateNode :: Nodename -> EitherT PrettyError m () -- ^ - , getFacts :: Query FactField -> EitherT PrettyError m [PFactInfo] -- ^ + , replaceFacts :: [(NodeName, Facts)] -> EitherT PrettyError m () -- ^ + , deactivateNode :: NodeName -> EitherT PrettyError m () -- ^ + , getFacts :: Query FactField -> EitherT PrettyError m [FactInfo] -- ^ , getResources :: Query ResourceField -> EitherT PrettyError m [Resource] -- ^ - , getNodes :: Query NodeField -> EitherT PrettyError m [PNodeInfo] + , getNodes :: Query NodeField -> EitherT PrettyError m [NodeInfo] , 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] + , getResourcesOfNode :: NodeName -> Query ResourceField -> EitherT PrettyError m [Resource] } -- | Pretty straightforward way to define the various PuppetDB queries -data Query a = QEqual a T.Text +data Query a = QEqual a Text | QG a Integer | QL a Integer | QGE a Integer | QLE a Integer - | QMatch T.Text T.Text + | QMatch Text T.Text | QAnd [Query a] | QOr [Query a] | QNot (Query a) @@ -494,12 +462,12 @@ | FCertname -- | Fields for the node endpoint -data NodeField = NName | NFact T.Text +data NodeField = NName | NFact Text -- | Fields for the resource endpoint data ResourceField = RTag | RCertname - | RParameter T.Text + | RParameter Text | RType | RTitle | RExported @@ -511,20 +479,17 @@ makeClassy ''LinkInformation makeClassy ''ResDefaults makeClassy ''ResourceModifier -makeClassy ''DaemonMethods makeClassy ''NativeTypeMethods makeClassy ''ScopeInformation makeClassy ''Resource makeClassy ''InterpreterState makeClassy ''InterpreterReader -makeClassy ''ImpureMethods +makeClassy ''IoMethods makeClassy ''CurContainer -makeFields ''WireCatalog -makeFields ''PFactInfo -makeFields ''PNodeInfo +makeClassy ''NodeInfo +makeClassy ''WireCatalog +makeClassy ''FactInfo -rcurcontainer :: Resource -> CurContainerDesc -rcurcontainer r = fromMaybe ContRoot (r ^? rscope . _head) class Monad m => MonadThrowPos m where throwPosError :: Doc -> m a @@ -548,29 +513,18 @@ else mempty string (renderStack stack) throwError (PrettyError (s <+> "at" <+> showPos p <> dstack)) -getCurContainer :: InterpreterMonad CurContainer -{-# INLINABLE getCurContainer #-} -getCurContainer = do - scp <- getScopeName - preuse (scopes . ix scp . scopeContainer) >>= \case - Just x -> return x - Nothing -> throwPosError ("Internal error: can't find the current container for" <+> green (string (T.unpack scp))) - -scopeName :: CurContainerDesc -> T.Text -scopeName (ContRoot ) = "::" -scopeName (ContImported x ) = "::imported::" `T.append` scopeName x -scopeName (ContClass x ) = x -scopeName (ContDefine dt dn _) = "#define/" `T.append` dt `T.append` "/" `T.append` dn -scopeName (ContImport _ x ) = "::import::" `T.append` scopeName x +instance ToRuby PValue where + toRuby = toRuby . toJSON +instance FromRuby PValue where + fromRuby = fmap chk . fromRuby + where + chk (Left x) = Left x + chk (Right x) = case fromJSON x of + Error rr -> Left rr -getScopeName :: InterpreterMonad T.Text -getScopeName = fmap scopeName getScope + Success suc -> Right suc -getScope :: InterpreterMonad CurContainerDesc -{-# INLINABLE getScope #-} -getScope = use curScope >>= \s -> if null s - then throwPosError "Internal error: empty scope!" - else return (head s) +-- JSON INSTANCES -- instance FromJSON PValue where parseJSON Null = return PUndef @@ -589,70 +543,6 @@ toJSON (PHash x) = Object (HM.map toJSON x) toJSON (PNumber n) = Number n -instance ToRuby PValue where - toRuby = toRuby . toJSON -instance FromRuby PValue where - 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)) - where - check (S.Left r) = return (S.Left r) - check (S.Right x) = return (S.Right x) - -safeDecodeUtf8 :: BS.ByteString -> InterpreterMonad T.Text -{-# INLINABLE safeDecodeUtf8 #-} -safeDecodeUtf8 i = return (T.decodeUtf8 i) - -resourceRelations :: Resource -> [(RIdentifier, LinkType)] -resourceRelations = concatMap expandSet . HM.toList . _rrelations - where - expandSet (ri, lts) = [(ri, lt) | lt <- HS.toList lts] - --- | helper for hashmap, in case we want another kind of map .. -ifromList :: (Monoid m, At m, F.Foldable f) => f (Index m, IxValue m) -> m -{-# INLINABLE ifromList #-} -ifromList = F.foldl' (\curm (k,v) -> curm & at k ?~ v) mempty - -ikeys :: (Eq k, Hashable k) => HM.HashMap k v -> HS.HashSet k -{-# INLINABLE ikeys #-} -ikeys = HS.fromList . HM.keys - -isingleton :: (Monoid b, At b) => Index b -> IxValue b -> b -{-# INLINABLE isingleton #-} -isingleton k v = mempty & at k ?~ v - -ifromListWith :: (Monoid m, At m, F.Foldable f) => (IxValue m -> IxValue m -> IxValue m) -> f (Index m, IxValue m) -> m -{-# INLINABLE ifromListWith #-} -ifromListWith f = F.foldl' (\curmap (k,v) -> iinsertWith f k v curmap) mempty - -iinsertWith :: At m => (IxValue m -> IxValue m -> IxValue m) -> Index m -> IxValue m -> m -> m -{-# INLINABLE iinsertWith #-} -iinsertWith f k v m = m & at k %~ mightreplace - where - mightreplace Nothing = Just v - mightreplace (Just x) = Just (f v x) - -iunionWith :: (Hashable k, Eq k) => (v -> v -> v) -> HM.HashMap k v -> HM.HashMap k v -> HM.HashMap k v -{-# INLINABLE iunionWith #-} -iunionWith = HM.unionWith - -fnull :: (Eq x, Monoid x) => x -> Bool -{-# INLINABLE fnull #-} -fnull = (== mempty) - -rid2text :: RIdentifier -> T.Text -rid2text (RIdentifier t n) = capitalizeRT t `T.append` "[" `T.append` capn `T.append` "]" - where - capn = if t == "classe" - then capitalizeRT n - else n - instance ToJSON Resource where toJSON r = object [ ("type", String $ r ^. rid . itype) , ("title", String $ r ^. rid . iname) @@ -667,10 +557,16 @@ relations = r ^. rrelations & HM.fromListWith (V.++) . concatMap changeRelations . HM.toList & HM.map toValue toValue v | V.length v == 1 = V.head v | otherwise = Array v - changeRelations :: (RIdentifier, HS.HashSet LinkType) -> [(T.Text, V.Vector Value)] + changeRelations :: (RIdentifier, HS.HashSet LinkType) -> [(Text, V.Vector Value)] changeRelations (k,v) = do c <- HS.toList v return (rel2text c, V.singleton (String (rid2text k))) + rid2text :: RIdentifier -> Text + rid2text (RIdentifier t n) = capitalizeRT t `T.append` "[" `T.append` capn `T.append` "]" + where + capn = if t == "classe" + then capitalizeRT n + else n instance FromJSON Resource where parseJSON (Object v) = do @@ -690,7 +586,7 @@ _ -> Nothing getResourceIdentifier _ = Nothing -- TODO : properly handle metaparameters - separate :: (Container PValue, HM.HashMap RIdentifier (HS.HashSet LinkType)) -> T.Text -> PValue -> (Container PValue, HM.HashMap RIdentifier (HS.HashSet LinkType)) + separate :: (Container PValue, HM.HashMap RIdentifier (HS.HashSet LinkType)) -> Text -> PValue -> (Container PValue, HM.HashMap RIdentifier (HS.HashSet LinkType)) separate (curAttribs, curRelations) k val = case (fromJSON (String k), getResourceIdentifier val) of (Success rel, Just ri) -> (curAttribs, curRelations & at ri . non mempty . contains rel .~ True) _ -> (curAttribs & at k ?~ val, curRelations) @@ -818,82 +714,25 @@ , ("transaction-uuid", String t) ] -instance ToJSON PFactInfo where - toJSON (PFactInfo n f v) = object [("certname", String n), ("name", String f), ("value", toJSON v)] +instance ToJSON FactInfo where + toJSON (FactInfo n f v) = object [("certname", String n), ("name", String f), ("value", toJSON v)] -instance FromJSON PFactInfo where - parseJSON (Object v) = PFactInfo <$> v .: "certname" <*> v .: "name" <*> v .: "value" +instance FromJSON FactInfo where + parseJSON (Object v) = FactInfo <$> v .: "certname" <*> v .: "name" <*> v .: "value" parseJSON _ = fail "invalid fact info" -instance ToJSON PNodeInfo where - toJSON p = object [ ("name" , toJSON (p ^. nodename)) - , ("deactivated" , toJSON (p ^. deactivated)) - , ("catalog_timestamp", toJSON (p ^. catalogT)) - , ("facts_timestamp" , toJSON (p ^. factsT)) - , ("report_timestamp" , toJSON (p ^. reportT)) +instance ToJSON NodeInfo where + toJSON p = object [ ("name" , toJSON (p ^. nodeInfoName)) + , ("deactivated" , toJSON (p ^. nodeInfoDeactivated)) + , ("catalog_timestamp", toJSON (p ^. nodeInfoCatalogT)) + , ("facts_timestamp" , toJSON (p ^. nodeInfoFactsT)) + , ("report_timestamp" , toJSON (p ^. nodeInfoReportT)) ] -instance FromJSON PNodeInfo where - parseJSON (Object v) = PNodeInfo <$> v .: "name" +instance FromJSON NodeInfo where + parseJSON (Object v) = NodeInfo <$> v .: "name" <*> v .:? "deactivated" .!= False <*> v .: "catalog_timestamp" <*> v .: "facts_timestamp" <*> v .: "report_timestamp" parseJSON _ = fail "invalide node info" - -text2Scientific :: T.Text -> Maybe Scientific -text2Scientific t = case parseOnly rational t of - Left _ -> Nothing - Right s -> Just s - -instance AsNumber PValue where - _Number = prism num2PValue toNumber - where - num2PValue :: Scientific -> PValue - num2PValue = PNumber - toNumber :: PValue -> Either PValue Scientific - toNumber (PNumber n) = Right n - toNumber p@(PString x) = case text2Scientific x of - Just o -> Right o - _ -> Left p - toNumber p = Left p - -initialState :: Facts - -> Container T.Text -- ^ Server settings - -> InterpreterState -initialState facts settings = InterpreterState baseVars initialclass mempty [ContRoot] dummypos mempty [] [] - where - callervars = HM.fromList [("caller_module_name", PString "::" :!: dummypos :!: ContRoot), ("module_name", PString "::" :!: dummypos :!: ContRoot)] - factvars = fmap (\x -> x :!: initialPPos "facts" :!: ContRoot) facts - settingvars = fmap (\x -> PString x :!: initialPPos "settings" :!: ContClass "settings") settings - baseVars = HM.fromList [ ("::", ScopeInformation (factvars `mappend` callervars) mempty mempty (CurContainer ContRoot mempty) mempty S.Nothing) - , ("settings", ScopeInformation settingvars mempty mempty (CurContainer (ContClass "settings") mempty) mempty S.Nothing) - ] - initialclass = mempty & at "::" ?~ (IncludeStandard :!: dummypos) - -dummypos :: PPosition -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 && not extMod - then throwPosError err - else do - srcname <- use (curPos._1.lSourceName) - logWriter priority (wrn <+> "at" <+> string srcname) - -isExternalModule :: InterpreterMonad Bool -isExternalModule = - getScope >>= \case - ContClass n -> isExternal n - ContDefine n _ _ -> isExternal n - _ -> return False - where - isExternal = singleton . IsExternalModule . head . T.splitOn "::" diff --git a/Puppet/Interpreter/Utils.hs b/Puppet/Interpreter/Utils.hs new file mode 100644 --- /dev/null +++ b/Puppet/Interpreter/Utils.hs @@ -0,0 +1,148 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} + +-- | The module should not depend on the Interpreter module +module Puppet.Interpreter.Utils where + +import Control.Lens hiding (Strict) +import Control.Monad.Operational +import Control.Monad.Writer.Class +import qualified Data.ByteString as BS +import qualified Data.HashMap.Strict as HM +import Data.Maybe (fromMaybe) +import qualified Data.Maybe.Strict as S +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Data.Tuple.Strict +import qualified System.Log.Logger as LOG + +import Puppet.Interpreter.Types +import Puppet.Parser.Types +import Puppet.Parser.Utils +import Puppet.Paths +import Puppet.PP + +initialState :: Facts + -> Container Text -- ^ Server settings + -> InterpreterState +initialState facts settings = InterpreterState baseVars initialclass mempty [ContRoot] dummyppos mempty [] [] + where + callervars = HM.fromList [("caller_module_name", PString "::" :!: dummyppos :!: ContRoot), ("module_name", PString "::" :!: dummyppos :!: ContRoot)] + factvars = fmap (\x -> x :!: initialPPos "facts" :!: ContRoot) facts + settingvars = fmap (\x -> PString x :!: initialPPos "settings" :!: ContClass "settings") settings + baseVars = HM.fromList [ ("::", ScopeInformation (factvars `mappend` callervars) mempty mempty (CurContainer ContRoot mempty) mempty S.Nothing) + , ("settings", ScopeInformation settingvars mempty mempty (CurContainer (ContClass "settings") mempty) mempty S.Nothing) + ] + initialclass = mempty & at "::" ?~ (ClassIncludeLike :!: dummyppos) + + +getModulename :: RIdentifier -> Text +getModulename (RIdentifier t n) = + let gm x = case T.splitOn "::" x of + [] -> x + (y:_) -> y + in case t of + "class" -> gm n + _ -> gm t + + +extractPrism :: Doc -> Prism' a b -> a -> InterpreterMonad b +extractPrism msg p a = case preview p a of + Just b -> return b + Nothing -> throwPosError ("Could not extract prism in" <+> msg) + +-- Scope +popScope :: InterpreterMonad () +popScope = curScope %= tail + +pushScope :: CurContainerDesc -> InterpreterMonad () +pushScope s = curScope %= (s :) + +getScopeName :: InterpreterMonad Text +getScopeName = scopeName <$> getScope + +scopeName :: CurContainerDesc -> Text +scopeName (ContRoot ) = "::" +scopeName (ContImported x ) = "::imported::" `T.append` scopeName x +scopeName (ContClass x ) = x +scopeName (ContDefine dt dn _) = "#define/" `T.append` dt `T.append` "/" `T.append` dn +scopeName (ContImport _ x ) = "::import::" `T.append` scopeName x + +getScope :: InterpreterMonad CurContainerDesc +{-# INLINABLE getScope #-} +getScope = use curScope >>= \s -> if null s + then throwPosError "Internal error: empty scope!" + else return (head s) + + +getCurContainer :: InterpreterMonad CurContainer +{-# INLINABLE getCurContainer #-} +getCurContainer = do + scp <- getScopeName + preuse (scopes . ix scp . scopeContainer) >>= \case + Just x -> return x + Nothing -> throwPosError ("Internal error: can't find the current container for" <+> green (string (T.unpack scp))) + +rcurcontainer :: Resource -> CurContainerDesc +rcurcontainer r = fromMaybe ContRoot (r ^? rscope . _head) + +-- Singleton getters available in the InterpreterMonad -- +getPuppetPaths :: InterpreterMonad PuppetDirPaths +getPuppetPaths = singleton PuppetPaths + +getNodeName:: InterpreterMonad NodeName +getNodeName = singleton GetNodeName + +isIgnoredModule :: Text -> InterpreterMonad Bool +isIgnoredModule m = singleton (IsIgnoredModule m) + +-- | 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 && not extMod + then throwPosError err + else do + srcname <- use (curPos._1.lSourceName) + logWriter priority (wrn <+> "at" <+> string srcname) + +isExternalModule :: InterpreterMonad Bool +isExternalModule = + getScope >>= \case + ContClass n -> isExternal n + ContDefine n _ _ -> isExternal n + _ -> return False + where + isExternal = singleton . IsExternalModule . head . T.splitOn "::" + + +-- Logging -- +warn :: (Monad m, MonadWriter InterpreterWriter m) => Doc -> m () +warn d = tell [LOG.WARNING :!: d] + +debug :: (Monad m, MonadWriter InterpreterWriter m) => Doc -> m () +debug d = tell [LOG.DEBUG :!: d] + +logWriter :: (Monad m, MonadWriter InterpreterWriter m) => LOG.Priority -> Doc -> m () +logWriter prio d = tell [prio :!: d] + +-- General -- +isEmpty :: (Eq x, Monoid x) => x -> Bool +isEmpty = (== mempty) + +safeDecodeUtf8 :: BS.ByteString -> InterpreterMonad Text +{-# INLINABLE safeDecodeUtf8 #-} +safeDecodeUtf8 i = return (T.decodeUtf8 i) + +dropInitialColons :: Text -> T.Text +dropInitialColons t = fromMaybe t (T.stripPrefix "::" t) + +normalizeRIdentifier :: Text -> T.Text -> RIdentifier +normalizeRIdentifier = RIdentifier . dropInitialColons diff --git a/Puppet/Lens.hs b/Puppet/Lens.hs --- a/Puppet/Lens.hs +++ b/Puppet/Lens.hs @@ -13,33 +13,19 @@ , _PArray -- * Parsing prism -- * Lenses and Prisms for 'Statement's - , _ResourceDeclaration - , _DefaultDeclaration - , _ResourceOverride - , _ConditionalStatement - , _ClassDeclaration - , _DefineDeclaration - , _Node - , _VariableAssignment - , _MainFunctionCall - , _SHFunctionCall - , _ResourceCollection - , _Dependency - , _TopContainer , _Statements - -- * More primitive prisms for 'Statement's - , _ResourceDeclaration' - , _DefaultDeclaration' - , _ResourceOverride' - , _ConditionalStatement' - , _ClassDeclaration' - , _DefineDeclaration' - , _Node' - , _VariableAssignment' - , _MainFunctionCall' - , _SHFunctionCall' - , _ResourceCollection' - , _Dependency' + , _ResDecl + , _ResDefaultDecl + , _ResOverrDecl + , _ResCollDecl + , _ConditionalDecl + , _ClassDecl + , _DefineDecl + , _NodeDecl + , _VarAssignDecl + , _MainFuncDecl + , _HigherOrderLambdaDecl + , _DepDecl -- * Lenses and Prisms for 'Expression's , _Equal , _Different @@ -78,8 +64,6 @@ import qualified Data.Vector as V import qualified Data.HashMap.Strict as HM -import qualified Data.Text as T -import qualified Data.Maybe.Strict as S import Data.Tuple.Strict hiding (uncurry) import Control.Exception (SomeException, toException, fromException) @@ -88,101 +72,64 @@ --makePrisms ''Statement makePrisms ''Expression -makePrisms ''ResDec -makePrisms ''DefaultDec -makePrisms ''ResOver -makePrisms ''CondStatement -makePrisms ''ClassDecl -makePrisms ''DefineDec -makePrisms ''Nd -makePrisms ''VarAss -makePrisms ''MFC -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 - ResourceDeclaration a -> Right a +_ResDecl :: Prism' Statement ResDecl +_ResDecl = prism ResourceDeclaration $ \x -> case x of + ResourceDeclaration a -> Right a + _ -> Left x +_ResDefaultDecl :: Prism' Statement ResDefaultDecl +_ResDefaultDecl = prism ResourceDefaultDeclaration $ \x -> case x of + ResourceDefaultDeclaration a -> Right a + _ -> Left x +_ResOverrDecl :: Prism' Statement ResOverrideDecl +_ResOverrDecl = prism ResourceOverrideDeclaration $ \x -> case x of + ResourceOverrideDeclaration a -> Right a _ -> Left x -_DefaultDeclaration' :: Prism' Statement DefaultDec -_DefaultDeclaration' = prism DefaultDeclaration $ \x -> case x of - DefaultDeclaration a -> Right a - _ -> Left x -_ResourceOverride' :: Prism' Statement ResOver -_ResourceOverride' = prism ResourceOverride $ \x -> case x of - ResourceOverride a -> Right a - _ -> Left x -_ConditionalStatement' :: Prism' Statement CondStatement -_ConditionalStatement' = prism ConditionalStatement $ \x -> case x of - ConditionalStatement a -> Right a - _ -> Left x -_ClassDeclaration' :: Prism' Statement ClassDecl -_ClassDeclaration' = prism ClassDeclaration $ \x -> case x of - ClassDeclaration a -> Right a - _ -> Left x -_DefineDeclaration' :: Prism' Statement DefineDec -_DefineDeclaration' = prism DefineDeclaration $ \x -> case x of - DefineDeclaration a -> Right a - _ -> Left x -_Node' :: Prism' Statement Nd -_Node' = prism Node $ \x -> case x of - Node a -> Right a - _ -> Left x -_VariableAssignment' :: Prism' Statement VarAss -_VariableAssignment' = prism VariableAssignment $ \x -> case x of - VariableAssignment a -> Right a +_ResCollDecl :: Prism' Statement ResCollDecl +_ResCollDecl = prism ResourceCollectionDeclaration $ \x -> case x of + ResourceCollectionDeclaration a -> Right a + _ -> Left x +_ConditionalDecl :: Prism' Statement ConditionalDecl +_ConditionalDecl = prism ConditionalDeclaration $ \x -> case x of + ConditionalDeclaration a -> Right a _ -> Left x -_MainFunctionCall' :: Prism' Statement MFC -_MainFunctionCall' = prism MainFunctionCall $ \x -> case x of - MainFunctionCall a -> Right a - _ -> Left x -_SHFunctionCall' :: Prism' Statement SFC -_SHFunctionCall' = prism SHFunctionCall $ \x -> case x of - SHFunctionCall a -> Right a - _ -> Left x -_ResourceCollection' :: Prism' Statement RColl -_ResourceCollection' = prism ResourceCollection $ \x -> case x of - ResourceCollection a -> Right a +_ClassDecl :: Prism' Statement ClassDecl +_ClassDecl = prism ClassDeclaration $ \x -> case x of + ClassDeclaration a -> Right a + _ -> Left x +_DefineDecl :: Prism' Statement DefineDecl +_DefineDecl = prism DefineDeclaration $ \x -> case x of + DefineDeclaration a -> Right a + _ -> Left x +_NodeDecl :: Prism' Statement NodeDecl +_NodeDecl = prism NodeDeclaration $ \x -> case x of + NodeDeclaration a -> Right a + _ -> Left x + +_VarAssignDecl :: Prism' Statement VarAssignDecl +_VarAssignDecl = prism VarAssignmentDeclaration $ \x -> case x of + VarAssignmentDeclaration a -> Right a _ -> Left x -_Dependency' :: Prism' Statement Dep -_Dependency' = prism Dependency $ \x -> case x of - Dependency a -> Right a - _ -> Left x +_MainFuncDecl :: Prism' Statement MainFuncDecl +_MainFuncDecl = prism MainFunctionDeclaration $ \x -> case x of + MainFunctionDeclaration a -> Right a + _ -> Left x +_HigherOrderLambdaDecl :: Prism' Statement HigherOrderLambdaDecl +_HigherOrderLambdaDecl = prism HigherOrderLambdaDeclaration $ \x -> case x of + HigherOrderLambdaDeclaration a -> Right a + _ -> Left x +_DepDecl :: Prism' Statement DepDecl +_DepDecl = prism DependencyDeclaration $ \x -> case x of + DependencyDeclaration a -> Right a + _ -> Left x + _TopContainer :: Prism' Statement (V.Vector Statement, Statement) _TopContainer = prism (uncurry TopContainer) $ \x -> case x of TopContainer vs s -> Right (vs,s) _ -> Left x -_ResourceDeclaration :: Prism' Statement (T.Text, Expression, V.Vector (Pair T.Text Expression), Virtuality, PPosition) -_ResourceDeclaration = _ResourceDeclaration' . _ResDec -_DefaultDeclaration :: Prism' Statement (T.Text, V.Vector (Pair T.Text Expression), PPosition) -_DefaultDeclaration = _DefaultDeclaration' . _DefaultDec -_ResourceOverride :: Prism' Statement (T.Text, Expression, V.Vector (Pair T.Text Expression), PPosition) -_ResourceOverride = _ResourceOverride' . _ResOver -_ConditionalStatement :: Prism' Statement (V.Vector (Pair Expression (V.Vector Statement)), PPosition) -_ConditionalStatement = _ConditionalStatement' . _CondStatement -_ClassDeclaration :: Prism' Statement (T.Text, V.Vector (Pair T.Text (S.Maybe Expression)), S.Maybe T.Text, V.Vector Statement, PPosition) -_ClassDeclaration = _ClassDeclaration' . _ClassDecl -_DefineDeclaration :: Prism' Statement (T.Text, V.Vector (Pair T.Text (S.Maybe Expression)), V.Vector Statement, PPosition) -_DefineDeclaration = _DefineDeclaration' . _DefineDec -_Node :: Prism' Statement (NodeDesc, V.Vector Statement, S.Maybe NodeDesc, PPosition) -_Node = _Node' . _Nd -_VariableAssignment :: Prism' Statement (T.Text, Expression, PPosition) -_VariableAssignment = _VariableAssignment' . _VarAss -_MainFunctionCall :: Prism' Statement (T.Text, V.Vector Expression, PPosition) -_MainFunctionCall = _MainFunctionCall' . _MFC -_SHFunctionCall :: Prism' Statement (HFunctionCall, PPosition) -_SHFunctionCall = _SHFunctionCall' . _SFC -_ResourceCollection :: Prism' Statement (CollectorType, T.Text, SearchExpression, V.Vector (Pair T.Text Expression), PPosition) -_ResourceCollection = _ResourceCollection' . _RColl -_Dependency :: Prism' Statement (Pair T.Text Expression, Pair T.Text Expression, LinkType, PPosition) -_Dependency = _Dependency' . _Dep - -- | Incomplete _PResolveExpression :: Prism' Expression PValue _PResolveExpression = prism reinject extract @@ -192,7 +139,7 @@ Left _ -> Left e reinject = Terminal . review _PResolveValue -_PResolveValue :: Prism' UValue PValue +_PResolveValue :: Prism' UnresolvedValue PValue _PResolveValue = prism toU toP where toP uv = case dummyEval (resolveValue uv) of @@ -213,15 +160,15 @@ where sget :: Statement -> V.Vector Statement sget (ClassDeclaration (ClassDecl _ _ _ s _)) = s - sget (DefineDeclaration (DefineDec _ _ s _)) = s - sget (Node (Nd _ s _ _)) = s + sget (DefineDeclaration (DefineDecl _ _ s _)) = s + sget (NodeDeclaration (NodeDecl _ s _ _)) = s sget (TopContainer s _) = s - sget (SHFunctionCall (SFC (HFunctionCall _ _ _ s _) _)) = s + sget (HigherOrderLambdaDeclaration (HigherOrderLambdaDecl (HOLambdaCall _ _ _ s _) _)) = s sget _ = V.empty sset :: Statement -> V.Vector Statement -> Statement sset (ClassDeclaration (ClassDecl n args inh _ p)) s = ClassDeclaration (ClassDecl n args inh s p) - sset (Node (Nd ns _ nd' p)) s = Node (Nd ns s nd' p) - sset (DefineDeclaration (DefineDec n args _ p)) s = DefineDeclaration (DefineDec n args s p) + sset (NodeDeclaration (NodeDecl ns _ nd' p)) s = NodeDeclaration (NodeDecl ns s nd' p) + sset (DefineDeclaration (DefineDecl n args _ p)) s = DefineDeclaration (DefineDecl n args s p) sset (TopContainer _ p) s = TopContainer s p - sset (SHFunctionCall (SFC (HFunctionCall t e pr _ e2) p)) s = SHFunctionCall (SFC (HFunctionCall t e pr s e2) p) + sset (HigherOrderLambdaDeclaration (HigherOrderLambdaDecl (HOLambdaCall t e pr _ e2) p)) s = HigherOrderLambdaDeclaration (HigherOrderLambdaDecl (HOLambdaCall t e pr s e2) p) sset x _ = x diff --git a/Puppet/Manifests.hs b/Puppet/Manifests.hs --- a/Puppet/Manifests.hs +++ b/Puppet/Manifests.hs @@ -1,22 +1,22 @@ -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} module Puppet.Manifests (filterStatements) where -import Puppet.PP -import Puppet.Parser.Types -import Puppet.Interpreter.Types +import Control.Applicative +import Control.Lens +import Control.Monad.Except +import qualified Data.Either.Strict as S +import qualified Data.HashMap.Strict as HM +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Data.Tuple.Strict +import qualified Data.Vector as V +import Text.Regex.PCRE.ByteString.Utils -import Text.Regex.PCRE.ByteString.Utils -import Control.Lens -import Control.Applicative -import Control.Monad.Except -import qualified Data.Vector as V -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import Data.Tuple.Strict -import qualified Data.Either.Strict as S -import qualified Data.HashMap.Strict as HM +import Puppet.Interpreter.Types +import Puppet.Parser.Types +import Puppet.PP -- TODO pre-triage stuff filterStatements :: TopLevelType -> T.Text -> V.Vector Statement -> IO (S.Either PrettyError Statement) @@ -24,9 +24,9 @@ filterStatements TopNode ndename stmts = -- this operation should probably get cached let (!spurious, !directnodes, !regexpmatches, !defaultnode) = V.foldl' triage (V.empty, HM.empty, V.empty, Nothing) stmts - triage curstuff n@(Node (Nd (NodeName !nm) _ _ _)) = curstuff & _2 . at nm ?~ n - triage curstuff n@(Node (Nd (NodeMatch (CompRegex _ !rg)) _ _ _)) = curstuff & _3 %~ (|> (rg :!: n)) - triage curstuff n@(Node (Nd NodeDefault _ _ _)) = curstuff & _4 ?~ n + triage curstuff n@(NodeDeclaration (NodeDecl (NodeName !nm) _ _ _)) = curstuff & _2 . at nm ?~ n + triage curstuff n@(NodeDeclaration (NodeDecl (NodeMatch (CompRegex _ !rg)) _ _ _)) = curstuff & _3 %~ (|> (rg :!: n)) + triage curstuff n@(NodeDeclaration (NodeDecl NodeDefault _ _ _)) = curstuff & _4 ?~ n triage curstuff x = curstuff & _1 %~ (|> x) bsnodename = T.encodeUtf8 ndename checkRegexp :: [Pair Regex Statement] -> ExceptT PrettyError IO (Maybe Statement) @@ -48,14 +48,13 @@ filterStatements x ndename stmts = let (!spurious, !defines, !classes) = V.foldl' triage (V.empty, HM.empty, HM.empty) stmts triage curstuff n@(ClassDeclaration (ClassDecl cname _ _ _ _)) = curstuff & _3 . at cname ?~ n - triage curstuff n@(DefineDeclaration (DefineDec cname _ _ _)) = curstuff & _2 . at cname ?~ n + triage curstuff n@(DefineDeclaration (DefineDecl cname _ _ _)) = curstuff & _2 . at cname ?~ n triage curstuff n = curstuff & _1 %~ (|> n) tc n = if V.null spurious then n else TopContainer spurious n in case x of TopNode -> return (S.Left "Case already covered, shoudln't happen in Puppet.Manifests") - TopSpurious -> return (S.Left "Should not ask for a TopSpurious!!!") TopDefine -> case defines ^. at ndename of Just n -> return (S.Right (tc n)) Nothing -> return (S.Left (PrettyError ("Couldn't find define " <+> ttext ndename))) diff --git a/Puppet/NativeTypes/Cron.hs b/Puppet/NativeTypes/Cron.hs --- a/Puppet/NativeTypes/Cron.hs +++ b/Puppet/NativeTypes/Cron.hs @@ -1,12 +1,15 @@ -module Puppet.NativeTypes.Cron (nativeCron) where +module Puppet.NativeTypes.Cron + (nativeCron) +where +import Control.Lens +import Data.Scientific +import qualified Data.Text as T +import qualified Data.Vector as V +import Puppet.Interpreter.Types +import Puppet.NativeTypes.Helpers +import Puppet.Utils import qualified Text.PrettyPrint.ANSI.Leijen as P -import Puppet.NativeTypes.Helpers -import Puppet.Interpreter.Types -import qualified Data.Text as T -import Control.Lens -import qualified Data.Vector as V -import Data.Scientific nativeCron :: (NativeTypeName, NativeTypeMethods) nativeCron = ("cron", nativetypemethods parameterfunctions return ) diff --git a/Puppet/NativeTypes/File.hs b/Puppet/NativeTypes/File.hs --- a/Puppet/NativeTypes/File.hs +++ b/Puppet/NativeTypes/File.hs @@ -37,9 +37,13 @@ ,("provider" , [values ["posix","windows"]]) ,("purge" , [string, values ["true","false"]]) ,("recurse" , [string, values ["inf","true","false","remote"]]) - ,("recurselimit " , [integer]) + ,("recurselimit" , [integer]) ,("replace" , [string, values ["true","false"]]) - ,("sourceselect " , [values ["first","all"]]) + ,("sourceselect" , [values ["first","all"]]) + ,("seltype" , [string]) + ,("selrange" , [string]) + ,("selinux_ignore_defaults", [string, values ["true","false"]]) + ,("selrole" , [string]) ,("target" , [string]) ,("source" , [rarray, strings, flip runarray checkSource]) ,("seluser" , [string]) diff --git a/Puppet/NativeTypes/Package.hs b/Puppet/NativeTypes/Package.hs --- a/Puppet/NativeTypes/Package.hs +++ b/Puppet/NativeTypes/Package.hs @@ -14,6 +14,7 @@ nativePackage :: (NativeTypeName, NativeTypeMethods) nativePackage = ("package", nativetypemethods parameterfunctions (getFeature >=> checkFeatures)) +-- Features are abilities that some providers may not support. data PackagingFeatures = Holdable | InstallOptions | Installable | Purgeable | UninstallOptions | Uninstallable | Upgradeable | Versionable deriving (Show, Eq, Generic) instance Hashable PackagingFeatures @@ -22,7 +23,7 @@ isFeatureSupported = HM.fromList [ ("aix", HS.fromList [Installable, Uninstallable, Upgradeable, Versionable]) , ("appdmg", HS.fromList [Installable]) , ("apple", HS.fromList [Installable]) - , ("apt", HS.fromList [Holdable, Installable, Purgeable, Uninstallable, Upgradeable, Versionable]) + , ("apt", HS.fromList [Holdable, InstallOptions, Installable, Purgeable, Uninstallable, Upgradeable, Versionable]) , ("aptitude", HS.fromList [Holdable, Installable, Purgeable, Uninstallable, Upgradeable, Versionable]) , ("aptrpm", HS.fromList [Installable, Purgeable, Uninstallable, Upgradeable, Versionable]) , ("blastwave", HS.fromList [Installable, Uninstallable, Upgradeable]) diff --git a/Puppet/PP.hs b/Puppet/PP.hs --- a/Puppet/PP.hs +++ b/Puppet/PP.hs @@ -1,19 +1,23 @@ module Puppet.PP ( ttext - , pshow + , prettyToText , displayNocolor -- * Re-exports , module Text.PrettyPrint.ANSI.Leijen ) where +import Data.Text (Text) import qualified Data.Text as T import Text.PrettyPrint.ANSI.Leijen hiding ((<$>), (<>)) ttext :: T.Text -> Doc ttext = text . T.unpack -pshow :: Doc -> String -pshow d = displayS (renderPretty 0.4 120 d) "" +prettyToText :: Doc -> Text +prettyToText = T.pack . prettyToShow + +prettyToShow :: Doc -> String +prettyToShow d = displayS (renderCompact d) "" -- | A rendering function that drops colors: displayNocolor :: Doc -> String diff --git a/Puppet/Parser.hs b/Puppet/Parser.hs --- a/Puppet/Parser.hs +++ b/Puppet/Parser.hs @@ -8,29 +8,26 @@ , expression ) where +import Control.Applicative +import Control.Lens hiding (noneOf) +import Control.Monad +import Data.Char +import qualified Data.Foldable as F +import qualified Data.Maybe.Strict as S +import Data.Scientific import qualified Data.Text as T import qualified Data.Text.Encoding as T -import qualified Data.Vector as V -import qualified Data.Maybe.Strict as S -import qualified Data.Foldable as F import Data.Tuple.Strict hiding (fst,zip) +import qualified Data.Vector as V +import Text.Megaparsec hiding (token) +import Text.Megaparsec.Expr +import qualified Text.Megaparsec.Lexer as L +import Text.Megaparsec.Text import Text.Regex.PCRE.ByteString.Utils -import Data.Char -import Control.Monad -import Control.Applicative -import Control.Lens hiding (noneOf) - import Puppet.Parser.Types import Puppet.Utils -import Data.Scientific - -import Text.Megaparsec hiding (token) -import Text.Megaparsec.Expr -import Text.Megaparsec.Text -import qualified Text.Megaparsec.Lexer as L - -- | Run a puppet parser against some 'T.Text' input. runPParser :: String -> T.Text -> Either ParseError (V.Vector Statement) runPParser = parse puppetParser @@ -219,10 +216,10 @@ T.pack . concat <$> many ( do { void (char '\\') ; x <- anyChar; return ['\\', x] } <|> some (noneOf "/\\") ) <* symbolic '/' -puppetArray :: Parser UValue +puppetArray :: Parser UnresolvedValue puppetArray = fmap (UArray . V.fromList) (brackets (sepComma expression)) "Array" -puppetHash :: Parser UValue +puppetHash :: Parser UnresolvedValue puppetHash = fmap (UHash . V.fromList) (braces (sepComma hashPart)) "Hash" where hashPart = (:!:) <$> (expression <* operator "=>") @@ -239,7 +236,7 @@ resnames <- brackets (expression `sepBy1` comma) "Resource reference values" return (restype, resnames) -resourceReference :: Parser UValue +resourceReference :: Parser UnresolvedValue resourceReference = do (restype, resnames) <- resourceReferenceRaw return $ UResourceReference restype $ case resnames of @@ -268,12 +265,8 @@ else fail "Function arguments C" return (fname, V.fromList args) -functionCall :: Parser UValue -functionCall = do - (fname, args) <- genFunctionCall False - return $ UFunctionCall fname args -literalValue :: Parser UValue +literalValue :: Parser UnresolvedValue literalValue = token (fmap UString stringLiteral' <|> fmap UString bareword <|> fmap UNumber numericalvalue "Literal Value") where numericalvalue = integerOrDouble >>= \i -> case i of @@ -303,7 +296,12 @@ termRegexp = regexp >>= compileRegexp terminal :: Parser Expression -terminal = terminalG (fmap Terminal (fmap UHFunctionCall (try hfunctionCall) <|> try functionCall)) +terminal = terminalG (fmap Terminal (fmap UHOLambdaCall (try lambdaCall) <|> try funcCall)) + where + funcCall :: Parser UnresolvedValue + funcCall = do + (fname, args) <- genFunctionCall False + return $ UFunctionCall fname args expressionTable :: [[Operator Parser Expression]] expressionTable = [ [ Postfix indexLookupChain ] -- http://stackoverflow.com/questions/10475337/parsec-expr-repeated-prefix-postfix-operator-not-supported @@ -344,30 +342,41 @@ stringExpression :: Parser Expression stringExpression = fmap (Terminal . UInterpolable) interpolableString <|> (reserved "undef" *> return (Terminal UUndef)) <|> fmap (Terminal . UBoolean) puppetBool <|> variable <|> fmap Terminal literalValue -variableAssignment :: Parser VarAss -variableAssignment = do +varAssign :: Parser VarAssignDecl +varAssign = do p <- getPosition v <- variableReference void $ symbolic '=' e <- expression when (T.all isDigit v) (fail "Can't assign fully numeric variables") pe <- getPosition - return (VarAss v e (p :!: pe)) + return (VarAssignDecl v e (p :!: pe)) -nodeStmt :: Parser [Nd] -nodeStmt = do +nodeDecl :: Parser [NodeDecl] +nodeDecl = do p <- getPosition reserved "node" let toString (UString s) = s toString (UNumber n) = scientific2text n - toString _ = error "Can't happen at nodeStmt" + toString _ = error "Can't happen at nodeDecl" nodename = (reserved "default" >> return NodeDefault) <|> fmap (NodeName . toString) literalValue ns <- (fmap NodeMatch termRegexp <|> nodename) `sepBy1` comma inheritance <- option S.Nothing (fmap S.Just (reserved "inherits" *> nodename)) st <- braces statementList pe <- getPosition - return [Nd n st inheritance (p :!: pe) | n <- ns] + return [NodeDecl n st inheritance (p :!: pe) | n <- ns] +defineDecl :: Parser DefineDecl +defineDecl = do + p <- getPosition + reserved "define" + name <- typeName + -- TODO check native type + params <- option V.empty puppetClassParameters + st <- braces statementList + pe <- getPosition + return (DefineDecl name params st (p :!: pe)) + puppetClassParameters :: Parser (V.Vector (Pair T.Text (S.Maybe Expression))) puppetClassParameters = V.fromList <$> parens (sepComma var) where @@ -378,29 +387,18 @@ <$> variableReference <*> (toStrictMaybe <$> optional (symbolic '=' *> expression)) -defineStmt :: Parser DefineDec -defineStmt = do - p <- getPosition - reserved "define" - name <- typeName - -- TODO check native type - params <- option V.empty puppetClassParameters - st <- braces statementList - pe <- getPosition - return (DefineDec name params st (p :!: pe)) - puppetIfStyleCondition :: Parser (Pair Expression (V.Vector Statement)) puppetIfStyleCondition = (:!:) <$> expression <*> braces statementList -unlessCondition :: Parser CondStatement +unlessCondition :: Parser ConditionalDecl unlessCondition = do p <- getPosition reserved "unless" (cond :!: stmts) <- puppetIfStyleCondition pe <- getPosition - return (CondStatement (V.singleton (Not cond :!: stmts)) (p :!: pe)) + return (ConditionalDecl (V.singleton (Not cond :!: stmts)) (p :!: pe)) -ifCondition :: Parser CondStatement +ifCondition :: Parser ConditionalDecl ifCondition = do p <- getPosition reserved "if" @@ -411,9 +409,9 @@ then [] else [Terminal (UBoolean True) :!: elsecond] pe <- getPosition - return (CondStatement (V.fromList (maincond : others ++ ec)) (p :!: pe)) + return (ConditionalDecl (V.fromList (maincond : others ++ ec)) (p :!: pe)) -caseCondition :: Parser CondStatement +caseCondition :: Parser ConditionalDecl caseCondition = do let puppetRegexpCase = do reg <- termRegexp @@ -440,7 +438,7 @@ expr1 <- expression condlist <- braces (some (puppetRegexpCase <|> defaultCase <|> puppetCase)) pe <- getPosition - return (CondStatement (V.fromList (map (condsToExpression expr1) (concat condlist))) (p :!: pe) ) + return (ConditionalDecl (V.fromList (map (condsToExpression expr1) (concat condlist))) (p :!: pe) ) data OperatorChain a = OperatorChain a LinkType (OperatorChain a) | EndOfChain a @@ -461,42 +459,16 @@ depOperator = (operator "->" *> pure RBefore) <|> (operator "~>" *> pure RNotify) --- | Used to parse chains of resource relations -parseRelationships :: Parser a -> Parser (OperatorChain a) -parseRelationships p = do - g <- p - o <- optional depOperator - case o of - Just o' -> OperatorChain g o' <$> parseRelationships p - Nothing -> pure (EndOfChain g) -resourceGroup :: Parser [ResDec] -resourceGroup = do - let resourceName = token stringExpression - resourceDeclaration = do - p <- getPosition - names <- brackets (sepComma1 resourceName) <|> fmap return resourceName - void $ symbolic ':' - vals <- fmap V.fromList (sepComma assignment) - pe <- getPosition - return [(n, vals, p :!: pe) | n <- names ] - groupDeclaration = (,) <$> many (char '@') <*> typeName <* symbolic '{' - (virts, rtype) <- try groupDeclaration -- for matching reasons, this gets a try until the opening brace - let sep = symbolic ';' <|> comma - x <- resourceDeclaration `sepEndBy1` sep - void $ symbolic '}' - virtuality <- case virts of - "" -> return Normal - "@" -> return Virtual - "@@" -> return Exported - _ -> fail "Invalid virtuality" - return [ ResDec rtype rname conts virtuality pos | (rname, conts, pos) <- concat x ] -assignment :: Parser (Pair T.Text Expression) -assignment = (:!:) <$> bw <*> (symbol "=>" *> expression) +assignment :: Parser AttributeDecl +assignment = AttributeDecl <$> key <*> arrowOp <*> expression where - bw = identl (satisfy isAsciiLower) (satisfy acceptable) "Assignment key" + key = identl (satisfy isAsciiLower) (satisfy acceptable) "Assignment key" acceptable x = isAsciiLower x || isAsciiUpper x || isDigit x || (x == '_') || (x == '-') + arrowOp = + (symbol "=>" *> pure AssignArrow) + <|> (symbol "+>" *> pure AppendArrow) searchExpression :: Parser SearchExpression searchExpression = makeExprParser (token searchterm) searchTable @@ -512,8 +484,8 @@ term <- stringExpression return (opr attrib term) -resourceCollection :: Position -> T.Text -> Parser RColl -resourceCollection p restype = do +resCollDecl :: Position -> T.Text -> Parser ResCollDecl +resCollDecl p restype = do openchev <- some (char '<') when (length openchev > 2) (fail "Too many brackets") void $ symbolic '|' @@ -526,10 +498,10 @@ then Collector else ExportedCollector pe <- getPosition - return (RColl collectortype restype e (V.fromList overrides) (p :!: pe) ) + return (ResCollDecl collectortype restype e (V.fromList overrides) (p :!: pe) ) -classDefinition :: Parser ClassDecl -classDefinition = do +classDecl :: Parser ClassDecl +classDecl = do p <- getPosition reserved "class" ClassDecl <$> className @@ -538,70 +510,61 @@ <*> braces statementList <*> ( (p :!:) <$> getPosition ) -mainFunctionCall :: Parser MFC -mainFunctionCall = do +mainFuncDecl :: Parser MainFuncDecl +mainFuncDecl = do p <- getPosition (fname, args) <- genFunctionCall True pe <- getPosition - return (MFC fname args (p :!: pe)) + return (MainFuncDecl fname args (p :!: pe)) -mainHFunctionCall :: Parser SFC -mainHFunctionCall = do +hoLambdaDecl :: Parser HigherOrderLambdaDecl +hoLambdaDecl = do p <- getPosition - fc <- try hfunctionCall + fc <- try lambdaCall pe <- getPosition - return (SFC fc (p :!: pe)) + return (HigherOrderLambdaDecl fc (p :!: pe)) -dotCall :: Parser SFC -dotCall = do +dotLambdaDecl :: Parser HigherOrderLambdaDecl +dotLambdaDecl = do p <- getPosition ex <- expression pe <- getPosition hf <- case ex of - FunctionApplication e (Terminal (UHFunctionCall hf)) -> do - unless (S.isNothing (hf ^. hfexpr)) (fail "Can't call a function with . and ()") - return (hf & hfexpr .~ S.Just e) - Terminal (UHFunctionCall hf) -> do - when (S.isNothing (hf ^. hfexpr)) (fail "This function needs data to operate on") + FunctionApplication e (Terminal (UHOLambdaCall hf)) -> do + unless (S.isNothing (hf ^. hoLambdaExpr)) (fail "Can't call a function with . and ()") + return (hf & hoLambdaExpr .~ S.Just e) + Terminal (UHOLambdaCall hf) -> do + when (S.isNothing (hf ^. hoLambdaExpr)) (fail "This function needs data to operate on") return hf _ -> fail "A method chained by dots." - unless (hf ^. hftype == HFEach) (fail "Expected 'each', the other types of method calls are not supported by language-puppet at the statement level.") - return (SFC hf (p :!: pe)) + unless (hf ^. hoLambdaFunc == LambEach) (fail "Expected 'each', the other types of method calls are not supported by language-puppet at the statement level.") + return (HigherOrderLambdaDecl hf (p :!: pe)) -data ChainableStuff = ChainResColl RColl - | ChainResDecl ResDec - | ChainResRefr T.Text [Expression] PPosition -resourceDefaults :: Parser DefaultDec -resourceDefaults = do +resDefaultDecl :: Parser ResDefaultDecl +resDefaultDecl = do p <- getPosition rnd <- resourceNameRef let assignmentList = V.fromList <$> sepComma1 assignment asl <- braces assignmentList pe <- getPosition - return (DefaultDec rnd asl (p :!: pe)) + return (ResDefaultDecl rnd asl (p :!: pe)) -resourceOverride :: Parser [ResOver] -resourceOverride = do +resOverrideDecl :: Parser [ResOverrideDecl] +resOverrideDecl = do p <- getPosition restype <- resourceNameRef names <- brackets (expression `sepBy1` comma) "Resource reference values" assignments <- V.fromList <$> braces (sepComma assignment) pe <- getPosition - return [ ResOver restype n assignments (p :!: pe) | n <- names ] - -extractResRef :: ChainableStuff -> [(T.Text, Expression, PPosition)] -extractResRef (ChainResColl _) = [] -extractResRef (ChainResDecl (ResDec rt rn _ _ pp)) = [(rt,rn,pp)] -extractResRef (ChainResRefr rt rns pp) = [(rt,rn,pp) | rn <- rns] - -extractChainStatement :: ChainableStuff -> [Statement] -extractChainStatement (ChainResColl r) = [ResourceCollection r] -extractChainStatement (ChainResDecl d) = [ResourceDeclaration d] -extractChainStatement ChainResRefr{} = [] + return [ ResOverrideDecl restype n assignments (p :!: pe) | n <- names ] -chainableStuff :: Parser [Statement] -chainableStuff = do +-- | Heterogeneous chain (interleaving resource declarations with +-- resource references)needs to be supported: +-- class { 'docker::service': } -> +-- Class['docker'] +chainableResources :: Parser [Statement] +chainableResources = do let withresname = do p <- getPosition restype <- resourceNameRef @@ -610,67 +573,99 @@ resnames <- brackets (expression `sepBy1` comma) pe <- getPosition pure (ChainResRefr restype resnames (p :!: pe)) - _ -> ChainResColl <$> resourceCollection p restype - chain <- parseRelationships $ pure <$> try withresname <|> map ChainResDecl <$> resourceGroup + _ -> ChainResColl <$> resCollDecl p restype + chain <- parseRelationships $ pure <$> try withresname <|> map ChainResDecl <$> resDeclGroup let relations = do (g1, g2, lt) <- zipChain chain (rt1, rn1, _ :!: pe1) <- concatMap extractResRef g1 (rt2, rn2, ps2 :!: _ ) <- concatMap extractResRef g2 - return (Dep (rt1 :!: rn1) (rt2 :!: rn2) lt (pe1 :!: ps2)) - return $ map Dependency relations <> (chain ^.. folded . folded . to extractChainStatement . folded) + return (DepDecl (rt1 :!: rn1) (rt2 :!: rn2) lt (pe1 :!: ps2)) + return $ map DependencyDeclaration relations <> (chain ^.. folded . folded . to extractChainStatement . folded) + where + extractResRef :: ChainableRes -> [(T.Text, Expression, PPosition)] + extractResRef (ChainResColl _) = [] + extractResRef (ChainResDecl (ResDecl rt rn _ _ pp)) = [(rt,rn,pp)] + extractResRef (ChainResRefr rt rns pp) = [(rt,rn,pp) | rn <- rns] + extractChainStatement :: ChainableRes -> [Statement] + extractChainStatement (ChainResColl r) = [ResourceCollectionDeclaration r] + extractChainStatement (ChainResDecl d) = [ResourceDeclaration d] + extractChainStatement ChainResRefr{} = [] + + parseRelationships :: Parser a -> Parser (OperatorChain a) + parseRelationships p = do + g <- p + o <- optional depOperator + case o of + Just o' -> OperatorChain g o' <$> parseRelationships p + Nothing -> pure (EndOfChain g) + + resDeclGroup :: Parser [ResDecl] + resDeclGroup = do + let resourceName = token stringExpression + resourceDeclaration = do + p <- getPosition + names <- brackets (sepComma1 resourceName) <|> fmap return resourceName + void $ symbolic ':' + vals <- fmap V.fromList (sepComma assignment) + pe <- getPosition + return [(n, vals, p :!: pe) | n <- names ] + groupDeclaration = (,) <$> many (char '@') <*> typeName <* symbolic '{' + (virts, rtype) <- try groupDeclaration -- for matching reasons, this gets a try until the opening brace + let sep = symbolic ';' <|> comma + x <- resourceDeclaration `sepEndBy1` sep + void $ symbolic '}' + virtuality <- case virts of + "" -> return Normal + "@" -> return Virtual + "@@" -> return Exported + _ -> fail "Invalid virtuality" + return [ ResDecl rtype rname conts virtuality pos | (rname, conts, pos) <- concat x ] + statement :: Parser [Statement] statement = - (pure . SHFunctionCall <$> try dotCall) - <|> (pure . VariableAssignment <$> variableAssignment) - <|> (map Node <$> nodeStmt) - <|> (pure . DefineDeclaration <$> defineStmt) - <|> (pure . ConditionalStatement <$> unlessCondition) - <|> (pure . ConditionalStatement <$> ifCondition) - <|> (pure . ConditionalStatement <$> caseCondition) - <|> (pure . DefaultDeclaration <$> try resourceDefaults) - <|> (map ResourceOverride <$> try resourceOverride) - <|> chainableStuff - {- - <|> resourceGroup - <|> rrGroup - -} - <|> (pure . ClassDeclaration <$> classDefinition) - <|> (pure . SHFunctionCall <$> mainHFunctionCall) - <|> (pure . MainFunctionCall <$> mainFunctionCall) + (pure . HigherOrderLambdaDeclaration <$> try dotLambdaDecl) + <|> (pure . VarAssignmentDeclaration <$> varAssign) + <|> (map NodeDeclaration <$> nodeDecl) + <|> (pure . DefineDeclaration <$> defineDecl) + <|> (pure . ConditionalDeclaration <$> unlessCondition) + <|> (pure . ConditionalDeclaration <$> ifCondition) + <|> (pure . ConditionalDeclaration <$> caseCondition) + <|> (pure . ResourceDefaultDeclaration <$> try resDefaultDecl) + <|> (map ResourceOverrideDeclaration <$> try resOverrideDecl) + <|> chainableResources + <|> (pure . ClassDeclaration <$> classDecl) + <|> (pure . HigherOrderLambdaDeclaration <$> hoLambdaDecl) + <|> (pure . MainFunctionDeclaration <$> mainFuncDecl) "Statement" -statementList :: Parser (V.Vector Statement) -statementList = fmap (V.fromList . concat) (many statement) -{- -- Stuff related to the new functions with "lambdas" --} - -parseHFunction :: Parser HigherFuncType -parseHFunction = (reserved "each" *> pure HFEach) - <|> (reserved "map" *> pure HFMap ) - <|> (reserved "reduce" *> pure HFReduce) - <|> (reserved "filter" *> pure HFFilter) - <|> (reserved "slice" *> pure HFSlice) - -parseHParams :: Parser BlockParameters -parseHParams = between (symbolic '|') (symbolic '|') hp - where - acceptablePart = T.pack <$> identifier - hp = do - vars <- (char '$' *> acceptablePart) `sepBy1` comma - case vars of - [a] -> return (BPSingle a) - [a,b] -> return (BPPair a b) - _ -> fail "Invalid number of variables between the pipes" +statementList :: Parser (V.Vector Statement) +statementList = (V.fromList . concat) <$> many statement -hfunctionCall :: Parser HFunctionCall -hfunctionCall = do +lambdaCall :: Parser HOLambdaCall +lambdaCall = do let toStrict (Just x) = S.Just x toStrict Nothing = S.Nothing - HFunctionCall <$> parseHFunction + HOLambdaCall <$> lambFunc <*> fmap (toStrict . join) (optional (parens (optional expression))) - <*> parseHParams + <*> lambParams <*> (symbolic '{' *> fmap (V.fromList . concat) (many (try statement))) <*> fmap toStrict (optional expression) <* symbolic '}' + where + lambFunc :: Parser LambdaFunc + lambFunc = (reserved "each" *> pure LambEach) + <|> (reserved "map" *> pure LambMap ) + <|> (reserved "reduce" *> pure LambReduce) + <|> (reserved "filter" *> pure LambFilter) + <|> (reserved "slice" *> pure LambSlice) + lambParams :: Parser LambdaParameters + lambParams = between (symbolic '|') (symbolic '|') hp + where + acceptablePart = T.pack <$> identifier + hp = do + vars <- (char '$' *> acceptablePart) `sepBy1` comma + case vars of + [a] -> return (BPSingle a) + [a,b] -> return (BPPair a b) + _ -> fail "Invalid number of variables between the pipes" diff --git a/Puppet/Parser/PrettyPrinter.hs b/Puppet/Parser/PrettyPrinter.hs --- a/Puppet/Parser/PrettyPrinter.hs +++ b/Puppet/Parser/PrettyPrinter.hs @@ -60,14 +60,14 @@ pretty (Terminal a) = pretty a pretty (FunctionApplication e1 e2) = parens (pretty e1) <> text "." <> pretty e2 -instance Pretty HigherFuncType where - pretty HFEach = bold $ red $ text "each" - pretty HFMap = bold $ red $ text "map" - pretty HFReduce = bold $ red $ text "reduce" - pretty HFFilter = bold $ red $ text "filter" - pretty HFSlice = bold $ red $ text "slice" +instance Pretty LambdaFunc where + pretty LambEach = bold $ red $ text "each" + pretty LambMap = bold $ red $ text "map" + pretty LambReduce = bold $ red $ text "reduce" + pretty LambFilter = bold $ red $ text "filter" + pretty LambSlice = bold $ red $ text "slice" -instance Pretty BlockParameters where +instance Pretty LambdaParameters where pretty b = magenta (char '|') <+> vars <+> magenta (char '|') where vars = case b of @@ -81,7 +81,7 @@ pretty (AndSearch s1 s2) = parens (pretty s1) <+> text "and" <+> parens (pretty s2) pretty (OrSearch s1 s2) = parens (pretty s1) <+> text "and" <+> parens (pretty s2) -instance Pretty UValue where +instance Pretty UnresolvedValue where pretty (UBoolean True) = dullmagenta $ text "true" pretty (UBoolean False) = dullmagenta $ text "false" pretty (UString s) = char '"' <> dullcyan (ttext (stringEscape s)) <> char '"' @@ -99,10 +99,10 @@ pretty (URegexp (CompRegex r _)) = char '/' <> text (T.unpack r) <> char '/' pretty (UVariableReference v) = dullblue (char '$' <> text (T.unpack v)) pretty (UFunctionCall f args) = showFunc f args - pretty (UHFunctionCall c) = pretty c + pretty (UHOLambdaCall c) = pretty c -instance Pretty HFunctionCall where - pretty (HFunctionCall hf me bp stts mee) = pretty hf <> mme <+> pretty bp <+> nest 2 (char '{' <$> ppStatements stts <> mmee) <$> char '}' +instance Pretty HOLambdaCall where + pretty (HOLambdaCall hf me bp stts mee) = pretty hf <> mme <+> pretty bp <+> nest 2 (char '{' <$> ppStatements stts <> mmee) <$> char '}' where mme = case me of S.Just x -> mempty <+> pretty x @@ -120,20 +120,23 @@ pretty RBefore = "->" pretty RSubscribe = "<~" +instance Pretty ArrowOp where + pretty AssignArrow = "=>" + pretty AppendArrow = "+>" + showPos :: Position -> Doc showPos p = green (char '#' <+> string (show p)) showPPos :: PPosition -> Doc showPPos p = green (char '#' <+> string (show (S.fst p))) -showAss :: V.Vector (Pair T.Text Expression) -> Doc -showAss v = folddoc (\a b -> a <> char ',' <$> b) rh lst +showAss :: V.Vector AttributeDecl -> Doc +showAss vx = folddoc (\a b -> a <> char ',' <$> b) prettyDecl (V.toList vx) where folddoc _ _ [] = empty - folddoc docAppend docGen (x:xs) = foldl docAppend (docGen x) (map docGen xs) - lst = V.toList v - maxlen = maximum (map (T.length . S.fst) lst) - rh (k :!: val) = dullblue (fill maxlen (text (T.unpack k))) <+> text "=>" <+> pretty val + folddoc acc docGen (x:xs) = foldl acc (docGen x) (map docGen xs) + maxlen = maximum (fmap (\(AttributeDecl k _ _) -> T.length k) vx) + prettyDecl (AttributeDecl k op v) = dullblue (fill maxlen (ttext k)) <+> pretty op <+> pretty v showArgs :: V.Vector (Pair T.Text (S.Maybe Expression)) -> Doc showArgs vec = tupled (map ra lst) @@ -156,8 +159,8 @@ pretty (NodeMatch r) = pretty (URegexp r) instance Pretty Statement where - pretty (SHFunctionCall (SFC c p)) = pretty c <+> showPPos p - pretty (ConditionalStatement (CondStatement conds p)) + pretty (HigherOrderLambdaDeclaration (HigherOrderLambdaDecl c p)) = pretty c <+> showPPos p + pretty (ConditionalDeclaration (ConditionalDecl conds p)) | V.null conds = empty | otherwise = text "if" <+> pretty firstcond <+> showPPos p <+> braceStatements firststts <$> vcat (map rendernexts xs) where @@ -165,10 +168,10 @@ rendernexts (Terminal (UBoolean True) :!: st) = text "else" <+> braceStatements st rendernexts (c :!: st) | V.null st = empty | otherwise = text "elsif" <+> pretty c <+> braceStatements st - pretty (MainFunctionCall (MFC funcname args p)) = showFunc funcname args <+> showPPos p - pretty (DefaultDeclaration (DefaultDec rtype defaults p)) = capitalize rtype <+> nest 2 (char '{' <+> showPPos p <$> showAss defaults) <$> char '}' - pretty (ResourceOverride (ResOver rtype rnames overs p)) = pretty (UResourceReference rtype rnames) <+> nest 2 (char '{' <+> showPPos p <$> showAss overs) <$> char '}' - pretty (ResourceDeclaration (ResDec rtype rname args virt p)) = nest 2 (red vrt <> dullgreen (text (T.unpack rtype)) <+> char '{' <+> showPPos p + pretty (MainFunctionDeclaration (MainFuncDecl funcname args p)) = showFunc funcname args <+> showPPos p + pretty (ResourceDefaultDeclaration (ResDefaultDecl rtype defaults p)) = capitalize rtype <+> nest 2 (char '{' <+> showPPos p <$> showAss defaults) <$> char '}' + pretty (ResourceOverrideDeclaration (ResOverrideDecl rtype rnames overs p)) = pretty (UResourceReference rtype rnames) <+> nest 2 (char '{' <+> showPPos p <$> showAss overs) <$> char '}' + pretty (ResourceDeclaration (ResDecl rtype rname args virt p)) = nest 2 (red vrt <> dullgreen (text (T.unpack rtype)) <+> char '{' <+> showPPos p <$> nest 2 (pretty rname <> char ':' <$> showAss args)) <$> char '}' where @@ -177,22 +180,22 @@ Virtual -> char '@' Exported -> text "@@" ExportedRealized -> text "!!" - pretty (DefineDeclaration (DefineDec cname args stts p)) = dullyellow (text "define") <+> dullgreen (ttext cname) <> showArgs args <+> showPPos p <$> braceStatements stts + pretty (DefineDeclaration (DefineDecl cname args stts p)) = dullyellow (text "define") <+> dullgreen (ttext cname) <> showArgs args <+> showPPos p <$> braceStatements stts pretty (ClassDeclaration (ClassDecl cname args inherit stts p)) = dullyellow (text "class") <+> dullgreen (text (T.unpack cname)) <> showArgs args <> inheritance <+> showPPos p <$> braceStatements stts where inheritance = case inherit of S.Nothing -> empty S.Just x -> empty <+> text "inherits" <+> text (T.unpack x) - pretty (VariableAssignment (VarAss a b p)) = dullblue (char '$' <> text (T.unpack a)) <+> char '=' <+> pretty b <+> showPPos p - pretty (Node (Nd nodename stmts i p)) = dullyellow (text "node") <+> pretty nodename <> inheritance <+> showPPos p <$> braceStatements stmts + pretty (VarAssignmentDeclaration (VarAssignDecl a b p)) = dullblue (char '$' <> text (T.unpack a)) <+> char '=' <+> pretty b <+> showPPos p + pretty (NodeDeclaration (NodeDecl nodename stmts i p)) = dullyellow (text "node") <+> pretty nodename <> inheritance <+> showPPos p <$> braceStatements stmts where inheritance = case i of S.Nothing -> empty S.Just n -> empty <+> text "inherits" <+> pretty n - pretty (Dependency (Dep (st :!: sn) (dt :!: dn) lt p)) = pretty (UResourceReference st sn) <+> pretty lt <+> pretty (UResourceReference dt dn) <+> showPPos p + pretty (DependencyDeclaration (DepDecl (st :!: sn) (dt :!: dn) lt p)) = pretty (UResourceReference st sn) <+> pretty lt <+> pretty (UResourceReference dt dn) <+> showPPos p pretty (TopContainer a b) = text "TopContainer:" <+> braces ( nest 2 (string "TOP" <$> braceStatements a <$> string "STATEMENT" <$> pretty b)) - pretty (ResourceCollection (RColl coltype restype search overrides p)) = capitalize restype <> enc (pretty search) <+> overs + pretty (ResourceCollectionDeclaration (ResCollDecl coltype restype search overrides p)) = capitalize restype <> enc (pretty search) <+> overs where overs | V.null overrides = showPPos p | otherwise = nest 2 (char '{' <+> showPPos p <$> showAss overrides) <$> char '}' diff --git a/Puppet/Parser/Types.hs b/Puppet/Parser/Types.hs --- a/Puppet/Parser/Types.hs +++ b/Puppet/Parser/Types.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} -- | All the types used for parsing, and helpers working on these types. module Puppet.Parser.Types ( -- * Position management @@ -18,11 +19,12 @@ -- ** Expressions Expression(..), SelectorCase(..), - UValue(..), - HigherFuncType(..), - HFunctionCall(..), - HasHFunctionCall(..), - BlockParameters(..), + UnresolvedValue(..), + LambdaFunc(..), + HOLambdaCall(..), + ChainableRes(..), + HasHOLambdaCall(..), + LambdaParameters(..), CompRegex(..), CollectorType(..), Virtuality(..), @@ -31,44 +33,46 @@ -- ** Search Expressions SearchExpression(..), -- ** Statements - Statement(..), - ResDec(..), - DefaultDec(..), - ResOver(..), - CondStatement(..), + ArrowOp(..), + AttributeDecl(..), + ConditionalDecl(..), ClassDecl(..), - DefineDec(..), - Nd(..), - VarAss(..), - MFC(..), - SFC(..), - RColl(..), - Dep(..) + ResDefaultDecl(..), + DepDecl(..), + Statement(..), + ResDecl(..), + ResOverrideDecl(..), + DefineDecl(..), + NodeDecl(..), + VarAssignDecl(..), + MainFuncDecl(..), + HigherOrderLambdaDecl(..), + ResCollDecl(..) ) where - import Control.Lens - import Data.Aeson import Data.Char (toUpper) import Data.Hashable import qualified Data.Maybe.Strict as S import Data.Scientific import Data.String +import Data.Text (Text) import qualified Data.Text as T import Data.Tuple.Strict import qualified Data.Vector as V +import GHC.Exts import GHC.Generics import Text.Megaparsec.Pos import Text.Regex.PCRE.String -- | Properly capitalizes resource types -capitalizeRT :: T.Text -> T.Text +capitalizeRT :: Text -> Text capitalizeRT = T.intercalate "::" . map capitalize' . T.splitOn "::" where - capitalize' :: T.Text -> T.Text + capitalize' :: Text -> Text capitalize' t | T.null t = T.empty | otherwise = T.cons (toUpper (T.head t)) (T.tail t) @@ -88,71 +92,92 @@ lSourceColumn = lens sourceColumn setSourceColumn -- | Generates an initial position based on a filename. -initialPPos :: T.Text -> PPosition +initialPPos :: Text -> PPosition initialPPos x = let i = initialPos (T.unpack x) in (i :!: i) -- | Generates a 'PPosition' based on a filename and line number. -toPPos :: T.Text -> Int -> PPosition +toPPos :: Text -> Int -> PPosition toPPos fl ln = let p = newPos (T.unpack fl) ln (-1) in (p :!: p) --- | The distinct Puppet /higher order functions/ -data HigherFuncType = HFEach - | HFMap - | HFReduce - | HFFilter - | HFSlice - deriving (Eq, Show) +-- | High Order "lambdas" +data LambdaFunc + = LambEach + | LambMap + | LambReduce + | LambFilter + | LambSlice + deriving (Eq, Show) --- | Currently only two types of block parameters are supported, single --- values and pairs. -data BlockParameters = BPSingle !T.Text -- ^ @|k|@ - | BPPair !T.Text !T.Text -- ^ @|k,v|@ - deriving (Eq, Show) +-- | Lambda block parameters: +-- Currently only two types of block parameters are supported: +-- single values and pairs. +data LambdaParameters + = BPSingle !Text -- ^ @|k|@ + | BPPair !Text !Text -- ^ @|k,v|@ + deriving (Eq, Show) --- The description of the /higher level function/ call. -data HFunctionCall = HFunctionCall - { _hftype :: !HigherFuncType - , _hfexpr :: !(S.Maybe Expression) - , _hfparams :: !BlockParameters - , _hfstatements :: !(V.Vector Statement) - , _hfexpression :: !(S.Maybe Expression) +-- The description of the /higher level lambda/ call. +data HOLambdaCall = HOLambdaCall + { _hoLambdaFunc :: !LambdaFunc + , _hoLambdaExpr :: !(S.Maybe Expression) + , _hoLambdaParams :: !LambdaParameters + , _hoLambdaStatements :: !(V.Vector Statement) + , _hoLambdaLastExpr :: !(S.Maybe Expression) } deriving (Eq,Show) -data CompRegex = CompRegex !T.Text !Regex +data ChainableRes + = ChainResColl !ResCollDecl + | ChainResDecl !ResDecl + | ChainResRefr !Text [Expression] !PPosition + deriving (Show, Eq) + +data AttributeDecl = AttributeDecl !Text !ArrowOp !Expression + deriving (Show, Eq) +data ArrowOp + = AppendArrow -- ^ `+>` + | AssignArrow -- ^ `=>` + deriving (Show, Eq) + +data CompRegex = CompRegex !Text !Regex instance Show CompRegex where show (CompRegex t _) = show t instance Eq CompRegex where (CompRegex a _) == (CompRegex b _) = a == b -- | An unresolved value, typically the parser's output. -data UValue +data UnresolvedValue = UBoolean !Bool -- ^ Special tokens generated when parsing the @true@ or @false@ literals. - | UString !T.Text -- ^ Raw string. + | UString !Text -- ^ Raw string. | UInterpolable !(V.Vector Expression) -- ^ A string that might contain variable references. The type should be refined at one point. | UUndef -- ^ Special token that is generated when parsing the @undef@ literal. - | UResourceReference !T.Text !Expression -- ^ A Resource[reference] + | UResourceReference !Text !Expression -- ^ A Resource[reference] | UArray !(V.Vector Expression) | UHash !(V.Vector (Pair Expression Expression)) | URegexp !CompRegex -- ^ The regular expression compilation is performed during parsing. - | UVariableReference !T.Text - | UFunctionCall !T.Text !(V.Vector Expression) - | UHFunctionCall !HFunctionCall - | UNumber Scientific + | UVariableReference !Text + | UFunctionCall !Text !(V.Vector Expression) + | UHOLambdaCall !HOLambdaCall + | UNumber !Scientific deriving (Show, Eq) +instance IsList UnresolvedValue where + type Item UnresolvedValue = Expression + fromList = UArray . V.fromList + toList u = case u of + UArray lst -> V.toList lst + _ -> [Terminal u] -instance IsString UValue where +instance IsString UnresolvedValue where fromString = UString . T.pack - - -data SelectorCase = SelectorValue UValue - | SelectorDefault - deriving (Eq, Show) +data SelectorCase + = SelectorValue !UnresolvedValue + | SelectorDefault + deriving (Eq, Show) -- | The 'Expression's data Expression @@ -179,9 +204,16 @@ | Negate !Expression | ConditionalValue !Expression !(V.Vector (Pair SelectorCase Expression)) -- ^ All conditionals are stored in this format. | FunctionApplication !Expression !Expression -- ^ This is for /higher order functions/. - | Terminal !UValue + | Terminal !UnresolvedValue -- ^ Terminal object contains no expression deriving (Eq, Show) +instance IsList Expression where + type Item Expression = Expression + fromList = Terminal . fromList + toList u = case u of + Terminal t -> toList t + _ -> [u] + instance Num Expression where (+) = Addition (-) = Substraction @@ -200,33 +232,43 @@ instance IsString Expression where fromString = Terminal . fromString +-- | Search expression inside collector `<| searchexpr |>` data SearchExpression - = EqualitySearch !T.Text !Expression - | NonEqualitySearch !T.Text !Expression + = EqualitySearch !Text !Expression + | NonEqualitySearch !Text !Expression | AndSearch !SearchExpression !SearchExpression | OrSearch !SearchExpression !SearchExpression | AlwaysTrue deriving (Eq, Show) -data CollectorType = Collector | ExportedCollector +data CollectorType + = Collector + | ExportedCollector deriving (Eq, Show) -data Virtuality = Normal -- ^ Normal resource, that will be included in the catalog - | Virtual -- ^ Type for virtual resources - | Exported -- ^ Type for exported resources - | ExportedRealized -- ^ These are resources that are exported AND included in the catalog - deriving (Generic, Eq, Show) +data Virtuality + = Normal -- ^ Normal resource, that will be included in the catalog + | Virtual -- ^ Type for virtual resources + | Exported -- ^ Type for exported resources + | ExportedRealized -- ^ These are resources that are exported AND included in the catalogderiving (Generic, Eq, Show) + deriving (Eq, Show) -data NodeDesc = NodeName !T.Text - | NodeMatch !CompRegex - | NodeDefault - deriving (Show, Eq) +data NodeDesc + = NodeName !Text + | NodeMatch !CompRegex + | NodeDefault + deriving (Show, Eq) -- | Relationship link type. -data LinkType = RNotify | RRequire | RBefore | RSubscribe deriving(Show, Eq,Generic) +data LinkType + = RNotify + | RRequire + | RBefore + | RSubscribe + deriving(Show, Eq,Generic) instance Hashable LinkType -rel2text :: LinkType -> T.Text +rel2text :: LinkType -> Text rel2text RNotify = "notify" rel2text RRequire = "require" rel2text RBefore = "before" @@ -242,38 +284,57 @@ instance ToJSON LinkType where toJSON = String . rel2text -data ResDec = ResDec !T.Text !Expression !(V.Vector (Pair T.Text Expression)) !Virtuality !PPosition deriving (Eq, Show) -data DefaultDec = DefaultDec !T.Text !(V.Vector (Pair T.Text Expression)) !PPosition deriving (Eq, Show) -data ResOver = ResOver !T.Text !Expression !(V.Vector (Pair T.Text Expression)) !PPosition deriving (Eq, Show) +-- | Resource declaration: e.g `file { mode => 755}` +data ResDecl = ResDecl !Text !Expression !(V.Vector AttributeDecl) !Virtuality !PPosition deriving (Eq, Show) + +-- | Resource default: e.g `File { mode => 755 }` +-- https://docs.puppetlabs.com/puppet/latest/reference/lang_defaults.html#language:-resource-default-statements +data ResDefaultDecl = ResDefaultDecl !Text !(V.Vector AttributeDecl) !PPosition deriving (Eq, Show) + +-- | Resource override: e.g `File['title'] { mode => 755}` +-- https://docs.puppetlabs.com/puppet/latest/reference/lang_resources_advanced.html#amending-attributes-with-a-resource-reference +data ResOverrideDecl = ResOverrideDecl !Text !Expression !(V.Vector AttributeDecl) !PPosition deriving (Eq, Show) + -- | All types of conditional statements (@case@, @if@, etc.) are stored as an ordered list of pair (condition, statements) -- (interpreted as "if first cond is true, choose first statements, else take the next pair, check the condition ...") -data CondStatement = CondStatement !(V.Vector (Pair Expression (V.Vector Statement))) !PPosition deriving (Eq, Show) -data ClassDecl = ClassDecl !T.Text !(V.Vector (Pair T.Text (S.Maybe Expression))) !(S.Maybe T.Text) !(V.Vector Statement) !PPosition deriving (Eq, Show) -data DefineDec = DefineDec !T.Text !(V.Vector (Pair T.Text (S.Maybe Expression))) !(V.Vector Statement) !PPosition deriving (Eq, Show) -data Nd = Nd !NodeDesc !(V.Vector Statement) !(S.Maybe NodeDesc) !PPosition deriving (Eq, Show) -data VarAss = VarAss !T.Text !Expression !PPosition deriving (Eq, Show) -data MFC = MFC !T.Text !(V.Vector Expression) !PPosition deriving (Eq, Show) +data ConditionalDecl = ConditionalDecl !(V.Vector (Pair Expression (V.Vector Statement))) !PPosition deriving (Eq, Show) + +data ClassDecl = ClassDecl !Text !(V.Vector (Pair Text (S.Maybe Expression))) !(S.Maybe Text) !(V.Vector Statement) !PPosition deriving (Eq, Show) +data DefineDecl = DefineDecl !Text !(V.Vector (Pair Text (S.Maybe Expression))) !(V.Vector Statement) !PPosition deriving (Eq, Show) + +-- | A node is a collection of statements + maybe an inherit node +data NodeDecl = NodeDecl !NodeDesc !(V.Vector Statement) !(S.Maybe NodeDesc) !PPosition deriving (Eq, Show) + +-- | e.g $newvar = 'world' +data VarAssignDecl = VarAssignDecl !Text !Expression !PPosition deriving (Eq, Show) + +data MainFuncDecl = MainFuncDecl !Text !(V.Vector Expression) !PPosition deriving (Eq, Show) + -- | /Higher order function/ call. -data SFC = SFC !HFunctionCall !PPosition deriving (Eq, Show) --- | For all types of collectors. -data RColl = RColl !CollectorType !T.Text !SearchExpression !(V.Vector (Pair T.Text Expression)) !PPosition deriving (Eq, Show) -data Dep = Dep !(Pair T.Text Expression) !(Pair T.Text Expression) !LinkType !PPosition deriving (Eq, Show) +data HigherOrderLambdaDecl = HigherOrderLambdaDecl !HOLambdaCall !PPosition deriving (Eq, Show) +-- | Resource Collector including exported collector (`<<| |>>`) +-- e.g `User <| title == 'jenkins' |> { groups +> "docker"}` +-- https://docs.puppetlabs.com/puppet/latest/reference/lang_collectors.html#language:-resource-collectors +data ResCollDecl = ResCollDecl !CollectorType !Text !SearchExpression !(V.Vector AttributeDecl) !PPosition deriving (Eq, Show) + +data DepDecl = DepDecl !(Pair Text Expression) !(Pair Text Expression) !LinkType !PPosition deriving (Eq, Show) + -- | All the possible statements data Statement - = ResourceDeclaration !ResDec - | DefaultDeclaration !DefaultDec - | ResourceOverride !ResOver - | ConditionalStatement !CondStatement + = ResourceDeclaration !ResDecl + | ResourceDefaultDeclaration !ResDefaultDecl + | ResourceOverrideDeclaration !ResOverrideDecl + | ResourceCollectionDeclaration !ResCollDecl | ClassDeclaration !ClassDecl - | DefineDeclaration !DefineDec - | Node !Nd - | VariableAssignment !VarAss - | MainFunctionCall !MFC - | SHFunctionCall !SFC - | ResourceCollection !RColl - | Dependency !Dep - | TopContainer !(V.Vector Statement) !Statement -- ^ This is a special statement that is used to include the expressions that are top level. This is certainly buggy, but probably just like the original implementation. + | DefineDeclaration !DefineDecl + | NodeDeclaration !NodeDecl + | ConditionalDeclaration !ConditionalDecl + | VarAssignmentDeclaration !VarAssignDecl + | MainFunctionDeclaration !MainFuncDecl + | HigherOrderLambdaDeclaration !HigherOrderLambdaDecl + | DependencyDeclaration !DepDecl + | TopContainer !(V.Vector Statement) !Statement -- ^ Special statement used to include the expressions that are top level. Certainly buggy, but probably just like the original implementation. deriving (Eq, Show) -makeClassy ''HFunctionCall +makeClassy ''HOLambdaCall diff --git a/Puppet/Parser/Utils.hs b/Puppet/Parser/Utils.hs new file mode 100644 --- /dev/null +++ b/Puppet/Parser/Utils.hs @@ -0,0 +1,12 @@ +module Puppet.Parser.Utils where + +import Text.Megaparsec.Pos + +import Puppet.Parser.Types + + +dummyppos :: PPosition +dummyppos = initialPPos "dummy" + +dummypos :: Position +dummypos = initialPos "dummy" diff --git a/Puppet/Pathes.hs b/Puppet/Pathes.hs deleted file mode 100644 --- a/Puppet/Pathes.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module Puppet.Pathes where - -import Control.Lens -import Data.Monoid - -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 - -defaultPathes :: String -> PuppetDirPaths -defaultPathes basedir = PuppetDirPaths basedir manifestdir modulesdir templatedir testdir - where - manifestdir = basedir <> "/manifests" - modulesdir = basedir <> "/modules" - templatedir = basedir <> "/templates" - testdir = basedir <> "/tests" diff --git a/Puppet/Paths.hs b/Puppet/Paths.hs new file mode 100644 --- /dev/null +++ b/Puppet/Paths.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE TemplateHaskell #-} +module Puppet.Paths where + +import Control.Lens +import Data.Monoid + +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 + +puppetPaths :: FilePath -> PuppetDirPaths +puppetPaths basedir = PuppetDirPaths basedir manifestdir modulesdir templatedir testdir + where + manifestdir = basedir <> "/manifests" + modulesdir = basedir <> "/modules" + templatedir = basedir <> "/templates" + testdir = basedir <> "/tests" diff --git a/Puppet/Preferences.hs b/Puppet/Preferences.hs --- a/Puppet/Preferences.hs +++ b/Puppet/Preferences.hs @@ -28,7 +28,7 @@ import Puppet.NativeTypes.Helpers import Puppet.Plugins import Puppet.Stdlib -import Puppet.Pathes +import Puppet.Paths import qualified Puppet.Puppetlabs as Puppetlabs import Puppet.Utils import PuppetDB.Dummy @@ -83,7 +83,7 @@ dfPreferences :: FilePath -> IO (Preferences IO) dfPreferences basedir = do - let dirpaths = defaultPathes basedir + let dirpaths = puppetPaths basedir modulesdir = dirpaths ^. modulesPath testdir = dirpaths ^. testPath typenames <- fmap (map takeBaseName) (getFiles (T.pack modulesdir) "lib/puppet/type" ".rb") diff --git a/Puppet/Puppetlabs.hs b/Puppet/Puppetlabs.hs --- a/Puppet/Puppetlabs.hs +++ b/Puppet/Puppetlabs.hs @@ -29,8 +29,8 @@ , ("/docker", "docker_run_flags", mockDockerRunFlags) , ("/postgresql", "postgresql_acls_to_resources_hash", pgAclsToHash) , ("/postgresql", "postgresql_password", pgPassword) - , ("/foreman", "random_password", randomPassword) - , ("/foreman", "cache_data", mockCacheData) + , ("/extlib", "random_password", randomPassword) + , ("/extlib", "cache_data", mockCacheData) ] -- | Build the map of available ext functions @@ -58,21 +58,17 @@ -- | The function is pure and always return the same "random" password randomPassword :: MonadThrowPos m => [PValue] -> m PValue -randomPassword x@[PNumber s] = - PString . Text.pack . randomChars <$> toInt s +randomPassword [PNumber s] = + PString . Text.pack . randomChars <$> scientificToInt s where randomChars n = take n $ randomRs ('a', 'z') (mkStdGen 1) - toInt :: MonadThrowPos m => Scientific -> m Int - toInt s = maybe (throwPosError $ "Unable to convert" <+> pretty x <+> "into an int.") - return - (Sci.toBoundedInteger s) randomPassword _ = throwPosError "expect one single string arguments" mockCacheData :: MonadThrowPos m => [PValue] -> m PValue -mockCacheData [_, b] = return b -mockCacheData arg@_ = throwPosError $ "expect 2 string arguments" <+> pretty arg +mockCacheData [_, _, b] = return b +mockCacheData arg@_ = throwPosError $ "expect 3 string arguments" <+> pretty arg -- | Simple implemenation that does not handle all cases. -- For instance 'auth_option' is currently not implemented. @@ -109,3 +105,9 @@ mockDockerRunFlags :: MonadThrowPos m => [PValue] -> m PValue mockDockerRunFlags arg@[PHash _]= (return . PString . Text.pack . displayNocolor . pretty . head) arg mockDockerRunFlags arg@_ = throwPosError $ "Expect an hash as argument but was" <+> pretty arg + +-- utils +scientificToInt :: MonadThrowPos m => Scientific -> m Int +scientificToInt s = maybe (throwPosError $ "Unable to convert" <+> string (show s) <+> "into an int.") + return + (Sci.toBoundedInteger s) diff --git a/Puppet/Stats.hs b/Puppet/Stats.hs --- a/Puppet/Stats.hs +++ b/Puppet/Stats.hs @@ -22,7 +22,6 @@ type StatsTable = HM.HashMap T.Text StatsPoint newtype MStats = MStats { unMStats :: MVar StatsTable } - -- | Returns the actual statistical values. getStats :: MStats -> IO StatsTable getStats = readMVar . unMStats diff --git a/Puppet/Stdlib.hs b/Puppet/Stdlib.hs --- a/Puppet/Stdlib.hs +++ b/Puppet/Stdlib.hs @@ -1,17 +1,16 @@ {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TupleSections #-} module Puppet.Stdlib (stdlibFunctions) where -import Puppet.Interpreter.Resolve -import Puppet.Interpreter.Types -import Puppet.PP - 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.Maybe (mapMaybe) import Data.Monoid +import Data.List.Split (chunksOf) import qualified Data.Text as T import qualified Data.Text.Encoding as T import Data.Traversable (for) @@ -21,6 +20,11 @@ import qualified Text.PrettyPrint.ANSI.Leijen as PP import Text.Regex.PCRE.ByteString.Utils +import Puppet.Interpreter.Resolve +import Puppet.Interpreter.Types +import Puppet.Interpreter.Utils +import Puppet.PP + -- | Contains the implementation of the StdLib functions. stdlibFunctions :: Container ( [PValue] -> InterpreterMonad PValue ) stdlibFunctions = HM.fromList [ singleArgument "abs" puppetAbs @@ -42,6 +46,7 @@ , singleArgument "getvar" getvar , ("getparam", const $ throwPosError "The getparam function is uncool and shall not be implemented in language-puppet") , ("grep", _grep) + , ("hash", hash) , singleArgument "is_array" isArray , singleArgument "is_domain_name" isDomainName , singleArgument "is_integer" isInteger @@ -55,6 +60,7 @@ , ("merge", merge) , ("member", member) , ("pick", pick) + , ("pick_default", pickDefault) , ("rstrip", stringArrayFunction T.stripEnd) , singleArgument "size" size , singleArgument "str2bool" str2Bool @@ -138,9 +144,10 @@ bool2num x = throwPosError ("bool2num(): Can't convert" <+> pretty x <+> "to boolean") puppetConcat :: [PValue] -> InterpreterMonad PValue -puppetConcat [PArray a, PArray b] = return (PArray (a <> b)) -puppetConcat [a,b] = throwPosError ("concat(): both arguments must be arrays, not" <+> pretty a <+> "or" <+> pretty b) -puppetConcat _ = throwPosError "concat(): expects 2 arguments" +puppetConcat = return . PArray . V.concat . map toArr + where + toArr (PArray x) = x + toArr x = V.singleton x puppetCount :: [PValue] -> InterpreterMonad PValue puppetCount [PArray x] = return (_Integer # V.foldl' cnt 0 x) @@ -207,6 +214,14 @@ _grep [x,_] = throwPosError ("grep(): The first argument must be an Array, not" <+> pretty x) _grep _ = throwPosError "grep(): Expected two arguments." +hash :: [PValue] -> InterpreterMonad PValue +hash [PArray elems] = do + let xs = mapMaybe assocPairs $ chunksOf 2 $ V.toList elems + assocPairs [a,b] = Just (a,b) + assocPairs _ = Nothing + PHash . HM.fromList <$> mapM (\(k,v) -> (,v) <$> resolvePValueString k) xs +hash _ = throwPosError "hash(): Expected and array." + isArray :: PValue -> InterpreterMonad PValue isArray = return . PBoolean . has _PArray @@ -262,20 +277,29 @@ hasKey _ = throwPosError "has_key(): expected two arguments." merge :: [PValue] -> InterpreterMonad PValue -merge [PHash a, PHash b] = return (PHash (b `HM.union` a)) -merge [a,b] = throwPosError ("merge(): Expects two hashes, not" <+> pretty a <+> pretty b) -merge _ = throwPosError "merge(): Expects two hashes" +merge xs | length xs < 2 = throwPosError "merge(): Expects at least two hashes" + | otherwise = let hashcontents = mapM (preview _PHash) xs + in case hashcontents of + Nothing -> throwPosError "merge(): Expects hashes" + Just hashes -> return $ PHash (getDual $ foldMap Dual hashes) pick :: [PValue] -> InterpreterMonad PValue pick [] = throwPosError "pick(): must receive at least one non empty value" -pick (a:as) - | a `elem` [PUndef, PString "", PString "undef"] = pick as - | otherwise = return a +pick xs = case filter (`notElem` [PUndef, PString "", PString "undef"]) xs of + [] -> throwPosError "pick(): no value suitable to be picked" + (x:_) -> return x +pickDefault :: [PValue] -> InterpreterMonad PValue +pickDefault [] = throwPosError "pick_default(): must receive at least one non empty value" +pickDefault xs = case filter (`notElem` [PUndef, PString "", PString "undef"]) xs of + [] -> return (last xs) + (x:_) -> return x + size :: PValue -> InterpreterMonad PValue size (PHash h) = return (_Integer # fromIntegral (HM.size h)) size (PArray v) = return (_Integer # fromIntegral (V.length v)) -size x = throwPosError ("size(): Expects a hash, not" <+> pretty x) +size (PString s) = return (_Integer # fromIntegral (T.length s)) +size x = throwPosError ("size(): Expects a hash, and array or a string, not" <+> pretty x) str2Bool :: PValue -> InterpreterMonad PValue str2Bool PUndef = return (PBoolean False) diff --git a/Puppet/Utils.hs b/Puppet/Utils.hs --- a/Puppet/Utils.hs +++ b/Puppet/Utils.hs @@ -1,31 +1,41 @@ {-# LANGUAGE LambdaCase #-} -- | Those are utility functions, most of them being pretty much self -- explanatory. -module Puppet.Utils - ( textElem - , module Data.Monoid +module Puppet.Utils ( + textElem , getDirectoryContents , takeBaseName , takeDirectory , strictifyEither - , nameThread , loadYamlFile , scientific2text - ) where + , text2Scientific + , ifromList, ikeys, isingleton, ifromListWith, iunionWith, iinsertWith + -- * re-export + , module Data.Monoid +) where +import Data.Attoparsec.Text (parseOnly, rational) import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.ByteString as BS +import qualified Data.Foldable as F +import Data.Hashable +import qualified Data.HashMap.Strict as HM +import qualified Data.HashSet as HS import Data.Monoid import System.Posix.Directory.ByteString import qualified Data.Either.Strict as S -import Control.Concurrent (myThreadId) -import GHC.Conc (labelThread) import Data.Scientific import Control.Lens import Data.Aeson.Lens import qualified Data.Yaml as Y +text2Scientific :: T.Text -> Maybe Scientific +text2Scientific t = case parseOnly rational t of + Left _ -> Nothing + Right s -> Just s + scientific2text :: Scientific -> T.Text scientific2text n = T.pack $ case n ^? _Integer of Just i -> show i @@ -38,9 +48,6 @@ textElem :: Char -> T.Text -> Bool textElem c = T.any (==c) -nameThread :: String -> IO () -nameThread n = myThreadId >>= flip labelThread n - getDirectoryContents :: T.Text -> IO [T.Text] getDirectoryContents fpath = do h <- openDirStream (T.encodeUtf8 fpath) @@ -79,7 +86,6 @@ dropFileName :: T.Text -> T.Text dropFileName = fst . splitFileName - -- | Split a filename into directory and file. 'combine' is the inverse. -- -- > Valid x => uncurry () (splitFileName x) == x || fst (splitFileName x) == "./" @@ -104,3 +110,31 @@ loadYamlFile fp = Y.decodeFileEither fp >>= \case Left rr -> error ("Error when parsing " ++ fp ++ ": " ++ show rr) Right x -> return x + +-- | helper for hashmap, in case we want another kind of map .. +ifromList :: (Monoid m, At m, F.Foldable f) => f (Index m, IxValue m) -> m +{-# INLINABLE ifromList #-} +ifromList = F.foldl' (\curm (k,v) -> curm & at k ?~ v) mempty + +ikeys :: (Eq k, Hashable k) => HM.HashMap k v -> HS.HashSet k +{-# INLINABLE ikeys #-} +ikeys = HS.fromList . HM.keys + +isingleton :: (Monoid b, At b) => Index b -> IxValue b -> b +{-# INLINABLE isingleton #-} +isingleton k v = mempty & at k ?~ v + +ifromListWith :: (Monoid m, At m, F.Foldable f) => (IxValue m -> IxValue m -> IxValue m) -> f (Index m, IxValue m) -> m +{-# INLINABLE ifromListWith #-} +ifromListWith f = F.foldl' (\curmap (k,v) -> iinsertWith f k v curmap) mempty + +iinsertWith :: At m => (IxValue m -> IxValue m -> IxValue m) -> Index m -> IxValue m -> m -> m +{-# INLINABLE iinsertWith #-} +iinsertWith f k v m = m & at k %~ mightreplace + where + mightreplace Nothing = Just v + mightreplace (Just x) = Just (f v x) + +iunionWith :: (Hashable k, Eq k) => (v -> v -> v) -> HM.HashMap k v -> HM.HashMap k v -> HM.HashMap k v +{-# INLINABLE iunionWith #-} +iunionWith = HM.unionWith diff --git a/PuppetDB/Common.hs b/PuppetDB/Common.hs --- a/PuppetDB/Common.hs +++ b/PuppetDB/Common.hs @@ -47,8 +47,8 @@ -- | Turns a 'FinalCatalog' and 'EdgeMap' into a document that can be -- serialized and fed to @puppet apply@. -generateWireCatalog :: Nodename -> FinalCatalog -> EdgeMap -> WireCatalog -generateWireCatalog ndename finalcat edgemap = WireCatalog ndename "version" edges resources "uiid" +generateWireCatalog :: NodeName -> FinalCatalog -> EdgeMap -> WireCatalog +generateWireCatalog node cat edgemap = WireCatalog node "version" edges resources "uiid" where edges = toVectorOf (folded . to (\li -> PuppetEdge (li ^. linksrc) (li ^. linkdst) (li ^. linkType))) (concatOf folded edgemap) - resources = toVectorOf folded finalcat + resources = toVectorOf folded cat diff --git a/PuppetDB/Remote.hs b/PuppetDB/Remote.hs --- a/PuppetDB/Remote.hs +++ b/PuppetDB/Remote.hs @@ -15,9 +15,9 @@ import Data.Aeson import Data.Proxy -type PDBAPIv3 = "nodes" :> QueryParam "query" (Query NodeField) :> Get '[JSON] [PNodeInfo] +type PDBAPIv3 = "nodes" :> QueryParam "query" (Query NodeField) :> Get '[JSON] [NodeInfo] :<|> "nodes" :> Capture "resourcename" Text :> "resources" :> QueryParam "query" (Query ResourceField) :> Get '[JSON] [Resource] - :<|> "facts" :> QueryParam "query" (Query FactField) :> Get '[JSON] [PFactInfo] + :<|> "facts" :> QueryParam "query" (Query FactField) :> Get '[JSON] [FactInfo] :<|> "resources" :> QueryParam "query" (Query ResourceField) :> Get '[JSON] [Resource] type PDBAPI = "v3" :> PDBAPIv3 @@ -39,9 +39,9 @@ (left "operation not supported") (\ndename q -> prettyError $ sgetNodeResources ndename (Just q)) where - sgetNodes :: Maybe (Query NodeField) -> EitherT ServantError IO [PNodeInfo] + sgetNodes :: Maybe (Query NodeField) -> EitherT ServantError IO [NodeInfo] sgetNodeResources :: Text -> Maybe (Query ResourceField) -> EitherT ServantError IO [Resource] - sgetFacts :: Maybe (Query FactField) -> EitherT ServantError IO [PFactInfo] + sgetFacts :: Maybe (Query FactField) -> EitherT ServantError IO [FactInfo] sgetResources :: Maybe (Query ResourceField) -> EitherT ServantError IO [Resource] (sgetNodes :<|> sgetNodeResources :<|> sgetFacts :<|> sgetResources) = client api url diff --git a/PuppetDB/TestDB.hs b/PuppetDB/TestDB.hs --- a/PuppetDB/TestDB.hs +++ b/PuppetDB/TestDB.hs @@ -120,32 +120,32 @@ _ -> False replCat :: DB -> WireCatalog -> EitherT PrettyError IO () -replCat db wc = liftIO $ atomically $ modifyTVar db (resources . at (wc ^. nodename) ?~ wc) +replCat db wc = liftIO $ atomically $ modifyTVar db (resources . at (wc ^. wireCatalogNodename) ?~ wc) -replFacts :: DB -> [(Nodename, Facts)] -> EitherT PrettyError IO () +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 -> EitherT PrettyError IO () +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 -> EitherT PrettyError IO [PFactInfo] +getFcts :: DB -> Query FactField -> EitherT PrettyError IO [FactInfo] getFcts db f = fmap (filter (resolveQuery factQuery f) . toFactInfo) (liftIO $ readTVarIO db) where - toFactInfo :: DBContent -> [PFactInfo] + toFactInfo :: DBContent -> [FactInfo] toFactInfo = concatMap gf . HM.toList . _dbcontentFacts where gf (k,n) = do (fn,fv) <- HM.toList n - return $ PFactInfo k fn fv - factQuery :: FactField -> PFactInfo -> Extracted + return $ FactInfo k fn fv + factQuery :: FactField -> FactInfo -> Extracted factQuery t = EText . view l where l = case t of - FName -> factname - FValue -> factval . _PString - FCertname -> nodename + FName -> factInfoName + FValue -> factInfoVal . _PString + FCertname -> factInfoNodename resourceQuery :: ResourceField -> Resource -> Extracted resourceQuery RTag r = r ^. rtags . to ESet @@ -165,13 +165,13 @@ 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 + toResources = concatMap (V.toList . view wireCatalogResources) . HM.elems . view resources -getResNode :: DB -> Nodename -> Query ResourceField -> EitherT PrettyError IO [Resource] +getResNode :: DB -> NodeName -> Query ResourceField -> EitherT PrettyError IO [Resource] getResNode db nn f = do c <- liftIO $ readTVarIO db case c ^. resources . at nn of - Just cnt -> return $ filter (resolveQuery resourceQuery f) $ V.toList $ cnt ^. wResources + Just cnt -> return $ filter (resolveQuery resourceQuery f) $ V.toList $ cnt ^. wireCatalogResources Nothing -> left "Unknown node" commit :: DB -> EitherT PrettyError IO () @@ -181,13 +181,13 @@ Nothing -> left "No backing file defined" Just bf -> liftIO (encodeFile bf dbc `catches` [ ]) -getNds :: DB -> Query NodeField -> EitherT PrettyError IO [PNodeInfo] +getNds :: DB -> Query NodeField -> EitherT PrettyError IO [NodeInfo] getNds db QEmpty = fmap toNodeInfo (liftIO $ readTVarIO db) where - toNodeInfo :: DBContent -> [PNodeInfo] + toNodeInfo :: DBContent -> [NodeInfo] toNodeInfo = fmap g . HM.keys . _dbcontentFacts where - g :: Nodename -> PNodeInfo - g = \n -> PNodeInfo n False S.Nothing S.Nothing S.Nothing + g :: NodeName -> NodeInfo + g = \n -> NodeInfo n False S.Nothing S.Nothing S.Nothing getNds _ _ = left "getNds with query not implemented" diff --git a/language-puppet.cabal b/language-puppet.cabal --- a/language-puppet.cabal +++ b/language-puppet.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: language-puppet -version: 1.1.4.1 +version: 1.1.5 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/ @@ -61,6 +61,7 @@ other-modules: Erb.Compute , Paths_language_puppet , Puppet.Interpreter.RubyRandom + , Puppet.Interpreter.Utils , Puppet.Manifests , Puppet.NativeTypes.Concat , Puppet.NativeTypes.Cron @@ -74,56 +75,56 @@ , Puppet.NativeTypes.SshSecure , Puppet.NativeTypes.User , Puppet.NativeTypes.ZoneRecord - , Puppet.Pathes + , Puppet.Parser.Utils + , Puppet.Paths , Puppet.Plugins extensions: OverloadedStrings, BangPatterns ghc-options: -Wall -funbox-strict-fields -j1 -- ghc-prof-options: -auto-all -caf-all - build-depends: base >=4.8 && < 4.9 - , aeson >= 0.8 && < 0.10 - , ansi-wl-pprint == 0.6.* - , attoparsec >= 0.12 && < 0.14 - , base16-bytestring == 0.1.* - , bifunctors == 5 - , bytestring - , case-insensitive == 1.2.* - , containers == 0.5.* - , cryptonite >= 0.6 - , directory == 1.2.* - , either >= 4.3 && < 4.5 - , exceptions >= 0.8 && < 0.9 - , filecache >= 0.2.9 && < 0.3 - , formatting - , hashable == 1.2.* - , hruby >= 0.3.1.6 && <0.4 - , hslogger == 1.2.* - , hslua >= 0.4 && < 0.5 - , lens >= 4.9 && < 5 - , lens-aeson >= 1.0 - , memory >= 0.7 - , mtl >= 2.2 && < 2.3 - , operational >= 0.2.3 && < 0.3 - , megaparsec == 4.1.* - , parsec == 3.1.* - , parsers >= 0.11 && < 0.13 - , pcre-utils >= 0.1.7 && < 0.2 - , process >= 1.1 && < 1.3 - , random - , regex-pcre-builtin >= 0.94.4 - , scientific >= 0.2 && < 0.4 - , servant == 0.4.* - , servant-client == 0.4.* - , semigroups - , split == 0.2.* - , stm == 2.4.* - , strict-base-types == 0.3.* - , text >= 0.11 - , time >= 1.5 && < 2 - , transformers == 0.4.* - , unix >= 2.6 && < 2.8 - , unordered-containers == 0.2.* - , vector == 0.10.* - , yaml >= 0.8.8 && < 0.9 + build-depends: aeson >= 0.8 + , ansi-wl-pprint == 0.6.* + , attoparsec >= 0.12 + , base >=4.8 && < 4.9 + , base16-bytestring == 0.1.* + , bytestring + , case-insensitive == 1.2.* + , containers == 0.5.* + , cryptonite >= 0.6 + , directory == 1.2.* + , either >= 4.3 && < 4.5 + , exceptions >= 0.8 && < 0.9 + , filecache >= 0.2.9 && < 0.3 + , formatting + , hashable == 1.2.* + , hruby >= 0.3.2 && < 0.4 + , hslogger == 1.2.* + , hslua >= 0.4.1 && < 0.5 + , hspec + , lens >= 4.12 && < 5 + , lens-aeson >= 1.0 + , megaparsec == 4.1.* + , memory >= 0.7 + , mtl >= 2.2 && < 2.3 + , operational >= 0.2.3 && < 0.3 + , parsec == 3.1.* + , pcre-utils >= 0.1.7 && < 0.2 + , process >= 1.2 + , random + , regex-pcre-builtin >= 0.94.4 + , scientific >= 0.2 && < 0.4 + , semigroups + , servant == 0.4.* + , servant-client == 0.4.* + , split == 0.2.* + , stm == 2.4.* + , strict-base-types >= 0.3 + , text >= 0.11 + , time >= 1.5 && < 2 + , transformers == 0.4.* + , unix >= 2.7 && < 2.8 + , unordered-containers == 0.2.* + , vector >= 0.10 + , yaml >= 0.8.8 && < 0.9 Test-Suite test-evals hs-source-dirs: tests type: exitcode-stdio-1.0 @@ -166,13 +167,43 @@ extensions: OverloadedStrings build-depends: language-puppet,base,strict-base-types,lens,text main-is: erb.hs +Test-Suite spec + hs-source-dirs: tests + type: exitcode-stdio-1.0 + ghc-options: -Wall -rtsopts -threaded + extensions: OverloadedStrings + build-depends: language-puppet,base,strict-base-types,lens,text,hspec,unordered-containers,megaparsec,vector,scientific + other-modules: Function.ShellquoteSpec + Function.SizeSpec + Function.MergeSpec + Function.EachSpec + InterpreterSpec + Helpers + main-is: Spec.hs executable puppetresources hs-source-dirs: progs extensions: BangPatterns, OverloadedStrings - ghc-options: -Wall -rtsopts -threaded -with-rtsopts "-A2M" -eventlog + ghc-options: -Wall -rtsopts -funbox-strict-fields -threaded -with-rtsopts "-A2M" -eventlog -- ghc-prof-options: -auto-all -caf-all -fprof-auto - build-depends: language-puppet,base,text,megaparsec,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 + build-depends: base + , Glob + , aeson + , bytestring + , containers + , either + , hslogger + , language-puppet + , lens + , megaparsec + , optparse-applicative + , parallel-io + , regex-pcre-builtin + , servant-client + , strict-base-types + , text + , unordered-containers + , vector main-is: PuppetResources.hs executable pdbquery @@ -180,5 +211,16 @@ 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,either,servant-client + build-depends: base + , bytestring + , either + , language-puppet + , lens + , optparse-applicative + , servant-client + , strict-base-types + , text + , unordered-containers + , vector + , yaml main-is: pdbQuery.hs diff --git a/progs/PuppetResources.hs b/progs/PuppetResources.hs --- a/progs/PuppetResources.hs +++ b/progs/PuppetResources.hs @@ -31,7 +31,7 @@ import qualified Text.Megaparsec as P import qualified Text.Regex.PCRE.String as REG -import Facter +import qualified Facter import Puppet.Daemon import Puppet.Lens import Puppet.Parser @@ -45,7 +45,7 @@ import PuppetDB.TestDB (loadTestDB) -type QueryFunc = Nodename -> IO (S.Either PrettyError (FinalCatalog, EdgeMap, FinalCatalog, [Resource])) +type QueryFunc = NodeName -> IO (S.Either PrettyError (FinalCatalog, EdgeMap, FinalCatalog, [Resource])) data MultNodes = MultNodes [T.Text] | AllNodes deriving Show @@ -60,7 +60,7 @@ , _optResourceType :: Maybe T.Text , _optResourceName :: Maybe T.Text , _optPuppetdir :: Maybe FilePath - , _optNodename :: Maybe Nodename + , _optNodename :: Maybe NodeName , _optMultnodes :: Maybe MultNodes , _optDeadcode :: Bool , _optPdburl :: Maybe String @@ -166,15 +166,15 @@ >>= pdbConnect >>= checkError "Error when connecting to the remote PuppetDB" (_, Just file) -> loadTestDB file >>= checkError "Error when initializing the PuppetDB API" - prf <- dfPreferences workingdir <&> prefPDB .~ pdbapi - <&> prefHieraPath .~ _optHieraFile - <&> prefIgnoredmodules %~ (`fromMaybe` _optIgnoredMods) - <&> (if _optStrictMode then prefStrictness .~ Strict else id) - <&> (if _optNoExtraTests then prefExtraTests .~ False else id) - <&> prefLogLevel .~ _optLoglevel - q <- initDaemon prf - let queryfunc = \node -> fmap (unifyFacts (prf ^. prefFactsDefault) (prf ^. prefFactsOverride)) (puppetDBFacts node pdbapi) >>= _dGetCatalog q node - return (queryfunc, pdbapi, _dParserStats q, _dCatalogStats q, _dTemplateStats q) + pref <- dfPreferences workingdir <&> prefPDB .~ pdbapi + <&> prefHieraPath .~ _optHieraFile + <&> prefIgnoredmodules %~ (`fromMaybe` _optIgnoredMods) + <&> (if _optStrictMode then prefStrictness .~ Strict else id) + <&> (if _optNoExtraTests then prefExtraTests .~ False else id) + <&> prefLogLevel .~ _optLoglevel + d <- initDaemon pref + let queryfunc = \node -> fmap (unifyFacts (pref ^. prefFactsDefault) (pref ^. prefFactsOverride)) (Facter.puppetDBFacts node pdbapi) >>= getCatalog d node + return (queryfunc, pdbapi, parserStats d, catalogStats d, templateStats d) where -- merge 3 sets of facts : some defaults, the original set and some override unifyFacts :: Container PValue -> Container PValue -> Container PValue -> Container PValue @@ -193,8 +193,8 @@ Just x -> print x prepareForPuppetApply :: WireCatalog -> WireCatalog -prepareForPuppetApply w = - let res = V.filter (\r -> r ^. rvirtuality == Normal) (w ^. wResources) :: V.Vector Resource +prepareForPuppetApply wcat = + let res = V.filter (\r -> r ^. rvirtuality == Normal) (wcat ^. wireCatalogResources) :: V.Vector Resource -- step 1 : capitalize resources types (and names in case of -- classes), and filter out exported stuff capi :: RIdentifier -> RIdentifier @@ -205,7 +205,7 @@ aliasMap = HM.fromList $ concatMap genAliasList (res ^.. folded) genAliasList r = map (\n -> (RIdentifier (r ^. rid . itype) n, r ^. rid . iname)) (r ^. rid . iname : r ^.. ralias . folded) nr = V.map (rid %~ capi) res - ne = V.map capEdge (w ^. wEdges) + ne = V.map capEdge (wcat ^. wireCatalogEdges) capEdge (PuppetEdge a b x) = PuppetEdge (capi a) (capi b) x -- step 2 : replace all references with the resource title in case -- of aliases - yes this sucks @@ -219,9 +219,8 @@ correctEdge (PuppetEdge s d x) = PuppetEdge (correct s) (correct d) x correctResource :: Resource -> Resource correctResource r = r & rrelations %~ HM.fromList . filter (\(x,_) -> aliasMap & has (ix x)) . map (_1 %~ correct) . HM.toList - in (wResources .~ correctResources) - . (wEdges .~ correctEdges) - $ w + in wcat & (wireCatalogResources .~ correctResources) + & (wireCatalogEdges .~ correctEdges) -- | Finds the dead code @@ -242,18 +241,18 @@ putDoc ("The following" <+> int (length parseFailed) <+> "files could not be parsed:" indent 4 (vcat (map (string . show) parseFailed))) putStrLn "" let getSubStatements s@(ResourceDeclaration{}) = [s] - getSubStatements (ConditionalStatement (CondStatement conds _)) = conds ^.. traverse . _2 . tgt + getSubStatements (ConditionalDeclaration (ConditionalDecl conds _)) = conds ^.. traverse . _2 . tgt getSubStatements s@(ClassDeclaration{}) = extractPrism s getSubStatements s@(DefineDeclaration{}) = extractPrism s - getSubStatements s@(Node{}) = extractPrism s - getSubStatements s@(SHFunctionCall{}) = extractPrism s + getSubStatements s@(NodeDeclaration{}) = extractPrism s + getSubStatements s@(HigherOrderLambdaDeclaration{}) = extractPrism s getSubStatements (TopContainer v s) = getSubStatements s ++ v ^.. tgt getSubStatements _ = [] tgt = folded . to getSubStatements . folded extractPrism = toListOf (_Statements . traverse . to getSubStatements . traverse) allResources = parseSucceeded ^.. folded . folded . to getSubStatements . folded deadResources = filter isDead allResources - isDead (ResourceDeclaration (ResDec _ _ _ _ pp)) = not $ Set.member pp allpositions + isDead (ResourceDeclaration (ResDecl _ _ _ _ pp)) = not $ Set.member pp allpositions isDead _ = True unless (null deadResources) $ do putDoc ("The following" <+> int (length deadResources) <+> "resource declarations are not used:" indent 4 (vcat (map pretty deadResources))) @@ -269,7 +268,7 @@ -- | For each node, queryfunc the catalog and return stats -computeStats :: FilePath -> Options -> QueryFunc -> (MStats, MStats, MStats) -> [Nodename] -> IO () +computeStats :: FilePath -> Options -> QueryFunc -> (MStats, MStats, MStats) -> [NodeName] -> IO () computeStats workingdir (Options {..}) queryfunc (parsingStats, catalogStats, templateStats) topnodes = do @@ -305,14 +304,14 @@ else do {putDoc (dullgreen "All green." <> line) ; exitSuccess} where - computeCatalog :: QueryFunc -> Nodename -> IO (Maybe (FinalCatalog, [Resource])) + computeCatalog :: QueryFunc -> NodeName -> IO (Maybe (FinalCatalog, [Resource])) computeCatalog func node = func node >>= \case 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 -> QueryFunc -> PuppetDBAPI IO -> NodeName -> IO () computeNodeCatalog (Options {..}) queryfunc pdbapi node = queryfunc node >>= \case S.Left rr -> do @@ -325,11 +324,11 @@ else displayIO stdout (renderCompact x) >> putStrLn "" catalog <- filterCatalog _optResourceType _optResourceName rawcatalog exported <- filterCatalog _optResourceType _optResourceName rawexported - let wireCatalog = generateWireCatalog node (catalog <> exported ) edgemap + let wirecatalog = generateWireCatalog node (catalog <> exported ) edgemap rawWireCatalog = generateWireCatalog node (rawcatalog <> rawexported) edgemap when _optCheckExport $ void $ runEitherT $ replaceCatalog pdbapi rawWireCatalog case (_optShowContent, _optShowjson) of - (_, True) -> BSL.putStrLn (encode (prepareForPuppetApply wireCatalog)) + (_, True) -> BSL.putStrLn (encode (prepareForPuppetApply wirecatalog)) (True, _) -> 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" @@ -382,11 +381,11 @@ (queryfunc, _, mPStats,mCStats,mTStats) <- initializedaemonWithPuppet workingdir cmd computeStats workingdir cmd queryfunc (mPStats, mCStats, mTStats) =<< retrieveNodes nodes where - retrieveNodes :: MultNodes -> IO [Nodename] + retrieveNodes :: MultNodes -> IO [NodeName] retrieveNodes AllNodes = do allstmts <- parseFile (workingdir <> "/manifests/site.pp") >>= \case Left err -> error (show err) Right x -> return x - let getNodeName (Node (Nd (NodeName n) _ _ _)) = Just n + let getNodeName (NodeDeclaration (NodeDecl (NodeName n) _ _ _)) = Just n getNodeName _ = Nothing return $ mapMaybe getNodeName (V.toList allstmts) retrieveNodes (MultNodes xs) = return xs diff --git a/progs/pdbQuery.hs b/progs/pdbQuery.hs --- a/progs/pdbQuery.hs +++ b/progs/pdbQuery.hs @@ -105,7 +105,7 @@ allfacts <- runCheck "get facts" (getFacts pdbapi QEmpty) tmpdb <- loadTestDB "/tmp/allfacts.yaml" >>= checkError "load test db" let groupfacts = foldl' groupfact HM.empty allfacts - groupfact curmap (PFactInfo ndname fctname fctval) = + groupfact curmap (FactInfo ndname fctname fctval) = curmap & at ndname . non HM.empty %~ (at fctname ?~ fctval) runCheck "replace facts in dummy db" (replaceFacts tmpdb (HM.toList groupfacts)) runCheck "commit db" (commitDB tmpdb) @@ -119,10 +119,10 @@ ndb <- loadTestDB destfile >>= checkError "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 + let factsGrouped = HM.toList $ HM.fromListWith (<>) $ map (\x -> (x ^. factInfoNodename, HM.singleton (x ^. factInfoName) (x ^. factInfoVal))) allfacts runCheck "replace facts" (replaceFacts ndb factsGrouped) forM_ allnodes $ \pnodename -> do - let ndename = pnodename ^. nodename + let ndename = pnodename ^. nodeInfoName res <- runCheck ("get resources for " ++ show ndename) (getResourcesOfNode pdbapi ndename QEmpty) let wirecatalog = WireCatalog ndename "version" V.empty (V.fromList res) ndename runCheck "replace catalog" (replaceCatalog ndb wirecatalog) diff --git a/tests/Function/EachSpec.hs b/tests/Function/EachSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Function/EachSpec.hs @@ -0,0 +1,52 @@ + {-# LANGUAGE OverloadedLists #-} +module Function.EachSpec (spec, main) where + +import Test.Hspec +import Helpers + +import Puppet.Interpreter.Types + +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + describe "should be callable as" $ do + it "each on an array selecting each value" $ do + c <- getCatalog "$a = [1,2,3]\n $a.each |$v| {\n file { \"/file_$v\": ensure => present } \n } " + getResource (RIdentifier "file" "/file_1") c >>= getAttribute "ensure" >>= \a -> a `shouldBe` "present" + getResource (RIdentifier "file" "/file_2") c >>= getAttribute "ensure" >>= \a -> a `shouldBe` "present" + getResource (RIdentifier "file" "/file_3") c >>= getAttribute "ensure" >>= \a -> a `shouldBe` "present" + it "each on an array selecting each value - function call style" $ do + c <- getCatalog "$a = [1,2,3]\n each ($a) |$index, $v| {\n file { \"/file_$v\": ensure => present }\n }" + getResource (RIdentifier "file" "/file_1") c >>= getAttribute "ensure" >>= \a -> a `shouldBe` "present" + getResource (RIdentifier "file" "/file_2") c >>= getAttribute "ensure" >>= \a -> a `shouldBe` "present" + getResource (RIdentifier "file" "/file_3") c >>= getAttribute "ensure" >>= \a -> a `shouldBe` "present" + it "each on an array with index" $ do + c <- getCatalog "$a = [present, absent, present]\n $a.each |$k,$v| {\n file { \"/file_$k\": ensure => $v }\n }" + getResource (RIdentifier "file" "/file_0") c >>= getAttribute "ensure" >>= \a -> a `shouldBe` "present" + getResource (RIdentifier "file" "/file_1") c >>= getAttribute "ensure" >>= \a -> a `shouldBe` "absent" + getResource (RIdentifier "file" "/file_2") c >>= getAttribute "ensure" >>= \a -> a `shouldBe` "present" + it "each on a hash selecting entries" $ do + c <- getCatalog "$a = {'a'=>'present','b'=>'absent','c'=>'present'}\n $a.each |$e| {\n $num = $e[0]\n file { \"/file_${num}\": ensure => $e[1] }\n }" + getResource (RIdentifier "file" "/file_a") c >>= getAttribute "ensure" >>= \a -> a `shouldBe` "present" + getResource (RIdentifier "file" "/file_b") c >>= getAttribute "ensure" >>= \a -> a `shouldBe` "absent" + getResource (RIdentifier "file" "/file_c") c >>= getAttribute "ensure" >>= \a -> a `shouldBe` "present" + it "each on a hash selecting key and value" $ do + c <- getCatalog "$a = {'a'=>present,'b'=>absent,'c'=>present}\n $a.each |$k, $v| {\n file { \"/file_$k\": ensure => $v }\n }" + getResource (RIdentifier "file" "/file_a") c >>= getAttribute "ensure" >>= \a -> a `shouldBe` "present" + getResource (RIdentifier "file" "/file_b") c >>= getAttribute "ensure" >>= \a -> a `shouldBe` "absent" + getResource (RIdentifier "file" "/file_c") c >>= getAttribute "ensure" >>= \a -> a `shouldBe` "present" + it "each on a hash selecting key and value (using captures-last parameter)" $ do + pending + c <- getCatalog "$a = {'a'=>present,'b'=>absent,'c'=>present}\n $a.each |*$kv| {\n file { \"/file_${kv[0]}\": ensure => $kv[1] }\n }" + getResource (RIdentifier "file" "/file_a") c >>= getAttribute "ensure" >>= \a -> a `shouldBe` "present" + getResource (RIdentifier "file" "/file_b") c >>= getAttribute "ensure" >>= \a -> a `shouldBe` "absent" + getResource (RIdentifier "file" "/file_c") c >>= getAttribute "ensure" >>= \a -> a `shouldBe` "present" + describe "should produce receiver" $ + it "each checking produced value using single expression" $ do + pending + c <- getCatalog "$a = [1, 3, 2]\n $b = $a.each |$x| { \"unwanted\" }\n $u = $b[1]\n file { \"/file_${u}\":\n ensure => present\n }" + getResource (RIdentifier "file" "/file_3") c >>= getAttribute "ensure" >>= \a -> a `shouldBe` "present" + + diff --git a/tests/Function/MergeSpec.hs b/tests/Function/MergeSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Function/MergeSpec.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE OverloadedLists #-} +module Function.MergeSpec (spec, main) where + +import Test.Hspec + +import Control.Monad +import qualified Data.HashMap.Strict as HM +import Data.Monoid +import Data.Text (Text) + +import Puppet.Interpreter.Pure +import Puppet.Interpreter.Types +import Puppet.PP +import Puppet.Stdlib + +main :: IO () +main = hspec spec + +evalArgs :: InterpreterMonad PValue -> Either PrettyError (HM.HashMap Text PValue) +evalArgs = dummyEval + >=> \pv -> case pv of + PHash s -> return s + _ -> Left ("Expected a string, not " <> PrettyError (pretty pv)) + +spec :: Spec +spec = do + mergeFunc <- case HM.lookup "merge" stdlibFunctions of + Just f -> return f + Nothing -> fail "Don't know the size function" + let evalArgs' = evalArgs . mergeFunc + let check args res = case evalArgs' (map PHash args) of + Left rr -> expectationFailure (show rr) + Right res' -> res' `shouldBe` res + checkError args ins = case evalArgs' args of + Left rr -> show rr `shouldContain` ins + Right r -> expectationFailure ("Should have errored, received this instead: " <> show r) + it "should error with invalid arguments" $ do + checkError [] "Expects at least two hashes" + checkError [PNumber 1] "Expects at least two hashes" + checkError [PBoolean True] "Expects at least two hashes" + checkError ["foo"] "Expects at least two hashes" + it "should handle empty hashes" $ do + check [[],[]] [] + check [[],[],[]] [] + it "should merge hashes" $ do + check [ [("key", "value")], [] ] [("key","value")] + check [ [], [("key", "value")] ] [("key","value")] + check [ [("key1", "value1")], [("key2", "value2")], [("key3", "value3")] ] [("key1", "value1"), ("key2", "value2"), ("key3", "value3")] + check [ [("key", "value1")], [("key", "value2")] ] [("key","value2")] diff --git a/tests/Function/ShellquoteSpec.hs b/tests/Function/ShellquoteSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Function/ShellquoteSpec.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE OverloadedLists #-} +module Function.ShellquoteSpec (spec, main) where + +import Test.Hspec + +import Data.Text (Text) +import qualified Data.Vector as V +import Control.Monad +import Data.Monoid + +import Puppet.Interpreter.Resolve +import Puppet.Interpreter.Pure +import Puppet.Interpreter.Types +import Puppet.Parser.Types +import Puppet.PP + +main :: IO () +main = hspec spec + +evalArgs :: [Expression] -> Either PrettyError Text +evalArgs = dummyEval . resolveValue . UFunctionCall "shellquote" . V.fromList + >=> \pv -> case pv of + PString s -> return s + _ -> Left ("Expected a string, not " <> PrettyError (pretty pv)) + +spec :: Spec +spec = do + let check args res = case evalArgs args of + Left rr -> expectationFailure (show rr) + Right res' -> res' `shouldBe` res + it "should handle no arguments" (check [] "") + it "should handle array arguments" $ + check ["foo", ["bar@example.com", "localhost:/dev/null"], "xyzzy+-4711,23"] + "foo bar@example.com localhost:/dev/null xyzzy+-4711,23" + it "should quote unsafe characters" $ + check ["/etc/passwd ", "(ls)", "*", "[?]", "'&'"] + "\"/etc/passwd \" \"(ls)\" \"*\" \"[?]\" \"'&'\"" + it "should deal with double quotes" $ + check ["\"foo\"bar\""] + "'\"foo\"bar\"'" + it "should cope with dollar signs" $ + check ["$PATH", "foo$bar", "\"x$\""] + "'$PATH' 'foo$bar' '\"x$\"'" + it "should deal with apostrophes (single quotes)" $ + check ["'foo'bar'", "`$'EDITOR'`"] + "\"'foo'bar'\" \"\\`\\$'EDITOR'\\`\"" + it "should cope with grave accents (backquotes)" $ + check ["`echo *`", "`ls \"$MAILPATH\"`"] + "'`echo *`' '`ls \"$MAILPATH\"`'" + it "should deal with both single and double quotes" $ + check ["'foo\"bar\"xyzzy'", "\"foo'bar'xyzzy\""] + "\"'foo\\\"bar\\\"xyzzy'\" \"\\\"foo'bar'xyzzy\\\"\"" + it "should handle multiple quotes *and* dollars and backquotes" $ + check ["'foo\"$x`bar`\"xyzzy'"] + "\"'foo\\\"\\$x\\`bar\\`\\\"xyzzy'\"" + it "should handle linefeeds" $ + check ["foo \n bar"] + "\"foo \n bar\"" diff --git a/tests/Function/SizeSpec.hs b/tests/Function/SizeSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Function/SizeSpec.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE OverloadedLists #-} +module Function.SizeSpec (spec, main) where + +import Test.Hspec + +import Control.Monad +import qualified Data.HashMap.Strict as HM +import Data.Monoid +import Data.Scientific + +import Puppet.Interpreter.Pure +import Puppet.Interpreter.Types +import Puppet.PP +import Puppet.Stdlib + +main :: IO () +main = hspec spec + +evalArgs :: InterpreterMonad PValue -> Either PrettyError Scientific +evalArgs = dummyEval + >=> \pv -> case pv of + PNumber s -> return s + _ -> Left ("Expected a string, not " <> PrettyError (pretty pv)) + +spec :: Spec +spec = do + sizeFunc <- case HM.lookup "size" stdlibFunctions of + Just f -> return f + Nothing -> fail "Don't know the size function" + let evalArgs' = evalArgs . sizeFunc + let check args res = case evalArgs' args of + Left rr -> expectationFailure (show rr) + Right res' -> res' `shouldBe` res + checkError args ins = case evalArgs' args of + Left rr -> show rr `shouldContain` ins + Right r -> expectationFailure ("Should have errored, received this instead: " <> show r) + it "should error with no arguments" (checkError [] "a single argument") + it "should error with numerical arguments" (checkError [PNumber 1] "size(): Expects ") + it "should error with boolean arguments" (checkError [PBoolean True] "size(): Expects ") + -- Not conformant: + -- it "should error with numerical arguments" (checkError ["1"] "size(): Expects ") + it "should handle arrays" $ do + check [PArray []] 0 + check [PArray ["a"]] 1 + check [PArray ["one","two","three"]] 3 + check [PArray ["one","two","three","four"]] 4 + it "should handle hashes" $ do + check [PHash []] 0 + check [PHash [("1","2")]] 1 + check [PHash [("1","2"),("3","4")]] 2 + it "should handle strings" $ do + check [""] 0 + check ["a"] 1 + check ["ab"] 2 + check ["abcd"] 4 + diff --git a/tests/Helpers.hs b/tests/Helpers.hs new file mode 100644 --- /dev/null +++ b/tests/Helpers.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE OverloadedLists #-} +module Helpers ( compileCatalog + , getCatalog + , getResource + , getAttribute + , spretty + ) where + +import Puppet.Interpreter (computeCatalog) +import Puppet.Interpreter.Pure +import Puppet.Interpreter.Types +import Puppet.Parser +import Puppet.Parser.Types +import Puppet.PP + +import Control.Lens +import qualified Data.HashMap.Strict as HM +import qualified Data.Maybe.Strict as S +import Data.Text (Text, unpack) + +compileCatalog :: Monad m => Text -> m (FinalCatalog, EdgeMap, FinalCatalog, [Resource], InterpreterState) +compileCatalog input = do + statements <- either (fail . show) return (runPParser "dummy" input) + let nodename = "node.fqdn" + sttmap = [( (TopNode, nodename), NodeDeclaration (NodeDecl (NodeName nodename) statements S.Nothing (initialPPos "dummy")) ) ] + (res, finalState, _) = pureEval dummyFacts sttmap (computeCatalog nodename) + (catalog,em,exported,defResources) <- either (fail . show) return res + return (catalog,em,exported,defResources,finalState) + +getCatalog :: Monad m => Text -> m FinalCatalog +getCatalog = fmap (view _1) . compileCatalog + +spretty :: Pretty a => a -> String +spretty = flip displayS "" . renderCompact . pretty + +getResource :: Monad m => RIdentifier -> FinalCatalog -> m Resource +getResource resid catalog = maybe (fail ("Unknown resource " ++ spretty resid)) return (HM.lookup resid catalog) + +getAttribute :: Monad m => Text -> Resource -> m PValue +getAttribute att res = case res ^? rattributes . ix att of + Nothing -> fail ("Unknown attribute: " ++ unpack att) + Just x -> return x + diff --git a/tests/InterpreterSpec.hs b/tests/InterpreterSpec.hs new file mode 100644 --- /dev/null +++ b/tests/InterpreterSpec.hs @@ -0,0 +1,79 @@ +module InterpreterSpec (collectorSpec, main) where + +import Control.Lens +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HM +import Data.Monoid +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Vector as V +import Test.Hspec +import Text.Megaparsec (eof, parse) + +import Puppet.Interpreter +import Puppet.Interpreter.Pure +import Puppet.Interpreter.Types +-- import Puppet.Lens +import Puppet.Parser +import Puppet.Parser.Types +import Puppet.PP + +appendArrowNode :: Text +appendArrowNode = "appendArrow" + +arrowOperationInput :: ArrowOp -> Text +arrowOperationInput arr = T.unlines [ "node " <> appendArrowNode <> " {" + , "user { 'jenkins':" + , " groups => 'ci'" + , "}" + , "User <| title == 'jenkins' |> {" + , "groups " <> (prettyToText . pretty) arr <> " 'docker'," + , "uid => 1000}" + , "}" + ] + +getResAttr :: + (Either + PrettyError + (FinalCatalog, EdgeMap, FinalCatalog, [Resource]), + InterpreterState, + InterpreterWriter) + -> Container PValue +getResAttr s = + let finalcatalog = s ^._1._Right._1 + in finalcatalog ^. at (RIdentifier "user" "jenkins")._Just.rattributes + + +collectorSpec :: Spec +collectorSpec = do + let computeWith arr = pureCompute appendArrowNode (arrowOperationInput arr) + describe "Resource Collector" $ + it "should append the new 'uid' attribute in the user resource" $ + getResAttr (computeWith AssignArrow) ^. at "uid" `shouldBe` Just (PNumber 1000) + describe "AppendArrow in AttributeDecl" $ + it "should add 'docker' to the 'groups' attribute of the user resource" $ + getResAttr (computeWith AppendArrow) ^. at "groups" `shouldBe` Just (PArray $ V.fromList ["ci", "docker"]) + describe "AssignArrow in AttributeDecl" $ + it "should override the 'groups' attributes from the user resource" $ + getResAttr (computeWith AssignArrow) ^. at "groups" `shouldBe` Just (PArray $ V.fromList ["docker"]) + +main :: IO () +main = hspec collectorSpec + +-- | Given a node and raw text input to be parsed, compute the manifest in a dummy setting. +pureCompute :: NodeName + -> Text + -> (Either PrettyError (FinalCatalog, EdgeMap, FinalCatalog, [Resource]), + InterpreterState, + InterpreterWriter) +pureCompute node input = + let hush :: Show a => Either a b -> b + hush = either (error . show) id + + getStatement :: NodeName -> Text -> HashMap (TopLevelType, NodeName) Statement + getStatement n i = HM.singleton (TopNode, n) (nodeStatement i) + + nodeStatement :: Text -> Statement + nodeStatement i = V.head $ hush $ parse (puppetParser <* eof) "test" i + + in pureEval dummyFacts (getStatement node input) (computeCatalog node) diff --git a/tests/Spec.hs b/tests/Spec.hs new file mode 100644 --- /dev/null +++ b/tests/Spec.hs @@ -0,0 +1,19 @@ +import Test.Hspec + +import qualified InterpreterSpec +import qualified Function.ShellquoteSpec +import qualified Function.SizeSpec +import qualified Function.MergeSpec +import qualified Function.EachSpec + +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + describe "Interpreter" InterpreterSpec.collectorSpec + describe "The shellquote function" Function.ShellquoteSpec.spec + describe "stdlib functions" $ do + describe "The size function" Function.SizeSpec.spec + describe "The merge function" Function.MergeSpec.spec + describe "The each function" Function.EachSpec.spec diff --git a/tests/hiera.hs b/tests/hiera.hs --- a/tests/hiera.hs +++ b/tests/hiera.hs @@ -34,6 +34,10 @@ hspec $ do describe "lookup data without a key" $ do it "returns an error when called with an empty string" $ q mempty "" Priority >>= checkOutput Nothing + describe "lookup data without a valid key" $ do + it "returns an error when called with a non existent key [Priority]" $ q mempty "foo" Priority >>= checkOutput Nothing + it "returns an error when called with a non existent key [ArrayMerge]" $ q mempty "foo" ArrayMerge >>= checkOutput Nothing + it "returns an error when called with a non existent key [HashMerge]" $ q mempty "foo" HashMerge >>= checkOutput Nothing describe "lookup data with no options" $ do it "can get string data" $ q mempty "http_port" Priority >>= checkOutput (Just (PNumber 8080)) it "can get arrays" $ q mempty "ntp_servers" Priority >>= checkOutput (Just (PArray (V.fromList ["0.ntp.puppetlabs.com","1.ntp.puppetlabs.com"])))