language-puppet 0.10.2 → 0.10.3
raw patch · 33 files changed
+1047/−251 lines, 33 filesdep +HUnitdep +lens-aesondep +stateWriterdep ~basedep ~hspecdep ~lens
Dependencies added: HUnit, lens-aeson, stateWriter, temporary
Dependency ranges changed: base, hspec, lens, strict-base-types, text, unordered-containers, vector, yaml
Files
- Erb/Compute.hs +12/−10
- Erb/Parser.hs +10/−3
- Erb/Ruby.hs +1/−0
- Facter.hs +1/−0
- Hiera/Server.hs +185/−0
- Puppet/Daemon.hs +18/−11
- Puppet/Interpreter.hs +154/−84
- Puppet/Interpreter/PrettyPrinter.hs +7/−11
- Puppet/Interpreter/Resolve.hs +134/−23
- Puppet/Interpreter/Types.hs +81/−31
- Puppet/Manifests.hs +9/−9
- Puppet/NativeTypes/Cron.hs +2/−2
- Puppet/NativeTypes/File.hs +7/−1
- Puppet/NativeTypes/Group.hs +1/−1
- Puppet/NativeTypes/Helpers.hs +12/−3
- Puppet/NativeTypes/User.hs +1/−1
- Puppet/Parser/Types.hs +74/−18
- Puppet/Preferences.hs +2/−1
- Puppet/Stats.hs +23/−8
- Puppet/Stdlib.hs +31/−0
- Puppet/Testing.hs +15/−5
- PuppetDB/Common.hs +9/−1
- PuppetDB/Dummy.hs +2/−0
- PuppetDB/Remote.hs +2/−1
- PuppetDB/TestDB.hs +16/−8
- language-puppet.cabal +24/−3
- progs/PuppetResources.hs +87/−13
- progs/pdbQuery.hs +14/−3
- ruby/calcerb.rb +4/−0
- ruby/hrubyerb.rb +4/−0
- tests/hiera.hs +59/−0
- tests/lexer.hs +1/−0
- tests/puppetdb.hs +45/−0
Erb/Compute.hs view
@@ -57,7 +57,7 @@ type TemplateAnswer = S.Either Doc T.Text initTemplateDaemon :: Preferences -> MStats -> IO (Either T.Text T.Text -> T.Text -> Container ScopeInformation -> IO (S.Either Doc T.Text))-initTemplateDaemon (Preferences _ modpath templatepath _ _ _ _ _) mvstats = do+initTemplateDaemon (Preferences _ modpath templatepath _ _ _ _ _ _) mvstats = do controlchan <- newChan templatecache <- newFileCache #ifdef HRUBY@@ -105,7 +105,7 @@ Right x -> (x, T.unpack x) parsed <- case fileinfo of Right _ -> measure mstats ("parsing - " <> filename) $ lazyQuery filecache ufilename $ parseErbFile ufilename- Left content -> measure mstats ("parsing - " <> filename) (return (runParser erbparser () "inline" (T.unpack content)))+ Left content -> measure mstats ("parsing - " <> filename) $ return (runParser erbparser () "inline" (T.unpack content)) case parsed of Left err -> do let !msg = "template " ++ ufilename ++ " could not be parsed " ++ show err@@ -149,20 +149,22 @@ Right r -> toRuby r computeTemplateWRuby :: Either T.Text T.Text -> T.Text -> Container ScopeInformation -> IO TemplateAnswer-computeTemplateWRuby fileinfo curcontext variables = freezeGC $ do+computeTemplateWRuby fileinfo curcontext variables = freezeGC $ eitherDocIO $ do rscp <- embedHaskellValue curcontext rvariables <- embedHaskellValue variables let varlist = variables ^. ix curcontext . scopeVariables+ let withBinding f = do+ erbBinding <- safeMethodCall "ErbBinding" "new" [rscp,rvariables]+ case erbBinding of+ Left x -> return (Left x)+ Right v -> do+ forM_ (itoList varlist) $ \(varname, (varval :!: _ :!: _)) -> toRuby varval >>= rb_iv_set v (T.unpack varname)+ f v o <- case fileinfo of Right fname -> do rfname <- toRuby fname- erbBinding <- safeMethodCall "ErbBinding" "new" [rscp,rvariables]- case erbBinding of- Left x -> return (Left x)- Right v -> do- forM_ (itoList varlist) $ \(varname, (varval :!: _ :!: _)) -> toRuby varval >>= rb_iv_set v (T.unpack varname)- safeMethodCall "Controller" "runFromFile" [rfname,v]- Left content -> toRuby content >>= safeMethodCall "Controller" "runFromContent" . (:[])+ withBinding $ \v -> safeMethodCall "Controller" "runFromFile" [rfname,v]+ Left content -> withBinding $ \v -> toRuby content >>= safeMethodCall "Controller" "runFromContent" . (:[v]) freeHaskellValue rvariables freeHaskellValue rscp case o of
Erb/Parser.hs view
@@ -9,9 +9,12 @@ import Text.Parsec.Language (emptyDef) import Erb.Ruby import Text.Parsec.Expr+import Text.Parsec.Pos import qualified Text.Parsec.Token as P import qualified Data.Text as T+import qualified Data.Text.IO as T import Control.Monad.Identity+import Control.Exception (catch,SomeException) def :: P.GenLanguageDef String u Identity def = emptyDef@@ -152,6 +155,10 @@ erbparser = textblock parseErbFile :: FilePath -> IO (Either ParseError [RubyStatement])-parseErbFile fname = do- input <- readFile fname- return (runParser erbparser () fname input)+parseErbFile fname = parseContent `catch` handler+ where+ parseContent = (runParser erbparser () fname . T.unpack) `fmap` T.readFile fname+ handler e = let msg = show (e :: SomeException)+ in return $ Left $ newErrorMessage (Message msg) (initialPos fname)++
Erb/Ruby.hs view
@@ -49,3 +49,4 @@ data RubyStatement = Puts !Expression deriving(Show)+
Facter.hs view
@@ -119,6 +119,7 @@ , ("puppetversion", "language-puppet") , ("virtual", "xenu") , ("clientcert", nodename)+ , ("is_virtual", "true") ] allfacts = nfacts `HM.union` ofacts genFacts = HM.fromList
+ Hiera/Server.hs view
@@ -0,0 +1,185 @@+{-# LANGUAGE LambdaCase, TemplateHaskell, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-}+{- | This module runs a Hiera server that caches Hiera data. There is+a huge caveat : only the data files are watched for changes, not the main configuration file.++A minor bug is that interpolation will not work for inputs containing the % character when it isn't used for interpolation.+-}+module Hiera.Server (startHiera,dummyHiera,HieraQueryFunc) where++import qualified Data.FileCache as F+import qualified Data.Yaml as Y+import qualified Data.Aeson as A+import Data.Aeson (FromJSON,Value(..),(.:?),(.!=))+import qualified Data.Either.Strict as S+import qualified Data.Maybe.Strict as S+import qualified Data.Text as T+import qualified Data.Attoparsec.Text as AT+import qualified Data.ByteString.Lazy as BS+import qualified Data.Vector as V+import qualified Data.HashMap.Strict as HM+import Data.Tuple.Strict+import Control.Monad.Writer.Strict++import Control.Applicative+import Control.Lens+import Control.Lens.Aeson+import System.FilePath.Lens (directory)+import Control.Exception++import Puppet.PP hiding ((<$>))+import Puppet.Interpreter.Types+import Puppet.Interpreter.Resolve+import Puppet.Utils (strictifyEither)++data HieraConfig = HieraConfig { _hieraconfigBackends :: [HieraBackend]+ , _hieraconfigHierarchy :: [InterpolableHieraString]+ , _hieraconfigBasedir :: FilePath+ } deriving Show++data HieraBackend = YamlBackend FilePath+ | JsonBackend FilePath+ deriving Show++newtype InterpolableHieraString = InterpolableHieraString [HieraStringPart]+ deriving Show++data HieraStringPart = HString T.Text+ | HVariable T.Text+ deriving Show++instance Pretty HieraStringPart where+ pretty (HString t) = ttext t+ pretty (HVariable v) = dullred (string "%{" <> ttext v <> string "}")+ prettyList = mconcat . map pretty++type HieraCache = F.FileCacheR Doc Y.Value++makeFields ''HieraConfig++instance FromJSON InterpolableHieraString where+ parseJSON (String s) = case parseInterpolableString s of+ Right x -> return (InterpolableHieraString x)+ Left rr -> fail rr+ parseJSON _ = fail "Invalid value type"++instance FromJSON HieraConfig where+ parseJSON (Object v) = do+ let genBackend :: T.Text -> Y.Parser HieraBackend+ genBackend backendname = do+ (backendConstructor, skey) <- case backendname of+ "yaml" -> return (YamlBackend, ":yaml")+ "json" -> return (JsonBackend, ":json")+ _ -> fail ("Unknown backend " ++ T.unpack backendname)+ datadir <- case (Object v) ^? key skey . key ":datadir" of+ Just (String dtdir) -> return dtdir+ Just _ -> fail ":datadir should be a string"+ Nothing -> return "/etc/puppet/hieradata"+ return (backendConstructor (T.unpack datadir))+ HieraConfig+ <$> (v .:? ":backends" .!= ["yaml"] >>= mapM genBackend)+ <*> (v .:? ":hierarchy" .!= [InterpolableHieraString [HString "common"]])+ <*> pure "/etc/puppet/hieradata"+ parseJSON _ = fail "Not a valid Hiera configuration"++-- | An attoparsec parser that turns text into parts that are ready for+-- interpolation+interpolableString :: AT.Parser [HieraStringPart]+interpolableString = AT.many1 (fmap HString rawPart <|> fmap HVariable interpPart)+ where+ rawPart = AT.takeWhile1 (/= '%')+ interpPart = AT.string "%{" *> AT.takeWhile1 (/= '}') <* AT.char '}'++parseInterpolableString :: T.Text -> Either String [HieraStringPart]+parseInterpolableString t = AT.parseOnly interpolableString t++-- | The only method you'll ever need. It runs a Hiera server and gives you+-- a querying function. The 'Nil' output is explicitely given as a Maybe+-- type.+startHiera :: FilePath -> IO (Either String (HieraQueryFunc))+startHiera hieraconfig = Y.decodeFileEither hieraconfig >>= \case+ Left ex -> return (Left (show ex))+ Right cfg -> do+ let ncfg = cfg & basedir .~ (hieraconfig ^. directory) <> "/"+ cache <- F.newFileCache+ return (Right (query ncfg cache))++-- | A dummy hiera function that will be used when hiera is not detected+dummyHiera :: HieraQueryFunc+dummyHiera _ _ _ = return (S.Right ([] :!: S.Nothing))++-- | The combinator for "normal" queries+queryCombinator :: [LogWriter (S.Maybe PValue)] -> LogWriter (S.Maybe PValue)+queryCombinator [] = return S.Nothing+queryCombinator (x:xs) = x >>= \case+ v@(S.Just _) -> return v+ S.Nothing -> queryCombinator xs++-- | The combinator for hiera_array+queryCombinatorArray :: [LogWriter (S.Maybe PValue)] -> LogWriter (S.Maybe PValue)+queryCombinatorArray = fmap rejoin . sequence+ where+ rejoin = S.Just . PArray . V.concat . map toA+ toA S.Nothing = V.empty+ toA (S.Just (PArray r)) = r+ toA (S.Just a) = V.singleton a++-- | The combinator for hiera_array+queryCombinatorHash :: [LogWriter (S.Maybe PValue)] -> LogWriter (S.Maybe PValue)+queryCombinatorHash = fmap (S.Just . PHash . mconcat . map toH) . sequence+ where+ toH S.Nothing = mempty+ toH (S.Just (PHash h)) = h+ toH _ = throw (ErrorCall "The hiera value was not a hash")++interpolateText :: Container ScopeInformation -> T.Text -> T.Text+interpolateText vars t = case (parseInterpolableString t ^? _Right) >>= resolveInterpolable vars of+ Just x -> x+ Nothing -> t++resolveInterpolable :: Container ScopeInformation -> [HieraStringPart] -> Maybe T.Text+resolveInterpolable vars = fmap T.concat . mapM (resolveInterpolablePart vars)++resolveInterpolablePart :: Container ScopeInformation -> HieraStringPart -> Maybe T.Text+resolveInterpolablePart _ (HString x) = Just x+resolveInterpolablePart vars (HVariable v) = getVariable vars "::" v ^? _Right . _PString++interpolatePValue :: Container ScopeInformation -> PValue -> PValue+interpolatePValue v (PHash h) = PHash . HM.fromList . map ( (_1 %~ interpolateText v) . (_2 %~ interpolatePValue v) ) . HM.toList $ h+interpolatePValue v (PArray r) = PArray (fmap (interpolatePValue v) r)+interpolatePValue v (PString t) = PString (interpolateText v t)+interpolatePValue _ x = x++type LogWriter = WriterT InterpreterWriter IO++query :: HieraConfig -> HieraCache -> HieraQueryFunc+query (HieraConfig b h bd) cache vars hquery qtype = fmap (S.Right . prepout) (runWriterT (sequencerFunction (map query' h))) `catch` (\e -> return . S.Left . string . show $ (e :: SomeException))+ where+ prepout (a,s) = s :!: a+ sequencerFunction = case qtype of+ Priority -> queryCombinator+ ArrayMerge -> queryCombinatorArray+ HashMerge -> queryCombinatorHash+ query' :: InterpolableHieraString -> LogWriter (S.Maybe PValue)+ query' (InterpolableHieraString strs) =+ case resolveInterpolable vars strs of+ Just s -> sequencerFunction (map (query'' s) b)+ Nothing -> warn ("Hiera: could not interpolate " <> pretty strs) >> return S.Nothing+ query'' :: T.Text -> HieraBackend -> LogWriter (S.Maybe PValue)+ query'' hieraname backend = do+ let (decodefunction, datadir, extension) = case backend of+ (JsonBackend d) -> (fmap (strictifyEither . (_Left %~ string). A.eitherDecode') . BS.readFile , d, ".json")+ (YamlBackend d) -> (fmap (strictifyEither . (_Left %~ string . show)) . Y.decodeFileEither, d, ".yaml")+ filename = mbd <> datadir <> "/" <> T.unpack hieraname <> extension+ where+ mbd = case datadir of+ '/' : _ -> mempty+ _ -> bd+ mfromJSON :: Maybe Value -> LogWriter (S.Maybe PValue)+ mfromJSON Nothing = return S.Nothing+ mfromJSON (Just v) = case A.fromJSON v of+ A.Success a -> return (S.Just (interpolatePValue vars a))+ _ -> warn ("Hiera: could not convert this Value to a Puppet type: " <> string (show v)) >> return S.Nothing+ v <- liftIO (F.query cache filename (decodefunction filename))+ case v of+ S.Left r -> debug ("Hiera: error when reading file " <> string filename <+> r) >> return S.Nothing+ S.Right x -> mfromJSON (x ^? key hquery)
Puppet/Daemon.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE LambdaCase #-}-module Puppet.Daemon (initDaemon, DaemonQuery(..), logDebug, logInfo, logWarning, logError) where+module Puppet.Daemon (initDaemon, logDebug, logInfo, logWarning, logError) where import Puppet.Parser import Puppet.Utils@@ -10,6 +10,7 @@ import Puppet.Manifests import Puppet.Interpreter import Puppet.Plugins+import Hiera.Server import Erb.Compute import Puppet.PP@@ -65,7 +66,7 @@ Known bugs : -* It might be buggy when top level statements that are not class/define/nodes+* It might be buggy when top level statements that are not class\/define\/nodes are altered, or when files loaded with require are changed. * Exported resources are supported through the PuppetDB interface.@@ -90,18 +91,23 @@ catalogStats <- newStats getStatements <- initParserDaemon prefs parserStats getTemplate <- initTemplateDaemon prefs templateStats+ hquery <- case prefs ^. hieraPath of+ Just p -> startHiera p >>= \case+ Left _ -> return dummyHiera+ Right x -> return x+ Nothing -> return dummyHiera let runMaster = do (luastate, luafunctions) <- initLua (T.pack (prefs ^. modulesPath)) let luacontainer = HM.fromList [ (fname, puppetFunc luastate fname) | fname <- luafunctions ] myprefs = prefs & prefExtFuncs %~ HM.union luacontainer- master myprefs controlChan getStatements getTemplate catalogStats+ master myprefs controlChan getStatements getTemplate catalogStats hquery replicateM_ (prefs ^. compilePoolSize) (forkIO runMaster) return (DaemonMethods (gCatalog controlChan) parserStats catalogStats templateStats) gCatalog :: Chan DaemonQuery -> T.Text -> Facts -> IO (S.Either Doc (FinalCatalog, EdgeMap, FinalCatalog))-gCatalog q nodename fcts = do+gCatalog q ndename fcts = do t <- newEmptyMVar- writeChan q (DaemonQuery nodename fcts t)+ writeChan q (DaemonQuery ndename fcts t) readMVar t data DaemonQuery = DaemonQuery@@ -117,14 +123,15 @@ -> ( TopLevelType -> T.Text -> IO (S.Either Doc Statement) ) -> (Either T.Text T.Text -> T.Text -> Container ScopeInformation -> IO (S.Either Doc T.Text)) -> MStats+ -> HieraQueryFunc -> IO ()-master prefs controlQ getStatements getTemplate stats = forever $ do- (DaemonQuery nodename facts q) <- readChan controlQ- logDebug ("Received query for node " <> nodename)- traceEventIO ("Received query for node " <> T.unpack nodename)- (stmts :!: warnings) <- measure stats nodename $ getCatalog getStatements getTemplate (prefs ^. prefPDB) nodename facts (prefs ^. natTypes) (prefs ^. prefExtFuncs)+master prefs controlQ getStatements getTemplate stats hquery = forever $ do+ (DaemonQuery ndename facts q) <- readChan controlQ+ logDebug ("Received query for node " <> ndename)+ traceEventIO ("Received query for node " <> T.unpack ndename)+ (stmts :!: warnings) <- measure stats ndename $ getCatalog getStatements getTemplate (prefs ^. prefPDB) ndename facts (prefs ^. natTypes) (prefs ^. prefExtFuncs) hquery mapM_ (\(p :!: m) -> LOG.logM loggerName p (displayS (renderCompact m) "")) warnings- traceEventIO ("getCatalog finished for " <> T.unpack nodename)+ traceEventIO ("getCatalog finished for " <> T.unpack ndename) putMVar q stmts initParserDaemon :: Preferences -> MStats -> IO ( TopLevelType -> T.Text -> IO (S.Either Doc Statement) )
Puppet/Interpreter.hs view
@@ -20,14 +20,14 @@ import qualified Data.Either.Strict as S import qualified Data.HashSet as HS import qualified Data.HashMap.Strict as HM-import Control.Monad.Trans.RWS.Strict-import Control.Monad.Error hiding (mapM)+import Control.Monad.Trans.RSS.Strict+import Control.Monad.Error hiding (mapM,forM) import Control.Lens import qualified Data.Maybe.Strict as S import qualified Data.Graph as G import qualified Data.Tree as T import Data.Foldable (toList,foldl',Foldable,foldlM)-import Data.Traversable (mapM)+import Data.Traversable (mapM,forM) -- helpers vmapM :: (Monad m, Foldable t) => (a -> m b) -> t a -> m [b]@@ -40,21 +40,23 @@ -> Facts -- ^ Facts ... -> Container PuppetTypeMethods -- ^ List of native types -> Container ( [PValue] -> InterpreterMonad PValue )+ -> HieraQueryFunc -- ^ Hiera query function -> IO (Pair (S.Either Doc (FinalCatalog, EdgeMap, FinalCatalog)) [Pair Priority Doc])-getCatalog gtStatement gtTemplate pdbQuery ndename facts nTypes extfuncs = do- let rdr = InterpreterReader nTypes gtStatement gtTemplate pdbQuery extfuncs ndename+getCatalog gtStatement gtTemplate pdbQuery ndename facts nTypes extfuncs hquery = do+ let rdr = InterpreterReader nTypes gtStatement gtTemplate pdbQuery extfuncs ndename hquery dummypos = initialPPos "dummy" initialclass = mempty & at "::" ?~ (IncludeStandard :!: dummypos)- stt = InterpreterState baseVars initialclass mempty ["::"] dummypos mempty [] []+ stt = InterpreterState baseVars initialclass mempty [ContRoot] dummypos mempty [] [] factvars = facts & each %~ (\x -> PString x :!: initialPPos "facts" :!: ContRoot) callervars = ifromList [("caller_module_name", PString "::" :!: dummypos :!: ContRoot), ("module_name", PString "::" :!: dummypos :!: ContRoot)] baseVars = isingleton "::" (ScopeInformation (factvars <> callervars) mempty mempty (CurContainer ContRoot mempty) mempty S.Nothing)- (output, _, warnings) <- runRWST (runErrorT (computeCatalog ndename)) rdr stt- return (strictifyEither output :!: _warnings warnings)+ (output, _, warnings) <- runRSST (runErrorT (computeCatalog ndename)) rdr stt+ return (strictifyEither output :!: warnings) isParent :: T.Text -> CurContainerDesc -> InterpreterMonad Bool-isParent _ ContRoot = return False-isParent _ ContImported = return False+isParent _ (ContImport _ _) = return False -- no relationship through import+isParent _ ContRoot = return False+isParent _ (ContImported _) = return False isParent _ (ContDefine _ _) = return False isParent cur (ContClass possibleparent) = do preuse (scopes . ix cur . scopeParent) >>= \case@@ -67,7 +69,7 @@ finalize :: [Resource] -> InterpreterMonad [Resource] finalize rlist = do -- step 1, apply defaults- scp <- getScope+ scp <- getScopeName defs <- use (scopes . ix scp . scopeDefaults) let getOver = use (scopes . ix scp . scopeOverrides) -- retrieves current overrides addDefaults r = do@@ -81,12 +83,17 @@ addOverrides' r x Nothing -> return r addOverrides' r (ResRefOverride _ prms p) = do- let inter = (r ^. rattributes) `HM.intersection` prms- unless (fnull inter) $ do- s <- getScope- i <- isParent s (r ^. rcontainer)- unless i $ throwPosError ("You are not allowed to override the following parameters " <+> containerComma inter <+> "already defined at" <+> showPPos p)- return (r & rattributes %~ (<>) prms)+ let forb = throwPosError ("Override of parameters of the following resource is forbidden in the current context:" </> pretty r <+> showPPos p)+ s <- getScope+ overrideType <- case r ^. rscope of+ [] -> forb -- we could not get the current resource context+ (x:_) -> if x == s+ then return CantOverride -- we are in the same context : can't replace, but add stuff+ else isParent (scopeName s) x >>= \i ->+ if i+ then return Replace -- we can override what's defined in a parent+ else forb+ foldM (\cr a -> addAttribute overrideType cr a) r (HM.toList prms) withDefaults <- mapM (addOverrides >=> addDefaults) rlist -- There might be some overrides that could not be applied. The only -- valid reason is that they override something in exported resources.@@ -113,12 +120,12 @@ popScope :: InterpreterMonad () popScope = curScope %= tail -pushScope :: T.Text -> InterpreterMonad ()+pushScope :: CurContainerDesc -> InterpreterMonad () pushScope s = curScope %= (s :) evalTopLevel :: Statement -> InterpreterMonad ([Resource], Statement) evalTopLevel (TopContainer tops s) = do- pushScope "::"+ pushScope ContRoot r <- vmapM evaluateStatement tops >>= finalize . concat -- popScope (nr, ns) <- evalTopLevel s@@ -170,7 +177,7 @@ makeEdgeMap :: FinalCatalog -> InterpreterMonad EdgeMap makeEdgeMap ct = do -- merge the looaded classes and resources- defs' <- use definedResources+ defs' <- HM.map _rpos `fmap` use definedResources clss' <- use loadedClasses let defs = defs' <> classes' <> aliases' <> names' names' = HM.map _rpos ct@@ -188,11 +195,13 @@ let containerMap :: HM.HashMap RIdentifier [RIdentifier] !containerMap = ifromListWith (<>) $ do r <- toList ct- let toResource ContRoot = RIdentifier "class" "::"- toResource (ContClass cn) = RIdentifier "class" cn- toResource (ContDefine t n) = RIdentifier t n- toResource ContImported = RIdentifier "class" "::"- return (toResource (r ^. rcontainer), [r ^. rid])+ let toResource ContRoot = return $ RIdentifier "class" "::"+ toResource (ContClass cn) = return $ RIdentifier "class" cn+ toResource (ContDefine t n) = return $ RIdentifier t n+ toResource (ContImported _) = mzero+ toResource (ContImport _ _) = mzero+ o <- toResource (rcurcontainer r)+ return (o, [r ^. rid]) -- This function uses the previous map in order to resolve to non -- container resources. resolveDestinations :: RIdentifier -> [RIdentifier]@@ -273,7 +282,7 @@ evaluateNode :: Statement -> InterpreterMonad [Resource] evaluateNode (Node _ stmts inheritance p) = do curPos .= p- pushScope "::"+ pushScope ContRoot unless (S.isNothing inheritance) $ throwPosError "Node inheritance is not handled yet, and will probably never be" vmapM evaluateStatement stmts >>= finalize . concat evaluateNode x = throwPosError ("Asked for a node evaluation, but got this instead:" <$> pretty x)@@ -296,7 +305,7 @@ if "::" `T.isInfixOf` cname then nestedDeclarations . at (TopClass, cname) ?= r >> return [] else do- scp <- getScope+ scp <- getScopeName if scp == "::" then nestedDeclarations . at (TopClass, cname) ?= r >> return [] else nestedDeclarations . at (TopClass, scp <> "::" <> cname) ?= r >> return []@@ -304,7 +313,7 @@ if "::" `T.isInfixOf` dname then nestedDeclarations . at (TopDefine, dname) ?= r >> return [] else do- scp <- getScope+ scp <- getScopeName if scp == "::" then nestedDeclarations . at (TopDefine, dname) ?= r >> return [] else nestedDeclarations . at (TopDefine, scp <> "::" <> dname) ?= r >> return []@@ -321,7 +330,19 @@ then do let q = searchExpressionToPuppetDB resType rsearch pdb <- view pdbAPI- interpreterIO (getResources pdb q)+ fqdn <- view thisNodename+ -- we must filter the resources that originated from this host+ -- here ! They are also turned into "normal" resources+ res <- ( map (rvirtuality .~ Normal)+ . filter ((/= fqdn) . _rnode)+ ) `fmap` interpreterIO (getResources pdb q)+ scpdesc <- ContImported `fmap` getScope+ void $ enterScope S.Nothing scpdesc+ pushScope scpdesc+ o <- finalize res+ popScope+ return o+ else return [] evaluateStatement (Dependency (t1 :!: n1) (t2 :!: n2) p) = do curPos .= p@@ -356,7 +377,7 @@ curPos .= p let resolveDefaultValue (prm :!: v) = fmap (prm :!:) (resolveExpression v) rdecls <- vmapM resolveDefaultValue decls >>= fromArgumentList- scp <- getScope+ scp <- getScopeName -- invariant that must be respected : the current scope must me create -- in "scopes", or nothing gets saved let newDefaults = ResDefaults resType scp rdecls p@@ -373,9 +394,10 @@ curPos .= p raassignements <- vmapM resolveArgument eargs >>= fromArgumentList rn <- resolveExpressionString urn- scp <- getScope+ scp <- getScopeName curoverrides <- use (scopes . ix scp . scopeOverrides) let rident = RIdentifier rt 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@@ -394,7 +416,7 @@ loadVariable :: T.Text -> PValue -> InterpreterMonad () loadVariable varname varval = do curcont <- getCurContainer- scp <- getScope+ scp <- getScopeName p <- use curPos scopeDefined <- use (scopes . contains scp) variableDefined <- preuse (scopes . ix scp . scopeVariables . ix varname)@@ -403,11 +425,11 @@ (_, Just (_ :!: pp :!: ctx)) -> do isParent scp (curcont ^. cctype) >>= \case True -> do- warn ("The variable"- <+> pretty (UVariableReference varname)- <+> "had been overriden because of some arbitrary inheritance rule that was set up to emulate puppet behaviour. It was defined at"- <+> showPPos pp- )+ debug ("The variable"+ <+> pretty (UVariableReference varname)+ <+> "had been overriden because of some arbitrary inheritance rule that was set up to emulate puppet behaviour. It was defined at"+ <+> showPPos pp+ ) scopes . ix scp . scopeVariables . at varname ?= (varval :!: p :!: curcont ^. cctype) False -> throwPosError ("Variable" <+> pretty (UVariableReference varname) <+> "already defined at" <+> showPPos pp </> "Context:" <+> pretty ctx@@ -416,22 +438,44 @@ ) _ -> scopes . ix scp . scopeVariables . at varname ?= (varval :!: p :!: curcont ^. cctype) -loadParameters :: Foldable f => Container PValue -> f (Pair T.Text (S.Maybe Expression)) -> PPosition -> InterpreterMonad ()-loadParameters params classParams defaultPos = do+-- | This function loads class and define parameters into scope. It checks+-- that all mandatory parameters are set, that no extra parameter is+-- declared.+--+-- 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 params classParams defaultPos wHiera = do+ params' <- case wHiera of+ S.Just classname -> do+ -- pass 1 : with classes, we retrieve the parameters that have no default values and+ -- that are not set, to try to get them with Hiera+ let !classParamSet = HS.fromList (fmap S.fst (classParams ^.. folded))+ !definedParamSet = ikeys params+ !unsetParams = classParamSet `HS.difference` definedParamSet+ loadHieraParam curprms paramname = do+ v <- runHiera (classname <> "::" <> paramname) Priority+ case v of+ S.Nothing -> return curprms+ S.Just vl -> return (curprms & at paramname ?~ vl)+ foldM loadHieraParam params (toList unsetParams)+ S.Nothing -> return params+ -- pass 2 : we check that everything is right let !classParamSet = HS.fromList (map S.fst (toList classParams)) !mandatoryParamSet = HS.fromList (map S.fst (classParams ^.. folded . filtered (S.isNothing . S.snd)))- !definedParamSet = ikeys params+ !definedParamSet = ikeys params' !unsetParams = mandatoryParamSet `HS.difference` definedParamSet !spuriousParams = definedParamSet `HS.difference` classParamSet- unless (fnull unsetParams) $ throwPosError ("The following mandatory parameters where not set:" <+> tupled (map ttext $ toList unsetParams))- unless (fnull spuriousParams) $ throwPosError ("The following parameters are unknown:" <+> tupled (map (dullyellow . ttext) $ toList spuriousParams))+ mclassdesc = S.maybe mempty ((\x -> mempty <+> "when including class" <+> x) . ttext) wHiera+ unless (fnull unsetParams) $ throwPosError ("The following mandatory parameters where not set:" <+> tupled (map ttext $ toList unsetParams) <> mclassdesc)+ unless (fnull spuriousParams) $ throwPosError ("The following parameters are unknown:" <+> tupled (map (dullyellow . ttext) $ toList spuriousParams) <> mclassdesc) let isDefault = not . flip HS.member definedParamSet . S.fst- mapM_ (uncurry loadVariable) (itoList params)+ mapM_ (uncurry loadVariable) (itoList params') curPos .= defaultPos forM_ (filter isDefault (toList classParams)) $ \(k :!: v) -> do rv <- case v of S.Nothing -> throwPosError "Internal error: invalid invariant at loadParameters"- S.Just e -> resolveExpression e+ S.Just e -> resolveExpression e loadVariable k rv -- | Enters a new scope, checks it is not already defined, and inherits the@@ -442,25 +486,26 @@ -- expanding the defines without the defaults applied enterScope :: S.Maybe T.Text -> CurContainerDesc -> InterpreterMonad T.Text enterScope parent cont = do- let scopename = case cont of- ContRoot -> "::"- ContImported -> "::"- ContClass x -> x- ContDefine dt dn -> "#define/" <> dt <> "/" <> dn+ let scopename = scopeName cont scopeAlreadyDefined <- use (scopes . contains scopename)- when scopeAlreadyDefined (throwPosError ("Internal error: scope already defined when loading scope for" <+> pretty cont))- scp <- getScope- -- TODO fill tags- basescope <- case parent of- S.Nothing -> do- curdefs <- use (scopes . ix scp . scopeDefaults)- return $ ScopeInformation mempty curdefs mempty (CurContainer cont mempty) mempty parent- S.Just p -> do- parentscope <- use (scopes . at p)- when (isNothing parentscope) (throwPosError ("Internal error: could not find parent scope" <+> ttext p))- let Just psc = parentscope- return (psc & scopeParent .~ parent)- scopes . at scopename ?= basescope+ let isImported = case cont of+ ContImported _ -> True+ _ -> False+ -- it is OK to reuse a scope related to imported stuff+ unless (scopeAlreadyDefined && isImported) $ do+ when scopeAlreadyDefined (throwPosError ("Internal error: scope" <+> brackets (ttext scopename) <+> "already defined when loading scope for" <+> pretty cont))+ scp <- getScopeName+ -- TODO fill tags+ basescope <- case parent of+ S.Nothing -> do+ curdefs <- use (scopes . ix scp . scopeDefaults)+ return $ ScopeInformation mempty curdefs mempty (CurContainer cont mempty) mempty parent+ S.Just p -> do+ parentscope <- use (scopes . at p)+ when (isNothing parentscope) (throwPosError ("Internal error: could not find parent scope" <+> ttext p))+ let Just psc = parentscope+ return (psc & scopeParent .~ parent)+ scopes . at scopename ?= basescope return scopename dropInitialColons :: T.Text -> T.Text@@ -477,25 +522,32 @@ let curContType = ContDefine deftype defname scopename <- enterScope S.Nothing curContType (spurious, dls) <- getstt TopDefine deftype+ let isImported (ContImported _) = True+ isImported _ = False+ isImportedDefine <- isImported `fmap` getScope case dls of (DefineDeclaration _ defineParams stmts cp) -> do p <- use curPos curPos .= r ^. rpos- pushScope scopename+ curscp <- getScope+ when isImportedDefine (pushScope (ContImport (r ^. rnode) curscp ))+ pushScope curContType loadVariable "title" (PString defname) loadVariable "name" (PString defname) -- not done through loadvariable because of override -- errors scopes . ix scopename . scopeVariables . at "module_name" ?= (PString modulename :!: p :!: curContType) scopes . ix scopename . scopeVariables . at "callermodule_name" ?= (curcaller :!: p :!: curContType)- loadParameters (r ^. rattributes) defineParams cp+ loadParameters (r ^. rattributes) defineParams cp S.Nothing curPos .= cp res <- evaluateStatementsVector stmts out <- finalize (spurious ++ res)+ when isImportedDefine popScope popScope return out _ -> throwPosError ("Internal error: we did not retrieve a DefineDeclaration, but had" <+> pretty dls) + loadClass :: T.Text -> Container PValue -> ClassIncludeType@@ -507,7 +559,7 @@ -- http://docs.puppetlabs.com/puppet/3/reference/lang_classes.html#using-resource-like-declarations use (loadedClasses . at classname) >>= \case Just (_ :!: pp) -> do- when (cincludetype == IncludeResource) (throwPosError ("Can't include class" <+> ttext classname <+> "twice when using the resource-like syntax (first occurance at" <+> showPPos pp <> ")"))+ when (cincludetype == IncludeResource) (throwPosError ("Can't include class" <+> ttext classname <+> "twice when using the resource-like syntax (first occurence at" <+> showPPos pp <> ")")) return [] -- already loaded, go on Nothing -> do@@ -522,20 +574,23 @@ inhstmts <- case inh of S.Nothing -> return [] S.Just ihname -> loadClass ihname mempty IncludeResource- scopename <- enterScope inh (ContClass classname)+ let !scopedesc = ContClass classname+ scopename <- enterScope inh scopedesc classresource <- if cincludetype == IncludeStandard then do scp <- use curScope- return [Resource (RIdentifier "class" classname) (HS.singleton classname) mempty mempty scp ContRoot Normal mempty p Nothing]+ fqdn <- view thisNodename+ return [Resource (RIdentifier "class" classname) (HS.singleton classname) mempty mempty scp Normal mempty p fqdn] else return []- pushScope scopename+ pushScope scopedesc let modulename = case T.splitOn "::" classname of [] -> classname (x:_) -> x -- not done through loadvariable because of override -- errors scopes . ix scopename . scopeVariables . at "module_name" ?= (PString modulename :!: p :!: ContClass classname)- loadParameters params classParams cp+ scopes . ix "::" . scopeVariables . at "calling_module" ?= (PString modulename :!: p :!: ContClass classname) -- hiera compatibility :(+ loadParameters params classParams cp (S.Just classname) curPos .= cp res <- evaluateStatementsVector stmts out <- finalize (classresource ++ spurious ++ inhstmts ++ res)@@ -577,11 +632,11 @@ _ -> do -- we must check if the resource scope is -- a parent of the current scope- curscope <- getScope- i <- isParent curscope (r ^. rcontainer)+ curscope <- getScopeName+ i <- isParent curscope (rcurcontainer r) if i then return (r & rattributes . at t ?~ v)- else throwPosError ("Attribute" <+> ttext t <+> "defined multiple times for" <+> pretty (r ^. rid) <+> showPPos (r ^. rpos))+ else throwPosError ("Attribute" <+> dullmagenta (ttext t) <+> "defined multiple times for" <+> pretty (r ^. rid) <+> showPPos (r ^. rpos)) registerResource :: T.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)"@@ -594,24 +649,29 @@ -- http://docs.puppetlabs.com/puppet/3/reference/lang_tags.html#containment let !defaulttags = {-# SCC "rrGetTags" #-} HS.fromList (rt : classtags) <> tgs allsegs x = x : T.splitOn "::" x- !classtags = case cnt of- ContRoot -> []- ContImported -> []- ContClass cn -> allsegs cn- ContDefine dt _ -> allsegs dt+ !classtags = getClassTags cnt+ getClassTags (ContClass cn ) = allsegs cn+ getClassTags (ContDefine dt _) = allsegs dt+ getClassTags (ContRoot ) = []+ getClassTags (ContImported _ ) = []+ getClassTags (ContImport _ _ ) = [] allScope <- use curScope- let baseresource = Resource (RIdentifier rt rn) (HS.singleton rn) mempty mempty allScope cnt vrt defaulttags p Nothing+ fqdn <- view thisNodename+ let baseresource = Resource (RIdentifier rt rn) (HS.singleton rn) mempty mempty allScope vrt defaulttags p fqdn r <- foldM (addAttribute CantOverride) baseresource (itoList arg) let resid = RIdentifier rt rn case rt of "class" -> {-# SCC "rrClass" #-} do- definedResources . at resid ?= p+ definedResources . at resid ?= r fmap (r:) $ loadClass rn (r ^. rattributes) IncludeResource _ -> {-# SCC "rrGeneralCase" #-} use (definedResources . at resid) >>= \case- Just apos -> throwPosError ("Resource" <+> pretty resid <+> "already defined at" <+> showPPos apos)+ Just otheres -> throwPosError ("Resource" <+> pretty resid <+> "already defined:" <$>+ pretty r <$>+ pretty otheres+ ) Nothing -> do- definedResources . at resid ?= p+ definedResources . at resid ?= r return [r] -- A helper function for the various loggers@@ -626,7 +686,7 @@ -- functions : this can't really be exported as it uses a lot of stuff from -- this module ... mainFunctionCall :: T.Text -> [PValue] -> InterpreterMonad [Resource]-mainFunctionCall "showscope" _ = use curScope >>= warn . list . map ttext >> return []+mainFunctionCall "showscope" _ = use curScope >>= warn . pretty >> return [] -- The logging functions mainFunctionCall "alert" a = logWithModifier ALERT red a mainFunctionCall "crit" a = logWithModifier CRITICAL red a@@ -653,12 +713,23 @@ realiz x = throwPosError ("realize(): all arguments must be resource references, not" <+> pretty x) mapM_ realiz args >> return [] mainFunctionCall "tag" args = do- scp <- getScope+ scp <- getScopeName let addTag x = scopes . ix scp . scopeExtraTags . contains x .= True mapM_ (resolvePValueString >=> addTag) args return [] mainFunctionCall "fail" [x] = fmap (("fail:" <+>) . dullred . ttext) (resolvePValueString x) >>= throwPosError mainFunctionCall "fail" _ = throwPosError "fail(): This function takes a single argument"+mainFunctionCall "hiera_include" [x] = do+ ndname <- resolvePValueString x+ classes <- runHiera ndname ArrayMerge >>= \case+ S.Just (PArray r) -> return (toList r)+ _ -> return []+ p <- use curPos+ curPos %= (_1 . lSourceName %~ (<> " [hiera_include call]"))+ o <- mainFunctionCall "include" classes+ curPos .= p+ return o+mainFunctionCall "hiera_include" _ = throwPosError "hiera_include(): This function takes a single argument" mainFunctionCall fname args = do p <- use curPos let representation = MainFunctionCall fname mempty p@@ -668,7 +739,6 @@ Nothing -> throwPosError ("Unknown function:" <+> pretty representation) unless (rs == PUndef) $ throwPosError ("This function call should return" <+> pretty PUndef <+> "and not" <+> pretty rs <$> pretty representation) return []- -- Method stuff evaluateHFC :: HFunctionCall -> InterpreterMonad [Resource]
Puppet/Interpreter/PrettyPrinter.hs view
@@ -50,15 +50,10 @@ pretty (RIdentifier t n) = pretty (PResourceReference t n) meta :: Resource -> Doc-meta r = showPPos (r ^. rpos) <+> (green (node <> brackets cont <+> brackets scp) )+meta r = showPPos (r ^. rpos) <+> (green (node <+> brackets scp) ) where- node = maybe mempty ((<+> mempty) . red . ttext) (r ^. rnode)- cont = case r ^. rcontainer of- ContRoot -> magenta "top level"- ContClass cname -> magenta "class" <+> ttext cname- ContDefine t n -> pretty (PResourceReference t n)- ContImported -> magenta "imported"- scp = "Scope" <+> pretty (r ^.. rscope . folded . filtered (/="::") . to (white . ttext))+ node = red (ttext (r ^. rnode))+ scp = "Scope" <+> pretty (r ^.. rscope . folded . filtered (/=ContRoot) . to pretty) resourceBody :: Resource -> Doc resourceBody r = virtuality <> blue (ttext (r ^. rid . iname)) <> ":" <+> meta r <$> containerComma'' insde <> ";"@@ -73,8 +68,8 @@ attriblist1 = sortWith fst $ HM.toList (r ^. rattributes) ++ aliasdiff aliasWithoutTitle = r ^. ralias & contains (r ^. rid . iname) .~ False aliasPValue = aliasWithoutTitle & PArray . V.fromList . map PString . HS.toList- aliasdiff | HS.null aliasWithoutTitle = [("alias", aliasPValue)]- | otherwise = []+ aliasdiff | HS.null aliasWithoutTitle = []+ | otherwise = [("alias", aliasPValue)] attriblist2 = map totext (resourceRelations r) totext (RIdentifier t n, lt) = (rel2text lt , PResourceReference t n) maxalign = max (maxalign' attriblist1) (maxalign' attriblist2)@@ -91,7 +86,8 @@ pretty r = dullyellow (ttext (r ^. rid . itype)) <+> lbrace <$> indent 2 (resourceBody r) <$> rbrace instance Pretty CurContainerDesc where- pretty ContImported = magenta "imported"+ pretty (ContImport p x) = magenta "import" <> braces (ttext p) <> braces (pretty x)+ pretty (ContImported x) = magenta "imported" <> braces (pretty x) pretty ContRoot = dullyellow (text "::") pretty (ContClass cname) = dullyellow (text "class") <+> dullgreen (text (T.unpack cname)) pretty (ContDefine dtype dname) = pretty (PResourceReference dtype dname)
Puppet/Interpreter/Resolve.hs view
@@ -1,5 +1,33 @@ {-# LANGUAGE LambdaCase #-}-module Puppet.Interpreter.Resolve where+-- | This module is all about converting and resolving foreign data into+-- the fully exploitable corresponding data type. The main use case is the+-- conversion of 'Expression' to 'PValue'.+module Puppet.Interpreter.Resolve+ ( -- * Pure resolution functions and prisms+ _PString,+ _PInteger,+ pvnum,+ getVariable,+ pValue2Bool,+ -- * Monadic resolution functions+ resolveVariable,+ resolveExpression,+ resolveValue,+ resolvePValueString,+ resolveExpressionString,+ resolveExpressionStrings,+ resolveArgument,+ runHiera,+ isNativeType,+ -- * Search expression management+ resolveSearchExpression,+ checkSearchExpression,+ searchExpressionToPuppetDB,+ -- * Higher order puppet functions handling+ hfGenerateAssociations,+ hfSetvars,+ hfRestorevars,+ ) where import Puppet.PP import Puppet.Interpreter.Types@@ -10,6 +38,7 @@ import Data.Version (parseVersion) import Text.ParserCombinators.ReadP (readP_to_S) +import Data.Maybe (fromMaybe) import Data.Aeson hiding ((.=)) import Data.CaseInsensitive ( mk ) import qualified Data.Vector as V@@ -37,10 +66,35 @@ import qualified Data.ByteString.Base16 as B16 import Text.Regex.PCRE.ByteString.Utils import Data.Bits+import Control.Monad.Writer (tell) +-- | A useful type that is used when trying to perform arithmetic on Puppet+-- numbers. type NumberPair = S.Either (Pair Integer Integer) (Pair Double Double) --- | Tries to convert a pair of PValues into numbers, as defined in+-- | A hiera helper function, that will throw all Hiera errors and log+-- messages to the main monad.+runHiera :: T.Text -> HieraQueryType -> InterpreterMonad (S.Maybe PValue)+runHiera q t = do+ hquery <- view hieraQuery+ scps <- use scopes+ (w :!: o) <- interpreterIO (hquery scps q t)+ tell w+ return o++-- | The implementation of all hiera_* functions+hieraCall :: HieraQueryType -> PValue -> (Maybe PValue) -> (Maybe PValue) -> InterpreterMonad PValue+hieraCall _ _ _ (Just _) = throwPosError "Overriding the hierarchy is not yet supported"+hieraCall qt q df _ = do+ qs <- resolvePValueString q+ o <- runHiera qs qt+ case o of+ S.Just p -> return p+ S.Nothing -> case df of+ Just d -> return d+ Nothing -> throwPosError ("Lookup for " <> ttext qs <> " failed")++-- | Tries to convert a pair of 'PValue's into 'Number's, as defined in -- attoparsec. If the two values can be converted, it will convert them so -- that they are of the same type toNumbers :: PValue -> PValue -> S.Maybe NumberPair@@ -53,7 +107,14 @@ _ -> S.Nothing toNumbers _ _ = S.Nothing -binaryOperation :: Expression -> Expression -> (Integer -> Integer -> Integer) -> (Double -> Double -> Double) -> InterpreterMonad PValue+-- | This tries to run a numerical binary operation on two puppet+-- expressions. It will try to resolve them, then convert them to numbers+-- (using 'toNumbners'), and will finally apply the correct operation.+binaryOperation :: Expression -- ^ left operand+ -> Expression -- ^ right operand+ -> (Integer -> Integer -> Integer) -- ^ operation in case those are integers+ -> (Double -> Double -> Double) -- ^ operation in case those are doubles+ -> InterpreterMonad PValue binaryOperation a b opi opd = do ra <- resolveExpression a rb <- resolveExpression b@@ -62,6 +123,8 @@ S.Just (S.Right (na :!: nb)) -> return (pvnum # D (opd na nb)) S.Just (S.Left (na :!: nb)) -> return (pvnum # I (opi na nb)) +-- | Just like 'binaryOperation', but for operations that only work on+-- integers. integerOperation :: Expression -> Expression -> (Integer -> Integer -> Integer) -> InterpreterMonad PValue integerOperation a b opr = do ra <- resolveExpression a@@ -71,7 +134,7 @@ S.Just (S.Right _) -> throwPosError ("Expected integer values, not" <+> pretty ra <+> "or" <+> pretty rb) S.Just (S.Left (na :!: nb)) -> return (pvnum # I (opr na nb)) --- | Converting PValue to and from Number with a prism!+-- | A prism between 'PValue' and 'Number' pvnum :: Prism' PValue Number pvnum = prism num2PValue toNumber where@@ -84,28 +147,36 @@ _ -> Left p toNumber p = Left p +-- | A prism between 'PValue' and 'T.Text' _PString :: Prism' PValue T.Text _PString = prism PString $ \x -> case x of PString s -> Right s n -> Left n +-- | A prism between 'PValue' and 'Integer' _PInteger :: Prism' PValue Integer _PInteger = prism (PString . T.pack . show) $ \x -> case x ^? pvnum of Just (I z) -> Right z _ -> Left x +-- | Resolves a variable, or throws an error if it can't. resolveVariable :: T.Text -> InterpreterMonad PValue resolveVariable fullvar = do scps <- use scopes- scp <- getScope+ scp <- getScopeName case getVariable scps scp fullvar of Left rr -> throwPosError rr Right x -> return x +-- | A simple helper that checks if a given type is native or a define. isNativeType :: T.Text -> InterpreterMonad Bool isNativeType t = view (nativeTypes . contains t) -getVariable :: Container ScopeInformation -> T.Text -> T.Text -> Either Doc PValue+-- | A pure function for resolving variables.+getVariable :: Container ScopeInformation -- ^ The whole scope data.+ -> T.Text -- ^ Current scope name.+ -> T.Text -- ^ Full variable name.+ -> Either Doc PValue getVariable scps scp fullvar = do (varscope, varname) <- case T.splitOn "::" fullvar of [] -> throwError "This doesn't make any sense in resolveVariable"@@ -119,6 +190,7 @@ Just pp -> extractVariable pp Nothing -> throwError ("Could not resolve variable" <+> pretty (UVariableReference fullvar) <+> "in context" <+> ttext varscope <+> "or root") +-- | A helper for numerical comparison functions. numberCompare :: Expression -> Expression -> (Integer -> Integer -> Bool) -> (Double -> Double -> Bool) -> InterpreterMonad PValue numberCompare a b compi compd = do ra <- resolveExpression a@@ -128,6 +200,7 @@ S.Just (S.Right (na :!: nb)) -> return (PBoolean (compd na nb)) S.Just (S.Left (na :!: nb)) -> return (PBoolean (compi na nb)) +-- | Handles the wonders of puppet equality checks. puppetEquality :: PValue -> PValue -> Bool puppetEquality ra rb = case toNumbers ra rb of@@ -144,6 +217,8 @@ -- for case insensitive matching _ -> ra == rb +-- | The main resolution function : turns an 'Expression' into a 'PValue',+-- if possible. resolveExpression :: Expression -> InterpreterMonad PValue resolveExpression (PValue v) = resolveValue v resolveExpression (Not e) = fmap (PBoolean . not . pValue2Bool) (resolveExpression e)@@ -232,6 +307,8 @@ resolveExpression (FunctionApplication _ x) = throwPosError ("Expected function application here, not" <+> pretty x) resolveExpression x = throwPosError ("Don't know how to resolve this expression:" <$> pretty x) +-- | Resolves an 'UValue' (terminal for the 'Expression' data type) into+-- a 'PValue' resolveValue :: UValue -> InterpreterMonad PValue resolveValue n@(URegexp _ _) = throwPosError ("Regular expressions are not allowed in this context: " <+> pretty n) resolveValue (UBoolean x) = return (PBoolean x)@@ -247,33 +324,41 @@ resolveValue (UFunctionCall fname args) = resolveFunction fname args resolveValue (UHFunctionCall hf) = evaluateHFCPure hf -resolveValueString :: UValue -> InterpreterMonad T.Text-resolveValueString = resolveValue >=> resolvePValueString-+-- | Turns strings and booleans into 'T.Text', or throws an error. resolvePValueString :: PValue -> InterpreterMonad T.Text resolvePValueString (PString x) = return x resolvePValueString (PBoolean True) = return "true" resolvePValueString (PBoolean False) = return "false" resolvePValueString x = throwPosError ("Don't know how to convert this to a string:" <$> pretty x) +-- | > resolveValueString = resolveValue >=> resolvePValueString+resolveValueString :: UValue -> InterpreterMonad T.Text+resolveValueString = resolveValue >=> resolvePValueString++-- | > resolveExpressionString = resolveExpression >=> resolvePValueString resolveExpressionString :: Expression -> InterpreterMonad T.Text resolveExpressionString = resolveExpression >=> resolvePValueString +-- | Just like 'resolveExpressionString', but accepts arrays. resolveExpressionStrings :: Expression -> InterpreterMonad [T.Text] resolveExpressionStrings x = resolveExpression x >>= \case 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 pValue2Bool PUndef = False pValue2Bool (PString "") = False pValue2Bool (PBoolean x) = x pValue2Bool _ = True +-- | This resolve function calls at the expression level. resolveFunction :: T.Text -> V.Vector Expression -> InterpreterMonad PValue resolveFunction "fqdn_rand" args = do let nbargs = V.length args@@ -341,7 +426,7 @@ file (x:xs) = fmap S.Right (T.readFile (T.unpack x)) `catch` (\SomeException{} -> file xs) resolveFunction' "tagged" ptags = do tags <- fmap HS.fromList (mapM resolvePValueString ptags)- scp <- getScope+ scp <- getScopeName scpset <- use (scopes . ix scp . scopeExtraTags) return (PBoolean (scpset `HS.intersection` tags == tags)) resolveFunction' "template" [templatename] = calcTemplate Right templatename@@ -363,6 +448,17 @@ resolveFunction' "pdbresourcequery" [q] = pdbresourcequery q Nothing resolveFunction' "pdbresourcequery" [q,k] = fmap Just (resolvePValueString k) >>= pdbresourcequery q resolveFunction' "pdbresourcequery" _ = throwPosError "pdbresourcequery(): Expects one or two arguments"+resolveFunction' "hiera" [q] = hieraCall Priority q Nothing Nothing+resolveFunction' "hiera" [q,d] = hieraCall Priority q (Just d) Nothing+resolveFunction' "hiera" [q,d,o] = hieraCall Priority q (Just d) (Just o)+resolveFunction' "hiera_array" [q] = hieraCall ArrayMerge q Nothing Nothing+resolveFunction' "hiera_array" [q,d] = hieraCall ArrayMerge q (Just d) Nothing+resolveFunction' "hiera_array" [q,d,o] = hieraCall ArrayMerge q (Just d) (Just o)+resolveFunction' "hiera_hash" [q] = hieraCall HashMerge q Nothing Nothing+resolveFunction' "hiera_hash" [q,d] = hieraCall HashMerge q (Just d) Nothing+resolveFunction' "hiera_hash" [q,d,o] = hieraCall HashMerge q (Just d) (Just o)+resolveFunction' "hiera" _ = throwPosError "hiera(): Expects one, two or three arguments"+ -- user functions resolveFunction' fname args = do external <- view externalFunctions@@ -391,10 +487,17 @@ calcTemplate :: (T.Text -> Either T.Text T.Text) -> PValue -> InterpreterMonad PValue calcTemplate templatetype templatename = do fname <- resolvePValueString templatename+ classes <- (PArray . V.fromList . map PString . HM.keys) `fmap` use loadedClasses+ scp <- getScopeName scps <- use scopes- scp <- getScope+ -- inject the special template variables (just classes for now)+ let cd = fromMaybe ContRoot (scps ^? ix scp . scopeContainer . cctype) -- get the current containder description+ -- Inject the classes variable. Note that we are relying on the+ -- invariant that the scope is already entered, and hence present+ -- in the scps container.+ cscps = scps & ix scp . scopeVariables . at "classes" ?~ ( classes :!: initialPPos "dummy" :!: cd ) computeFunc <- view computeTemplateFunction- liftIO (computeFunc (templatetype fname) scp scps)+ liftIO (computeFunc (templatetype fname) scp cscps) >>= \case S.Left rr -> throwPosError ("template error for" <+> ttext fname <+> ":" <$> rr) S.Right r -> return (PString r)@@ -406,6 +509,8 @@ PHash _ -> throwPosError "The use of an array in a search expression is undefined" resolved -> return resolved +-- | Turns an unresolved 'SearchExpression' from the parser into a fully+-- resolved 'RSearchExpression'. resolveSearchExpression :: SearchExpression -> InterpreterMonad RSearchExpression resolveSearchExpression AlwaysTrue = return RAlwaysTrue resolveSearchExpression (EqualitySearch a e) = REqualitySearch `fmap` pure a <*> resolveExpressionSE e@@ -413,8 +518,10 @@ resolveSearchExpression (AndSearch e1 e2) = RAndSearch `fmap` resolveSearchExpression e1 <*> resolveSearchExpression e2 resolveSearchExpression (OrSearch e1 e2) = ROrSearch `fmap` resolveSearchExpression e1 <*> resolveSearchExpression e2 +-- | Turns a resource type and 'RSearchExpression' into something that can+-- be used in a PuppetDB query. searchExpressionToPuppetDB :: T.Text -> RSearchExpression -> Query ResourceField-searchExpressionToPuppetDB rtype res = QAnd ( QEqual RType rtype : mkSE res )+searchExpressionToPuppetDB rtype res = QAnd ( QEqual RType (capitalizeRT rtype) : mkSE res ) where mkSE (RAndSearch a b) = [QAnd (mkSE a ++ mkSE b)] mkSE (ROrSearch a b) = [QOr (mkSE a ++ mkSE b)]@@ -425,6 +532,9 @@ mkFld "title" = RTitle mkFld z = RParameter z +-- | Checks whether a given 'Resource' matches a 'RSearchExpression'. Note+-- that the expression doesn't check for type, so you must filter the+-- resources by type beforehand, if needs be. checkSearchExpression :: RSearchExpression -> Resource -> Bool checkSearchExpression RAlwaysTrue _ = True checkSearchExpression (RAndSearch a b) r = checkSearchExpression a r && checkSearchExpression b r@@ -442,11 +552,8 @@ Nothing -> False Just x -> puppetEquality x v -{----------------------------------------- Higher order functions part-----------------------------------------}---- | Generates associations for evaluation of blocks+-- | 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@@ -467,11 +574,15 @@ (invalid, _) -> throwPosError ("Can't iterate on this data type:" <+> pretty invalid) -- | Sets the proper variables, and returns the scope variables the way--- they were before being modified.+-- they were before being modified. This is a hack that ensures that+-- variables are local to the new scope.+--+-- It doesn't work at all like other Puppet parts, but consistency isn't+-- really expected here ... hfSetvars :: [(T.Text, PValue)] -> InterpreterMonad (Container (Pair (Pair PValue PPosition) CurContainerDesc)) hfSetvars vals = do- scp <- getScope+ scp <- getScopeName p <- use curPos container <- getCurContainer save <- use (scopes . ix scp . scopeVariables)@@ -479,14 +590,14 @@ mapM_ hfSetvar vals return save --- | Restores what needs restoring. This will erase all allocation.+-- | Restores what needs restoring. This will erase all allocations. hfRestorevars :: Container (Pair (Pair PValue PPosition) CurContainerDesc) -> InterpreterMonad () hfRestorevars save = do- scp <- getScope+ scp <- getScopeName scopes . ix scp . scopeVariables .= save --- | Evaluates a statement in "pure" mode.+-- | Evaluates a statement in "pure" mode. TODO evalPureStatement :: Statement -> InterpreterMonad () evalPureStatement = undefined
Puppet/Interpreter/Types.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveGeneric, TemplateHaskell, CPP, ScopedTypeVariables, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, LambdaCase #-}+{-# LANGUAGE DeriveGeneric, TemplateHaskell, CPP, ScopedTypeVariables, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, LambdaCase, FlexibleContexts #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Puppet.Interpreter.Types where @@ -15,7 +15,8 @@ import qualified Data.Text.Encoding as T import qualified Data.Vector as V import Data.Tuple.Strict-import Control.Monad.RWS.Strict hiding ((<>))+import Control.Monad.Trans.RSS.Strict+import Control.Monad.Writer hiding ((<>)) import Control.Monad.Error import Control.Lens import Data.String (IsString(..))@@ -31,6 +32,7 @@ import Control.Applicative hiding (empty) import Data.Time.Clock import GHC.Stack+import Data.Maybe (fromMaybe) #ifdef HRUBY import Foreign.Ruby@@ -51,6 +53,14 @@ | PHash !(Container PValue) deriving (Eq, Show) +-- | 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 = Container ScopeInformation -> T.Text -> HieraQueryType -> IO (S.Either Doc (Pair InterpreterWriter (S.Maybe PValue)))+ data RSearchExpression = REqualitySearch !T.Text !PValue | RNonEqualitySearch !T.Text !PValue@@ -93,8 +103,12 @@ , _defPos :: !PPosition } -data CurContainerDesc = ContRoot | ContClass !T.Text | ContDefine !T.Text !T.Text | ContImported- deriving Eq+data CurContainerDesc = ContRoot -- ^ Contained at node or root level+ | ContClass !T.Text -- ^ Contained in a class+ | ContDefine !T.Text !T.Text -- ^ Contained in a define+ | ContImported !CurContainerDesc -- ^ Dummy container for imported resources, so that we know we must update the nodename+ | ContImport !Nodename !CurContainerDesc -- ^ This one is used when finalizing imported resources, and contains the current node name+ deriving (Eq, Generic, Ord) data CurContainer = CurContainer { _cctype :: !CurContainerDesc , _cctags :: !(HS.HashSet T.Text)@@ -117,8 +131,8 @@ data InterpreterState = InterpreterState { _scopes :: !(Container ScopeInformation) , _loadedClasses :: !(Container (Pair ClassIncludeType PPosition))- , _definedResources :: !(HM.HashMap RIdentifier PPosition)- , _curScope :: ![Scope]+ , _definedResources :: !(HM.HashMap RIdentifier Resource)+ , _curScope :: ![CurContainerDesc] , _curPos :: !PPosition , _nestedDeclarations :: !(HM.HashMap (TopLevelType, T.Text) Statement) , _extraRelations :: ![LinkInformation]@@ -131,23 +145,24 @@ , _pdbAPI :: PuppetDBAPI , _externalFunctions :: Container ( [PValue] -> InterpreterMonad PValue ) , _thisNodename :: T.Text+ , _hieraQuery :: HieraQueryFunc } -data Warning = Warning !Doc+newtype Warning = Warning Doc -data InterpreterWriter = InterpreterWriter { _warnings :: ![Pair Priority Doc] }+type InterpreterLog = Pair Priority Doc+type InterpreterWriter = [InterpreterLog] -warn :: Doc -> InterpreterMonad ()-warn d = tell (InterpreterWriter [WARNING :!: d])+warn :: (Monad m, MonadWriter InterpreterWriter m) => Doc -> m ()+warn d = tell [WARNING :!: d] -logWriter :: Priority -> Doc -> InterpreterMonad ()-logWriter prio d = tell (InterpreterWriter [prio :!: d])+debug :: (Monad m, MonadWriter InterpreterWriter m) => Doc -> m ()+debug d = tell [DEBUG :!: d] -instance Monoid InterpreterWriter where- mempty = InterpreterWriter []- mappend (InterpreterWriter a) (InterpreterWriter b) = {-# SCC "mappendInterpreterWriter" #-} InterpreterWriter (a ++ b)+logWriter :: (Monad m, MonadWriter InterpreterWriter m) => Priority -> Doc -> m ()+logWriter prio d = tell [prio :!: d] -type InterpreterMonad = ErrorT Doc (RWST InterpreterReader InterpreterWriter InterpreterState IO)+type InterpreterMonad = ErrorT Doc (RSST InterpreterReader InterpreterWriter InterpreterState IO) instance Error Doc where noMsg = empty@@ -169,7 +184,7 @@ data OverrideType = CantOverride -- ^ Overriding forbidden, will throw an error | Replace -- ^ Can silently replace- | CantReplace+ | CantReplace -- ^ Silently ignore errors data ResourceCollectorType = RealizeVirtual | RealizeCollected@@ -200,12 +215,11 @@ , _ralias :: !(HS.HashSet T.Text) -- ^ All the resource aliases , _rattributes :: !(Container PValue) -- ^ Resource parameters. , _rrelations :: !(HM.HashMap RIdentifier (HS.HashSet LinkType)) -- ^ Resource relations.- , _rscope :: ![T.Text] -- ^ Resource scope when it was defined- , _rcontainer :: !CurContainerDesc -- ^ The class that contains this resource+ , _rscope :: ![CurContainerDesc] -- ^ Resource scope when it was defined, the real container will be the first item , _rvirtuality :: !Virtuality , _rtags :: !(HS.HashSet T.Text) , _rpos :: !PPosition -- ^ Source code position of the resource definition.- , _rnode :: !(Maybe T.Text) -- ^ The node were this resource was created, if remote+ , _rnode :: !Nodename -- ^ The node were this resource was created, if remote } deriving Eq @@ -303,6 +317,9 @@ makeFields ''PFactInfo makeFields ''PNodeInfo +rcurcontainer :: Resource -> CurContainerDesc+rcurcontainer r = fromMaybe ContRoot (r ^? rscope . _head)+ throwPosError :: Doc -> InterpreterMonad a throwPosError s = do p <- use (curPos . _1)@@ -315,12 +332,22 @@ getCurContainer :: InterpreterMonad CurContainer {-# INLINE getCurContainer #-} getCurContainer = do- scp <- getScope+ scp <- getScopeName preuse (scopes . ix scp . scopeContainer) >>= \case Just x -> return x- Nothing -> throwPosError ("Internal error: can't find the current container for" <+> string (show scp))+ Nothing -> throwPosError ("Internal error: can't find the current container for" <+> green (string (T.unpack scp))) -getScope :: InterpreterMonad Scope+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++getScopeName :: InterpreterMonad T.Text+getScopeName = fmap scopeName getScope++getScope :: InterpreterMonad CurContainerDesc {-# INLINE getScope #-} getScope = use curScope >>= \s -> if null s then throwPosError "Internal error: empty scope!"@@ -355,10 +382,16 @@ Success suc -> return (Just suc) #endif +eitherDocIO :: IO (S.Either Doc a) -> IO (S.Either Doc a)+eitherDocIO computation = (computation >>= check) `catch` (\e -> return $ S.Left $ dullred $ text $ show (e :: SomeException))+ where+ check (S.Left r) = return (S.Left r)+ check (S.Right x) = return (S.Right x)+ interpreterIO :: IO (S.Either Doc a) -> InterpreterMonad a {-# INLINE interpreterIO #-} interpreterIO f = do- liftIO (f `catch` (\e -> return $ S.Left $ dullred $ text $ show (e :: SomeException))) >>= \case+ liftIO (eitherDocIO f) >>= \case S.Right x -> return x S.Left rr -> throwPosError rr @@ -416,7 +449,11 @@ rel2text RSubscribe = "subscribe" rid2text :: RIdentifier -> T.Text-rid2text (RIdentifier t n) = t `T.append` "[" `T.append` n `T.append` "]"+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)@@ -443,21 +480,34 @@ let virtuality = if isExported then Exported else Normal+ getResourceIdentifier :: PValue -> Maybe RIdentifier+ getResourceIdentifier (PString x) =+ let (restype, brckts) = T.breakOn "[" x+ rna | T.null brckts = Nothing+ | T.null restype = Nothing+ | T.last brckts == ']' = Just (T.tail (T.init brckts))+ | otherwise = Nothing+ in case rna of+ Just resname -> Just (RIdentifier (T.toLower restype) (T.toLower resname))+ _ -> 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 (curAttribs, curRelations) k val = (curAttribs & at k ?~ val, curRelations)+ 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) (attribs,relations) <- HM.foldlWithKey' separate (mempty,mempty) <$> v .: "parameters"+ contimport <- v .:? "certname" .!= "unknown" Resource- <$> (RIdentifier <$> v .: "type" <*> v .: "title")+ <$> (RIdentifier <$> fmap T.toLower (v .: "type") <*> v .: "title") <*> v .:? "aliases" .!= mempty <*> pure attribs <*> pure relations- <*> pure ["JSON"]- <*> pure ContImported+ <*> pure [ContImport contimport ContRoot] <*> pure virtuality <*> v .: "tags"- <*> (toPPos <$> v .:? "sourcefile" .!= "dummy" <*> v .:? "sourceline" .!= 0)- <*> pure Nothing+ <*> (toPPos <$> v .:? "sourcefile" .!= "null" <*> v .:? "sourceline" .!= 0)+ <*> pure contimport parseJSON _ = mempty
Puppet/Manifests.hs view
@@ -19,14 +19,14 @@ -- TODO pre-triage stuff filterStatements :: TopLevelType -> T.Text -> V.Vector Statement -> IO (S.Either Doc Statement) -- the most complicated case, node matching-filterStatements TopNode nodename stmts =+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 (NodeName !nm) _ _ _) = curstuff & _2 . at nm ?~ n triage curstuff n@(Node (NodeMatch _ !rg) _ _ _) = curstuff & _3 %~ (|> (rg :!: n)) triage curstuff n@(Node NodeDefault _ _ _) = curstuff & _4 ?~ n triage curstuff x = curstuff & _1 %~ (|> x)- bsnodename = T.encodeUtf8 nodename+ bsnodename = T.encodeUtf8 ndename checkRegexp :: [Pair Regex Statement] -> ErrorT Doc IO (Maybe Statement) checkRegexp [] = return Nothing checkRegexp ((regexp :!: s):xs) = do@@ -36,14 +36,14 @@ Right (Just _) -> return (Just s) strictEither (Left x) = S.Left x strictEither (Right x) = S.Right x- in case directnodes ^. at nodename of -- check if there is a node specifically called after my name+ in case directnodes ^. at ndename of -- check if there is a node specifically called after my name Just r -> return (S.Right (TopContainer spurious r)) Nothing -> fmap strictEither $ runErrorT $ do regexpMatchM <- checkRegexp (V.toList regexpmatches) -- match regexps case regexpMatchM <|> defaultnode of -- check for regexp matches or use the default node Just r -> return (TopContainer spurious r)- Nothing -> throwError ("Couldn't find node" <+> ttext nodename)-filterStatements x nodename stmts =+ Nothing -> throwError ("Couldn't find node" <+> ttext ndename)+filterStatements x ndename stmts = let (!spurious, !defines, !classes) = V.foldl' triage (V.empty, HM.empty, HM.empty) stmts triage curstuff n@(ClassDeclaration cname _ _ _ _) = curstuff & _3 . at cname ?~ n triage curstuff n@(DefineDeclaration cname _ _ _) = curstuff & _2 . at cname ?~ n@@ -54,9 +54,9 @@ 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 nodename of+ TopDefine -> case defines ^. at ndename of Just n -> return (S.Right (tc n))- Nothing -> return (S.Left ("Couldn't find define " <+> ttext nodename))- TopClass -> case classes ^. at nodename of+ Nothing -> return (S.Left ("Couldn't find define " <+> ttext ndename))+ TopClass -> case classes ^. at ndename of Just n -> return (S.Right (tc n))- Nothing -> return (S.Left ("Couldn't find class " <+> ttext nodename))+ Nothing -> return (S.Left ("Couldn't find class " <+> ttext ndename))
Puppet/NativeTypes/Cron.hs view
@@ -19,8 +19,8 @@ parameterfunctions :: [(T.Text, [T.Text -> PuppetTypeValidate])] parameterfunctions =- [("command" , [string, mandatory])- ,("ensure" , [defaultvalue "present", string, values ["present","absent"]])+ [("ensure" , [defaultvalue "present", string, values ["present","absent"]])+ ,("command" , [string, mandatoryIfNotAbsent]) ,("environment" , []) ,("hour" , [vrange 0 23 [] ]) ,("minute" , [vrange 0 59 [] ])
Puppet/NativeTypes/File.hs view
@@ -37,7 +37,7 @@ ,("replace" , [string, values ["true","false"]]) ,("sourceselect", [values ["first","all"]]) ,("target" , [string])- ,("source" , [])+ ,("source" , [rarray, strings, flip runarray checkSource]) ] validateFile :: PuppetTypeValidate@@ -63,3 +63,9 @@ in if source && content then Left "Source and content can't be specified at the same time" else Right res++checkSource :: T.Text -> PValue -> PuppetTypeValidate+checkSource _ (PString x) res | "puppet://" `T.isPrefixOf` x = Right res+ | "file://" `T.isPrefixOf` x = Right res+ | otherwise = throwError "A source should start with either puppet:// or file://"+checkSource _ x _ = throwError ("Expected a string, not" <+> pretty x)
Puppet/NativeTypes/Group.hs view
@@ -18,7 +18,7 @@ [("allowdupe" , [string, defaultvalue "false", values ["true","false"]]) ,("attribute_membership" , [string, defaultvalue "minimum", values ["inclusive","minimum"]]) ,("attributes" , [strings])- ,("auth_membership" , [defaultvalue "true"])+ ,("auth_membership" , [defaultvalue "minimum", string, values ["inclusive","minimum"]]) ,("ensure" , [defaultvalue "present", string, values ["present","absent"]]) ,("gid" , [integer]) ,("ia_load_module" , [string])
Puppet/NativeTypes/Helpers.hs view
@@ -20,9 +20,11 @@ , integer , integers , mandatory+ , mandatoryIfNotAbsent , inrange , faketype , defaulttype+ , runarray ) where import Puppet.PP hiding (string,integer)@@ -64,15 +66,14 @@ keyset = HS.fromList $ HM.keys (res ^. rattributes) setdiff = HS.difference keyset (metaparameters `HS.union` validparameters) --- | This validator always accept the resources, but add the default parameters--- (such as title).+-- | This validator always accept the resources, but add the default parameters (to be defined :) addDefaults :: PuppetTypeValidate addDefaults res = Right (res & rattributes %~ newparams) where def PUndef = False def _ = True newparams p = HM.filter def $ HM.union p defaults- defaults = HM.fromList [("title", PString (res ^. rid ^. iname))]+ defaults = HM.empty -- | Helper function that runs a validor on a PArray runarray :: T.Text -> (T.Text -> PValue -> PuppetTypeValidate) -> PuppetTypeValidate@@ -141,6 +142,14 @@ Just (PString al) -> Right (res & rid . iname .~ al) Just x -> Left ("The alias must be a string, not" <+> pretty x) Nothing -> Right (r & rattributes . at prm ?~ PString (r ^. rid . iname))++-- | Checks that a given parameter is set unless the resources "ensure" is set to absent+mandatoryIfNotAbsent :: T.Text -> PuppetTypeValidate+mandatoryIfNotAbsent param res = case res ^. rattributes . at param of+ Just _ -> Right res+ Nothing -> case res ^. rattributes . at "ensure" of+ Just "absent" -> Right res+ _ -> Left $ "Parameter" <+> paramname param <+> "should be set." -- | Checks that a given parameter is set. mandatory :: T.Text -> PuppetTypeValidate
Puppet/NativeTypes/User.hs view
@@ -17,7 +17,7 @@ [("allowdupe" , [string, defaultvalue "false", values ["true","false"]]) ,("attribute_membership" , [string, defaultvalue "minimum", values ["inclusive","minimum"]]) ,("attributes" , [rarray,strings])- ,("auth_membership" , [defaultvalue "true"])+ ,("auth_membership" , [defaultvalue "minimum", string, values ["inclusive","minimum"]]) ,("auths" , [rarray,strings]) ,("comment" , [string]) ,("ensure" , [defaultvalue "present", string, values ["present","absent","role"]])
Puppet/Parser/Types.hs view
@@ -1,5 +1,37 @@ {-# LANGUAGE DeriveGeneric, TemplateHaskell #-}-module Puppet.Parser.Types where+-- | All the types used for parsing, and helpers working on these types.+module Puppet.Parser.Types+ ( -- * Position management+ Position,+ PPosition,+ initialPPos,+ toPPos,+ -- ** Lenses+ lSourceName,+ lSourceLine,+ lSourceColumn,+ -- * Helpers+ capitalize',+ capitalizeRT,+ array,+ toBool,+ -- * Types+ -- ** Expressions+ Expression(..),+ SelectorCase(..),+ UValue(..),+ HigherFuncType(..),+ HFunctionCall(..),+ HasHFunctionCall(..),+ BlockParameters(..),+ CollectorType(..),+ Virtuality(..),+ NodeDesc(..),+ -- ** Search Expressions+ SearchExpression(..),+ -- ** Statements+ Statement(..)+ ) where import qualified Data.Text as T import qualified Data.Vector as V@@ -20,20 +52,34 @@ capitalize' t | T.null t = T.empty | otherwise = T.cons (toUpper (T.head t)) (T.tail t) +-- | A pair containing the start and end of a given token. type PPosition = Pair Position Position +-- | Position in a puppet file. Currently an alias to 'SourcePos'. type Position = SourcePos +lSourceName :: Lens' Position SourceName+lSourceName = lens sourceName setSourceName++lSourceLine :: Lens' Position Line+lSourceLine = lens sourceLine setSourceLine++lSourceColumn :: Lens' Position Column+lSourceColumn = lens sourceColumn setSourceColumn++-- | Generates an initial position based on a filename. initialPPos :: T.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 fl ln = let p = newPos (T.unpack fl) ln (-1) in (p :!: p) +-- | The distinct Puppet /higher order functions/ data HigherFuncType = HFEach | HFMap | HFReduce@@ -41,11 +87,13 @@ | HFSlice deriving Eq -data BlockParameters = BPSingle !T.Text- | BPPair !T.Text !T.Text+-- | 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 --- used for the each/filter/etc. "higher level functions"+-- The description of the /higher level function/ call. data HFunctionCall = HFunctionCall { _hftype :: !HigherFuncType , _hfexpr :: !(S.Maybe Expression) , _hfparams :: !BlockParameters@@ -54,20 +102,21 @@ } deriving Eq +-- | An unresolved value, typically the parser's output. data UValue- = UBoolean !Bool- | UString !T.Text- | UInterpolable !(V.Vector UValue)- | UUndef- | UResourceReference !T.Text !Expression+ = UBoolean !Bool -- ^ Special tokens generated when parsing the @true@ or @false@ literals.+ | UString !T.Text -- ^ Raw string.+ | UInterpolable !(V.Vector UValue) -- ^ 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] | UArray !(V.Vector Expression) | UHash !(V.Vector (Pair Expression Expression))- | URegexp !T.Text !Regex+ | URegexp !T.Text !Regex -- ^ The regular expression compilation is performed during parsing. | UVariableReference !T.Text | UFunctionCall !T.Text !(V.Vector Expression) | UHFunctionCall !HFunctionCall --- manual instance because of the Regex problem+-- The Eq instance is manual, because of the 'Regex' comparison problem instance Eq UValue where (==) (UBoolean a) (UBoolean b) = a == b (==) (UString a) (UString b) = a == b@@ -81,6 +130,7 @@ (==) (UFunctionCall a1 a2) (UFunctionCall b1 b2) = (a1 == b1) && (a2 == b2) (==) _ _ = False +-- | A helper function for writing 'array's. array :: [Expression] -> UValue array = UArray . V.fromList @@ -88,6 +138,7 @@ | SelectorDefault deriving (Eq) +-- | The 'Expression's data Expression = Equal !Expression !Expression | Different !Expression !Expression@@ -110,8 +161,8 @@ | LeftShift !Expression !Expression | Lookup !Expression !Expression | Negate !Expression- | ConditionalValue !Expression !(V.Vector (Pair SelectorCase Expression))- | FunctionApplication !Expression !Expression+ | ConditionalValue !Expression !(V.Vector (Pair SelectorCase Expression)) -- ^ All conditionals are stored in this format.+ | FunctionApplication !Expression !Expression -- ^ This is for /higher order functions/. | PValue !UValue deriving (Eq) @@ -126,6 +177,7 @@ data CollectorType = Collector | ExportedCollector deriving (Eq) +-- | Tries to turn an unresolved value into a 'Bool' without any context. toBool :: UValue -> Bool toBool (UString "") = False toBool (UInterpolable v) = not (V.null v)@@ -133,7 +185,10 @@ toBool (UBoolean x) = x toBool _ = True -data Virtuality = Normal | Virtual | Exported | ExportedRealized+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) data NodeDesc = NodeName !T.Text@@ -146,20 +201,21 @@ (==) (NodeMatch a _) (NodeMatch b _) = a == b (==) _ _ = False +-- | All the possible statements data Statement = ResourceDeclaration !T.Text !Expression !(V.Vector (Pair T.Text Expression)) !Virtuality !PPosition | DefaultDeclaration !T.Text !(V.Vector (Pair T.Text Expression)) !PPosition | ResourceOverride !T.Text !Expression !(V.Vector (Pair T.Text Expression)) !PPosition- | ConditionalStatement !(V.Vector (Pair Expression (V.Vector Statement))) !PPosition+ | ConditionalStatement !(V.Vector (Pair Expression (V.Vector Statement))) !PPosition -- ^ All types of conditional statements are stored that way (@case@, @if@, etc.) | ClassDeclaration !T.Text !(V.Vector (Pair T.Text (S.Maybe Expression))) !(S.Maybe T.Text) !(V.Vector Statement) !PPosition | DefineDeclaration !T.Text !(V.Vector (Pair T.Text (S.Maybe Expression))) !(V.Vector Statement) !PPosition | Node !NodeDesc !(V.Vector Statement) !(S.Maybe NodeDesc) !PPosition | VariableAssignment !T.Text !Expression !PPosition | MainFunctionCall !T.Text !(V.Vector Expression) !PPosition- | SHFunctionCall !HFunctionCall !PPosition- | ResourceCollection !CollectorType !T.Text !SearchExpression !(V.Vector (Pair T.Text Expression)) !PPosition+ | SHFunctionCall !HFunctionCall !PPosition -- ^ /Higher order function/ call.+ | ResourceCollection !CollectorType !T.Text !SearchExpression !(V.Vector (Pair T.Text Expression)) !PPosition -- ^ For all types of collectors. | Dependency !(Pair T.Text Expression) !(Pair T.Text Expression) !PPosition- | TopContainer !(V.Vector Statement) !Statement+ | 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. deriving Eq makeClassy ''HFunctionCall
Puppet/Preferences.hs view
@@ -22,6 +22,7 @@ , _prefPDB :: PuppetDBAPI , _natTypes :: Container PuppetTypeMethods -- ^ The list of native types. , _prefExtFuncs :: Container ( [PValue] -> InterpreterMonad PValue )+ , _hieraPath :: Maybe FilePath } makeClassy ''Preferences@@ -34,4 +35,4 @@ templatedir = basedir <> "/templates" typenames <- fmap (map takeBaseName) (getFiles (T.pack modulesdir) "lib/puppet/type" ".rb") let loadedTypes = HM.fromList (map defaulttype typenames)- return $ Preferences manifestdir modulesdir templatedir 4 4 dummyPuppetDB (baseNativeTypes `HM.union` loadedTypes) (stdlibFunctions)+ return $ Preferences manifestdir modulesdir templatedir 4 4 dummyPuppetDB (baseNativeTypes `HM.union` loadedTypes) (stdlibFunctions) (Just (basedir <> "/hiera.yaml"))
Puppet/Stats.hs view
@@ -1,7 +1,9 @@ {-| A quickly done module that exports utility functions used to collect various statistics. All statistics are stored in a MVar holding a HashMap.++This is not accurate in the presence of lazy evaluation. Nothing is forced. -}-module Puppet.Stats where+module Puppet.Stats (measure, measure_, newStats, getStats, StatsTable, StatsPoint(..), MStats) where import Data.Time.Clock.POSIX (getPOSIXTime) import Control.Monad@@ -10,20 +12,32 @@ import qualified Data.Text as T import Control.Lens -data StatsPoint = StatsPoint !Int !Double !Double !Double- deriving(Show)+data StatsPoint = StatsPoint { _statspointCount :: !Int -- ^ Total number of calls to a computation+ , _statspointTotal :: !Double -- ^ Total time spent during this computation+ , _statspointMin :: !Double -- ^ Minimum execution time+ , _statspointMax :: !Double -- ^ Maximum execution time+ } deriving(Show)++-- | A table where keys are the names of the computations, and values are+-- 'StatsPoint's. type StatsTable = HM.HashMap T.Text StatsPoint -type MStats = MVar StatsTable+newtype MStats = MStats { unMStats :: MVar StatsTable } +-- | Returns the actual statistical values. getStats :: MStats -> IO StatsTable-getStats = readMVar+getStats = readMVar . unMStats +-- | Create a new statistical container. newStats :: IO MStats-newStats = newMVar HM.empty+newStats = MStats `fmap` newMVar HM.empty -measure :: MStats -> T.Text -> IO a -> IO a-measure mtable statsname action = do+-- | Wraps a computation, and measures related execution statistics.+measure :: MStats -- ^ Statistics container+ -> T.Text -- ^ Action identifier+ -> IO a -- ^ Computation+ -> IO a+measure (MStats mtable) statsname action = do (!tm, !out) <- time action !stats <- takeMVar mtable let nstats :: StatsTable@@ -40,6 +54,7 @@ putMVar mtable nstats return out +-- | Just like 'measure', discarding the result value. measure_ :: MStats -> T.Text -> IO a -> IO () measure_ mtable statsname action = void ( measure mtable statsname action )
Puppet/Stdlib.hs view
@@ -19,6 +19,7 @@ import Data.Attoparsec.Number import qualified Data.ByteString.Base16 as B16 +-- | Contains the implementation of the StdLib functions. stdlibFunctions :: Container ( [PValue] -> InterpreterMonad PValue ) stdlibFunctions = HM.fromList [ singleArgument "abs" puppetAbs , ("any2array", any2array)@@ -34,6 +35,7 @@ , ("delete_at", deleteAt) , singleArgument "delete_undef_values" deleteUndefValues , ("downcase", stringArrayFunction T.toLower)+ , singleArgument "flatten" flatten , singleArgument "getvar" getvar , ("getparam", const $ throwPosError "The getparam function is uncool and shall not be implemented in language-puppet") , singleArgument "is_array" isArray@@ -43,8 +45,10 @@ , ("lstrip", stringArrayFunction T.stripStart) , ("merge", merge) , ("rstrip", stringArrayFunction T.stripEnd)+ , singleArgument "str2bool" str2Bool , ("strip", stringArrayFunction T.strip) , ("upcase", stringArrayFunction T.toUpper)+ , ("validate_absolute_path", validateAbsolutePath) , ("validate_array", validateArray) , ("validate_bool", validateBool) , ("validate_hash", validateHash)@@ -165,6 +169,14 @@ deleteUndefValues (PHash h) = return $ PHash $ HM.filter (/= PUndef) h deleteUndefValues x = throwPosError ("delete_undef_values(): Expects an Array or a Hash, not" <+> pretty x) +flatten :: PValue -> InterpreterMonad PValue+flatten r@(PArray _) = return $ PArray (flatten' r)+ where+ flatten' :: PValue -> V.Vector PValue+ flatten' (PArray x) = V.concatMap flatten' x+ flatten' x = V.singleton x+flatten x = throwPosError ("flatten(): Expects an Array, not" <+> pretty x)+ getvar :: PValue -> InterpreterMonad PValue getvar = resolvePValueString >=> resolveVariable @@ -197,6 +209,25 @@ 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"++str2Bool :: PValue -> InterpreterMonad PValue+str2Bool PUndef = return (PBoolean False)+str2Bool a@(PBoolean _) = return a+str2Bool a = do+ s <- resolvePValueString a+ let b | s `elem` ["", "1", "t", "y", "true", "yes"] = Just True+ | s `elem` [ "0", "f", "n", "false", "no"] = Just False+ | otherwise = Nothing+ case b of+ Just x -> return (PBoolean x)+ Nothing -> throwPosError "str2bool(): Unknown type of boolean given"++validateAbsolutePath :: [PValue] -> InterpreterMonad PValue+validateAbsolutePath [] = throwPosError "validateAbsolutePath(): wrong number of arguments, must be > 0"+validateAbsolutePath a = mapM_ (resolvePValueString >=> validate) a >> return PUndef+ where+ validate x | T.head x == '/' = return ()+ | otherwise = throwPosError (ttext x <+> "is not an absolute path") validateArray :: [PValue] -> InterpreterMonad PValue validateArray [] = throwPosError "validate_array(): wrong number of arguments, must be > 0"
Puppet/Testing.hs view
@@ -1,11 +1,13 @@-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TemplateHaskell, LambdaCase #-} module Puppet.Testing ( module Control.Lens , module Data.Monoid , module Puppet.PP , module Puppet.Interpreter.Types+ , H.hspec , basicTest , testingDaemon+ , defaultDaemon , testCatalog , describeCatalog , it@@ -13,7 +15,6 @@ ) where import Prelude hiding (notElem,all)-import Control.Monad.RWS.Strict hiding ((<>)) import Control.Lens import Data.Foldable hiding (forM_) import Data.Maybe@@ -29,6 +30,8 @@ import qualified Test.Hspec.Formatters as H import qualified Test.Hspec.Runner as H import qualified Test.Hspec.Core as HC+import Facter+import PuppetDB.Common import Puppet.Preferences import Puppet.PP@@ -94,14 +97,21 @@ -- | Initializes a daemon made for running tests, using the specific test -- puppetDB-testingDaemon :: Maybe T.Text -- ^ Might contain the URL of the actual PuppetDB, used for getting facts.+testingDaemon :: PuppetDBAPI -- ^ Contains the puppetdb API functions -> FilePath -- ^ Path to the manifests -> (T.Text -> IO (Container T.Text)) -- ^ The facter function -> IO (T.Text -> IO (S.Either Doc (FinalCatalog, EdgeMap, FinalCatalog)))-testingDaemon purl pdir allFacts = do+testingDaemon pdb pdir allFacts = do LOG.updateGlobalLogger "Puppet.Daemon" (LOG.setLevel LOG.WARNING) prefs <- genPreferences pdir- q <- initDaemon (prefs { _compilePoolSize = 8, _parsePoolSize = 2 })+ q <- initDaemon (prefs { _compilePoolSize = 8, _parsePoolSize = 2, _prefPDB = pdb }) return (\nodname -> allFacts nodname >>= _dGetCatalog q nodname) +-- | A default testing daemon.+defaultDaemon :: FilePath -> IO (T.Text -> IO (S.Either Doc (FinalCatalog, EdgeMap, FinalCatalog)))+defaultDaemon pdir = do+ pdb <- getDefaultDB PDBTest >>= \case+ S.Left x -> error (show x)+ S.Right y -> return y+ testingDaemon pdb pdir (flip puppetDBFacts pdb)
PuppetDB/Common.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE LambdaCase #-}+-- | Common data types for PuppetDB. module PuppetDB.Common where import Puppet.PP@@ -14,7 +15,11 @@ import qualified Data.Either.Strict as S import Data.Vector.Lens -data PDBType = PDBRemote | PDBDummy | PDBTest+-- | The supported PuppetDB implementations.+data PDBType = PDBRemote -- ^ Your standard PuppetDB, queried through the HTTP interface.+ | PDBDummy -- ^ A stupid stub, this is the default choice.+ | PDBTest -- ^ A slow but handy PuppetDB implementation that is backed by a YAML file.+ deriving Eq instance Read PDBType where readsPrec _ r | isJust reml = [(PDBRemote, fromJust reml)]@@ -32,6 +37,7 @@ tstl = stripPrefix "PDBTest" r tsts = stripPrefix "test" r +-- | Given a 'PDBType', will try return a sane default implementation. getDefaultDB :: PDBType -> IO (S.Either Doc PuppetDBAPI) getDefaultDB PDBDummy = return (S.Right dummyPuppetDB) getDefaultDB PDBRemote = pdbConnect "http://localhost:8080"@@ -39,6 +45,8 @@ Just h -> loadTestDB (h ++ "/.testdb") Nothing -> fmap S.Right initTestDB +-- | 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" where
PuppetDB/Dummy.hs view
@@ -1,3 +1,5 @@+-- | A dummy implementation of 'PuppetDBAPI', that will return empty+-- responses. module PuppetDB.Dummy where import Puppet.Interpreter.Types
PuppetDB/Remote.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE LambdaCase #-}-module PuppetDB.Remote where+module PuppetDB.Remote (pdbConnect) where import Puppet.Utils import Puppet.PP@@ -43,6 +43,7 @@ let req = initReq { requestHeaders = [("Accept", "application/json")] } runRequest req +-- | Given an URL (ie. @http://localhost:8080}), will return an incomplete 'PuppetDBAPI'. pdbConnect :: T.Text -> IO (S.Either Doc PuppetDBAPI) pdbConnect url = return $ S.Right $ PuppetDBAPI (return (ttext url))
PuppetDB/TestDB.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE TemplateHaskell, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, LambdaCase #-}+-- | A stub implementation of PuppetDB, backed by a YAML file. module PuppetDB.TestDB (loadTestDB,initTestDB) where --- import Data.Aeson import Data.Yaml import qualified Data.Text as T import qualified Data.Either.Strict as S@@ -14,7 +14,6 @@ import Data.List (foldl') import Text.Parsec.Pos import Data.CaseInsensitive-import Debug.Trace import qualified Data.HashMap.Strict as HM import qualified Data.HashSet as HS @@ -32,7 +31,13 @@ type DB = TVar DBContent instance FromJSON DBContent where- parseJSON (Object v) = DBContent <$> v .: "resources" <*> v .: "facts" <*> pure Nothing+ parseJSON (Object v) = do+ let toText :: Value -> Parser T.Text+ toText (String m) = pure m+ toText (Number n) = pure (T.pack (show n))+ toText x = fail ("Could not convert " ++ show x ++ " to a string when parsing facts")+ fcts <- v .: "facts" >>= traverse (traverse toText)+ DBContent <$> v .: "resources" <*> pure fcts <*> pure Nothing parseJSON _ = mempty instance ToJSON DBContent where@@ -43,10 +48,15 @@ loadTestDB fp = decodeFileEither fp >>= \case Left (OtherParseException rr) -> return (S.Left (string (show rr)))- Left rr -> trace ("Warning: could not decode " ++ fp ++ " :" ++ show rr) (S.Right <$> genDBAPI (newDB & backingFile ?~ fp ))+ Left (InvalidYaml Nothing) -> baseError "Unknown error"+ Left (InvalidYaml (Just (YamlException s))) -> baseError (string s)+ Left (InvalidYaml (Just (YamlParseException pb ctx (YamlMark _ l c)))) -> baseError $ red (string pb <+> string ctx) <+> "at line" <+> int l <> ", column" <+> int c+ Left _ -> S.Right <$> genDBAPI (newDB & backingFile ?~ fp ) Right x -> fmap S.Right (genDBAPI (x & backingFile ?~ fp ))-+ where+ baseError r = return $ S.Left $ "Could not parse" <+> string fp <> ":" <+> r +-- | Starts a new PuppetDB, without any backing file. initTestDB :: IO PuppetDBAPI initTestDB = genDBAPI newDB @@ -133,9 +143,7 @@ resourceQuery :: ResourceField -> Resource -> Extracted resourceQuery RTag r = r ^. rtags . to ESet-resourceQuery RCertname r = case r ^. rnode of- Just t -> EText t- Nothing -> ENil+resourceQuery RCertname r = r ^. rnode . to EText resourceQuery (RParameter p) r = case r ^? rattributes . ix p . _PString of Just s -> EText s Nothing -> ENil
language-puppet.cabal view
@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: language-puppet-version: 0.10.2+version: 0.10.3 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/@@ -41,6 +41,7 @@ , Puppet.NativeTypes , Puppet.NativeTypes.Helpers , Puppet.Interpreter+ , Puppet.Interpreter.Resolve , SafeProcess , Puppet.Stdlib , Puppet.Testing@@ -48,6 +49,7 @@ , PuppetDB.TestDB , PuppetDB.Dummy , PuppetDB.Common+ , Hiera.Server other-modules: Text.Parser.Parsec , Puppet.Utils , Puppet.NativeTypes.File@@ -56,7 +58,6 @@ , Erb.Ruby , Erb.Evaluate , Erb.Compute- , Puppet.Interpreter.Resolve , Puppet.Manifests , Puppet.NativeTypes.ZoneRecord , Puppet.NativeTypes.Cron@@ -112,6 +113,9 @@ , stm == 2.4.* , hspec >= 1.7.0 && <1.8.0 , yaml >= 0.8.0 && <0.9+ , lens-aeson >= 0.1.2 && <0.2+ , stateWriter == 0.2.*+ Test-Suite test-lexer hs-source-dirs: tests type: exitcode-stdio-1.0@@ -126,13 +130,30 @@ extensions: OverloadedStrings build-depends: language-puppet,base,text,parsec,vector,ansi-wl-pprint main-is: expr.hs+Test-Suite test-hiera+ hs-source-dirs: tests+ type: exitcode-stdio-1.0+ ghc-options: -Wall -rtsopts -threaded+ extensions: OverloadedStrings+ build-depends: language-puppet,base,hspec,temporary,strict-base-types,HUnit,lens,vector,unordered-containers,text+ main-is: hiera.hs +Test-Suite test-puppetdb+ hs-source-dirs: tests+ type: exitcode-stdio-1.0+ ghc-options: -Wall -rtsopts -threaded+ extensions: OverloadedStrings+ build-depends: language-puppet,base,temporary,strict-base-types,lens,text+ main-is: puppetdb.hs+++ executable puppetresources hs-source-dirs: progs extensions: BangPatterns, OverloadedStrings ghc-options: -Wall -rtsopts -threaded ghc-prof-options: -auto-all -caf-all -fprof-auto- build-depends: language-puppet,base,text,parsec,vector,ansi-wl-pprint,bytestring,mtl,hslogger,Diff,unordered-containers,strict-base-types,optparse-applicative,regex-pcre-builtin,lens,aeson+ build-depends: language-puppet,base,text,parsec,vector,ansi-wl-pprint,bytestring,mtl,hslogger,Diff,unordered-containers,strict-base-types,optparse-applicative,regex-pcre-builtin,lens,aeson,yaml main-is: PuppetResources.hs executable pdbquery
progs/PuppetResources.hs view
@@ -112,11 +112,13 @@ import qualified Text.Parsec as P import qualified Data.Vector as V import qualified Data.Either.Strict as S-import Options.Applicative as O+import Options.Applicative as O hiding ((&)) import Control.Monad import Text.Regex.PCRE.String import Data.Text.Strict.Lens--- import Data.Aeson+import Data.Aeson (encode)+import Data.Yaml (decodeFileEither)+import Control.Lens as L import Facter @@ -128,6 +130,7 @@ import Puppet.Parser import Puppet.Parser.PrettyPrinter() import Puppet.Interpreter.PrettyPrinter()+import Puppet.Interpreter.Resolve (_PString) import PuppetDB.Remote import PuppetDB.Dummy import PuppetDB.TestDB@@ -142,11 +145,11 @@ hackish as it will generate facts from the local computer ! -} -initializedaemonWithPuppet :: LOG.Priority -> PuppetDBAPI -> FilePath -> IO (T.Text -> IO (FinalCatalog, EdgeMap, FinalCatalog))-initializedaemonWithPuppet prio pdbapi puppetdir = do+initializedaemonWithPuppet :: LOG.Priority -> PuppetDBAPI -> FilePath -> Maybe FilePath -> (Facts -> Facts) -> IO (T.Text -> IO (FinalCatalog, EdgeMap, FinalCatalog))+initializedaemonWithPuppet prio pdbapi puppetdir hierapath overrideFacts = do LOG.updateGlobalLogger "Puppet.Daemon" (LOG.setLevel prio)- q <- fmap (prefPDB .~ pdbapi) (genPreferences puppetdir) >>= initDaemon- let f ndename = puppetDBFacts ndename pdbapi+ q <- fmap ((prefPDB .~ pdbapi) . (hieraPath .~ hierapath)) (genPreferences puppetdir) >>= initDaemon+ let f ndename = fmap overrideFacts (puppetDBFacts ndename pdbapi) >>= _dGetCatalog q ndename >>= \case S.Left rr -> putDoc rr >> putStrLn "" >> error "error!"@@ -174,10 +177,55 @@ , _nodename :: Maybe String , _pdbfile :: Maybe FilePath , _loglevel :: LOG.Priority+ , _hieraFile :: Maybe FilePath+ , _factsFile :: Maybe FilePath+ , _factsDef :: Maybe FilePath } deriving Show +prepareForPuppetApply :: WireCatalog -> WireCatalog+prepareForPuppetApply w =+ let res = V.filter (\r -> r ^. rvirtuality == Normal) (w ^. wResources) :: V.Vector Resource+ -- step 1 : capitalize resources types (and names in case of+ -- classes), and filter out exported stuff+ capi :: RIdentifier -> RIdentifier+ capi r = r & itype %~ capitalizeRT & if r ^. itype == "class"+ then iname %~ capitalizeRT+ else id+ aliasMap :: HM.HashMap RIdentifier T.Text+ 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)+ 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+ knownEdge :: PuppetEdge -> Bool+ knownEdge (PuppetEdge s d _) = (aliasMap ^. contains s) && (aliasMap ^. contains d)+ correctEdges = V.map correctEdge $ V.filter knownEdge ne+ correctResources = V.map correctResource nr+ correct :: RIdentifier -> RIdentifier+ correct ri = ri & iname %~ \n -> HM.lookupDefault n ri aliasMap+ correctEdge :: PuppetEdge -> PuppetEdge+ correctEdge (PuppetEdge s d x) = PuppetEdge (correct s) (correct d) x+ correctResource :: Resource -> Resource+ correctResource r = r & rrelations %~ HM.fromList . filter (\(x,_) -> aliasMap ^. contains x) . map (_1 %~ correct) . HM.toList+ in (wResources .~ correctResources)+ . (wEdges .~ correctEdges)+ $ w+ cmdlineParser :: Parser CommandLine-cmdlineParser = CommandLine <$> optional remotepdb <*> sj <*> sc <*> optional (T.pack <$> rt) <*> optional (T.pack <$> rn) <*> pdir <*> optional nn <*> optional pdbfile <*> priority+cmdlineParser = CommandLine <$> optional remotepdb+ <*> sj+ <*> sc+ <*> optional (T.pack <$> rt)+ <*> optional (T.pack <$> rn)+ <*> pdir+ <*> optional nn+ <*> optional pdbfile+ <*> priority+ <*> optional hiera+ <*> optional fcts+ <*> optional fco where sc = switch ( long "showcontent" <> short 'c'@@ -201,16 +249,36 @@ <> help "Node name") pdbfile = strOption ( long "pdbfile" <> help "Path to the testing PuppetDB file.")+ hiera = strOption ( long "hiera"+ <> help "Path to the Hiera configuration file (default hiera.yaml)"+ <> value "hiera.yaml"+ ) priority = option ( long "loglevel" <> short 'v' <> help "Values are : DEBUG, INFO, NOTICE, WARNING, ERROR, CRITICAL, ALERT, EMERGENCY" <> value LOG.WARNING )+ fcts = strOption ( long "facts-override"+ <> help "Path to a Yaml file containing a list of 'facts' that will override locally resolved facts"+ )+ fco = strOption ( long "facts-defaults"+ <> help "Path to a Yaml file containing a list of 'facts' that will be used as defaults"+ )++loadFactsOverrides :: FilePath -> IO Facts+loadFactsOverrides fp = decodeFileEither fp >>= \case+ Left rr -> error ("Error when parsing " ++ fp ++ ": " ++ show rr)+ Right x -> case traverse tv x of+ Just y -> return y+ Nothing -> error ("Error when parsing " ++ fp ++ ": some of the values were not strings")+ where+ tv x = x ^? _PString+ run :: CommandLine -> IO ()-run (CommandLine _ _ _ _ _ f Nothing _ _) = parseFile f >>= \case+run (CommandLine _ _ _ _ _ f Nothing _ _ _ _ _) = parseFile f >>= \case Left rr -> error ("parse error:" ++ show rr) Right s -> putDoc (vcat (map pretty (V.toList s)))-run (CommandLine puppeturl showjson showcontent mrt mrn puppetdir (Just ndename) mpdbf prio) = do+run (CommandLine puppeturl showjson showcontent mrt mrn puppetdir (Just ndename) mpdbf prio hpath fcts fdef) = do let checkError r (S.Left rr) = error (show (red r <> ":" <+> rr)) checkError _ (S.Right x) = return x tnodename = T.pack ndename@@ -219,13 +287,19 @@ (Just _, Just _) -> error "You must choose between a testing PuppetDB and a remote one" (Just url, _) -> pdbConnect (T.pack url) >>= checkError "Error when connecting to the remote PuppetDB" (_, Just file) -> loadTestDB file >>= checkError "Error when initializing the PuppetDB API"- queryfunc <- initializedaemonWithPuppet prio pdbapi puppetdir+ !factsOverrides <- case (fcts, fdef) of+ (Just _, Just _) -> error "You can't use --facts-override and --facts-defaults at the same time"+ (Just p, Nothing) -> HM.union `fmap` loadFactsOverrides p+ (Nothing, Just p) -> (flip HM.union) `fmap` loadFactsOverrides p+ (Nothing, Nothing) -> return id+ queryfunc <- initializedaemonWithPuppet prio pdbapi puppetdir hpath factsOverrides printFunc <- hIsTerminalDevice stdout >>= \isterm -> return $ \x -> if isterm then putDoc x >> putStrLn "" else displayIO stdout (renderCompact x) >> putStrLn "" (rawcatalog,m,rawexported) <- queryfunc tnodename- void $ replaceCatalog pdbapi (generateWireCatalog tnodename (rawcatalog <> rawexported) m)+ let wireCatalog = generateWireCatalog tnodename (rawcatalog <> rawexported) m+ void $ replaceCatalog pdbapi wireCatalog void $ commitDB pdbapi let cmpMatch Nothing _ curcat = return curcat cmpMatch (Just rg) lns curcat = compile compBlank execBlank (T.unpack rg) >>= \case@@ -238,8 +312,8 @@ filterCatalog = cmpMatch mrt (_1 . itype . unpacked) >=> cmpMatch mrn (_1 . iname . unpacked) catalog <- filterCatalog rawcatalog exported <- filterCatalog rawexported- case (showcontent, showjson) of- (_, True) -> BSL.putStrLn ("TODO JSON MODE")+ case (showcontent, showjson) of+ (_, True) -> BSL.putStrLn (encode (prepareForPuppetApply wireCatalog)) (True, _) -> do unless (mrt == Just "file" || mrt == Nothing) (error $ "Show content only works for file, not for " ++ show mrt) case mrn of
progs/pdbQuery.hs view
@@ -5,6 +5,7 @@ import PuppetDB.Common import PuppetDB.TestDB import PuppetDB.Remote+import Facter import Options.Applicative as O import qualified Data.Text as T@@ -14,7 +15,7 @@ import qualified Data.Either.Strict as S import Control.Lens import qualified Data.HashMap.Strict as HM-import Control.Monad (forM_)+import Control.Monad (forM_,unless) import qualified Data.Vector as V data CommandLine = CommandLine { _pdbloc :: Maybe FilePath@@ -28,6 +29,7 @@ | DeactivateNode T.Text | DumpResources T.Text | CreateTestDB FilePath+ | AddFacts T.Text factedit :: Parser Command factedit = EditFact <$> O.argument (Just . T.pack) mempty <*> O.argument (Just . T.pack) mempty@@ -41,6 +43,9 @@ createtestdb :: Parser Command createtestdb = CreateTestDB <$> O.argument Just mempty +addfacts :: Parser Command+addfacts = AddFacts <$> O.argument (Just . T.pack) mempty+ cmdlineParser :: Parser CommandLine cmdlineParser = CommandLine <$> optional pl <*> pt <*> cmd where@@ -59,6 +64,7 @@ <> command "delnode" (ParserInfo delnodeparser True "Deactivate node" "Deactivate node" "" 6) <> command "nodes" (ParserInfo (pure DumpNodes) True "Dump all nodes" "Dump all nodes" "" 8) <> command "snapshot" (ParserInfo createtestdb True "Create a test DB from the current DB" "" "" 10)+ <> command "addfacts" (ParserInfo addfacts True "Adds facts to the test DB for the given node name, if they are not already defined" "" "" 11) ) display :: (Show r, ToJSON a) => String -> S.Either r a -> IO ()@@ -74,12 +80,17 @@ pdbapi <- case epdbapi of S.Left r -> error (show r) S.Right x -> return x+ let getOrError s (S.Left rr) = error (s <> " " <> show rr)+ getOrError _ (S.Right x) = return x case _pdbcmd cmdl of DumpFacts -> getFacts pdbapi QEmpty >>= display "get facts" DumpNodes -> getNodes pdbapi QEmpty >>= display "dump nodes"+ AddFacts n -> do+ unless (_pdbtype cmdl == PDBTest) (error "This option only works with the test puppetdb")+ fcts <- puppetDBFacts n pdbapi+ replaceFacts pdbapi [(n, fcts)] >>= getOrError "replace facts"+ commitDB pdbapi >>= getOrError "commit db" CreateTestDB destfile -> do- let getOrError s (S.Left rr) = error (s <> " " <> show rr)- getOrError _ (S.Right x) = return x ndb <- loadTestDB destfile >>= getOrError "puppetdb load" allnodes <- getNodes pdbapi QEmpty >>= getOrError "get nodes" allfacts <- getFacts pdbapi QEmpty >>= getOrError "get facts"
ruby/calcerb.rb view
@@ -7,6 +7,10 @@ @context = ctx end + def [](key)+ lookupvar(key)+ end+ def lookupvar(name) if name.start_with?("::") name = name[2..-1]
ruby/hrubyerb.rb view
@@ -7,6 +7,10 @@ @variables = variables end + def [](key)+ lookupvar(key)+ end+ def vl(name) if name.start_with?("::") name = name[2..-1]
+ tests/hiera.hs view
@@ -0,0 +1,59 @@+module Main where++import Test.Hspec+import System.IO.Temp+import Hiera.Server+import Data.Monoid+import qualified Data.Either.Strict as S+import qualified Data.Maybe.Strict as S+import Data.Tuple.Strict+import Test.HUnit+import qualified Data.Vector as V+import qualified Data.HashMap.Strict as HM+import qualified Data.Text as T++import Puppet.Parser.Types+import Puppet.Interpreter.Types++main :: IO ()+main = withSystemTempDirectory "hieratest" $ \tmpfp -> do+ let ndname = "node.site.com"+ newscope = HM.singleton "::" (ScopeInformation vars mempty mempty (CurContainer ContRoot mempty) mempty S.Nothing)+ vars = HM.fromList [ ("environment", ("production" :!: initialPPos "dummy" :!: ContRoot))+ , ("fqdn" , (PString ndname :!: initialPPos "dummy" :!: ContRoot))+ ]+ writeFile (tmpfp ++ "/hiera.yaml") $ "---\n:backends:\n - \"yaml\"\n - \"json\"\n:logger: \"console\"\n:hierarchy:\n - \"%{::fqdn}\"\n - \"%{::environment}\"\n - \"global\"\n\n:yaml:\n :datadir: " ++ show tmpfp ++ "\n:json:\n :datadir: " ++ show tmpfp ++ "\n"+ writeFile (tmpfp ++ "/global.yaml") "---\nhttp_port: 8080\nntp_servers: ['0.ntp.puppetlabs.com', '1.ntp.puppetlabs.com']\nusers:\n pete:\n uid: 2000\n tom:\n uid: 2001\nglobal: \"glob\""+ writeFile (tmpfp ++ "/production.yaml") "---\nhttp_port: 9090\nntp_servers: ['2.ntp.puppetlabs.com', '3.ntp.puppetlabs.com']\ninterp1: '**%{::fqdn}**'\nusers:\n bob:\n uid: 100\n tom:\n uid: 12\n"+ writeFile (tmpfp ++ "/" ++ T.unpack ndname ++ ".json") "{\"testnode\":{\"1\":\"**%{::fqdn}**\",\"2\":\"nothing special\"},\"testjson\":\"ok\",\"arraytest\":[\"a\",\"%{::fqdn}\",\"c\"]}\n"+ let users = HM.fromList [ ("pete", PHash (HM.singleton "uid" "2000"))+ , ("tom" , PHash (HM.singleton "uid" "2001"))+ ]+ pusers = HM.fromList [ ("bob", PHash (HM.singleton "uid" "100"))+ , ("tom" , PHash (HM.singleton "uid" "12"))+ ]+ Right rq <- startHiera (tmpfp ++ "/hiera.yaml")+ let checkOutput v (S.Right (_ :!: x)) = x @?= v+ checkOutput _ (S.Left rr) = assertFailure (show rr)+ q = rq+ hspec $ do+ describe "lookup data without a key" $ do+ it "returns an error when called with an empty string" $ q mempty "" Priority >>= checkOutput S.Nothing+ describe "lookup data with no options" $ do+ it "can get string data" $ q mempty "http_port" Priority >>= checkOutput (S.Just "8080")+ it "can get arrays" $ q mempty "ntp_servers" Priority >>= checkOutput (S.Just (PArray (V.fromList ["0.ntp.puppetlabs.com","1.ntp.puppetlabs.com"])))+ it "can get hashes" $ q mempty "users" Priority >>= checkOutput (S.Just (PHash users))+ describe "lookup data with a scope" $ do+ it "overrides some values" $ q newscope "http_port" Priority >>= checkOutput (S.Just "9090")+ it "doesn't fail on others" $ q newscope "global" Priority >>= checkOutput (S.Just "glob")+ describe "json backend" $ do+ it "resolves in json" $ q newscope "testjson" Priority >>= checkOutput (S.Just "ok")+ describe "deep interpolation" $ do+ it "resolves in strings" $ q newscope "interp1" Priority >>= checkOutput (S.Just (PString ("**" <> ndname <> "**")))+ it "resolves in objects" $ q newscope "testnode" Priority >>= checkOutput (S.Just (PHash (HM.fromList [("1",PString ("**" <> ndname <> "**")),("2",PString "nothing special")])))+ it "resolves in arrays" $ q newscope "arraytest" Priority >>= checkOutput (S.Just (PArray (V.fromList [PString "a", PString ndname, PString "c"])))+ describe "other merge modes" $ do+ it "catenates arrays" $ q newscope "ntp_servers" ArrayMerge >>= checkOutput (S.Just (PArray (V.fromList ["2.ntp.puppetlabs.com","3.ntp.puppetlabs.com","0.ntp.puppetlabs.com","1.ntp.puppetlabs.com"])))+ it "puts single values in arrays" $ q newscope "http_port" ArrayMerge >>= checkOutput (S.Just (PArray (V.fromList ["9090","8080"])))+ it "merges hashes" $ q newscope "users" HashMerge >>= checkOutput (S.Just (PHash (pusers <> users)))+
tests/lexer.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE LambdaCase #-} module Main where import Control.Monad
+ tests/puppetdb.hs view
@@ -0,0 +1,45 @@+module Main where++import Control.Monad+import System.IO.Temp+import Data.Monoid+import qualified Data.Either.Strict as S+import qualified Data.Text as T+import qualified Data.Text.IO as T+import Control.Lens++import Puppet.Interpreter.Types+import PuppetDB.Common+import PuppetDB.TestDB+import Facter++checkError :: Show x => String -> S.Either x a -> IO a+checkError _ (S.Right x) = return x+checkError step (S.Left rr) = error (step ++ ": " ++ show rr)++main :: IO ()+main = withSystemTempDirectory "hieratest" $ \tmpfp -> do+ let ndname = "node.site.com"+ pdbfile = tmpfp <> "/puppetdb.yaml"+ -- generate an empty puppetdb+ pdb <- loadTestDB pdbfile >>= checkError "loadTestDB"+ -- get some dummy facts+ facts <- puppetDBFacts ndname pdb+ -- and add a custom fact+ let nfacts = facts & at "customfact" ?~ "MyCustomFactValue"+ -- save the facts+ replaceFacts pdb [(ndname, nfacts)] >>= checkError "replaceFacts"+ commitDB pdb >>= checkError "commitDB"+ -- check that our custom fact was indeed saved+ dblines <- T.lines `fmap` T.readFile pdbfile+ unless (" customfact: MyCustomFactValue" `elem` dblines) (error "could not find my fact")+ -- now we initiate a new puppetdbapi+ fpdb <- loadTestDB pdbfile >>= checkError "loadTestDB"+ ffacts <- puppetDBFacts ndname pdb+ unless (ffacts == nfacts) (error "facts are distinct")+ replaceCatalog fpdb (generateWireCatalog ndname mempty mempty) >>= checkError "replaceCatalog"+ commitDB fpdb >>= checkError "commit 2"+ -- and check for our facts again+ fdblines <- T.lines `fmap` T.readFile pdbfile+ unless (" customfact: MyCustomFactValue" `elem` fdblines) (error "could not find my fact")+