language-puppet 0.12.2 → 0.12.3
raw patch · 23 files changed
+444/−182 lines, 23 filesdep +operationaldep ~pcre-utils
Dependencies added: operational
Dependency ranges changed: pcre-utils
Files
- Erb/Compute.hs +1/−1
- Facter.hs +1/−1
- Hiera/Server.hs +24/−18
- Puppet/Daemon.hs +9/−8
- Puppet/Interpreter.hs +23/−29
- Puppet/Interpreter/IO.hs +96/−0
- Puppet/Interpreter/PrettyPrinter.hs +41/−0
- Puppet/Interpreter/Resolve.hs +35/−40
- Puppet/Interpreter/Types.hs +103/−28
- Puppet/Lens.hs +1/−4
- Puppet/Manifests.hs +2/−2
- Puppet/NativeTypes.hs +2/−1
- Puppet/Parser.hs +12/−9
- Puppet/Plugins.hs +7/−2
- Puppet/Preferences.hs +6/−3
- Puppet/Stdlib.hs +12/−15
- Puppet/Testing.hs +55/−8
- PuppetDB/Common.hs +1/−1
- PuppetDB/Dummy.hs +1/−1
- PuppetDB/Remote.hs +1/−1
- PuppetDB/TestDB.hs +3/−3
- language-puppet.cabal +4/−2
- progs/PuppetResources.hs +4/−5
Erb/Compute.hs view
@@ -63,7 +63,7 @@ showRubyError (Stack msg stk) = dullred (string msg) </> dullyellow (string stk) showRubyError (WithOutput str _) = dullred (string str) -initTemplateDaemon :: RubyInterpreter -> Preferences -> MStats -> IO (Either T.Text T.Text -> T.Text -> Container ScopeInformation -> IO (S.Either Doc T.Text))+initTemplateDaemon :: RubyInterpreter -> (Preferences IO) -> MStats -> IO (Either T.Text T.Text -> T.Text -> Container ScopeInformation -> IO (S.Either Doc T.Text)) initTemplateDaemon intr (Preferences _ modpath templatepath _ _ _ _) mvstats = do controlchan <- newChan templatecache <- newFileCache
Facter.hs view
@@ -132,7 +132,7 @@ modelnames = mapMaybe (fmap (dropWhile (`elem` "\t :")) . stripPrefix "model name") (lines cpuinfo) return $ ("processorcount", show (length cpuinfos)) : cpuinfos -puppetDBFacts :: T.Text -> PuppetDBAPI -> IO (Container T.Text)+puppetDBFacts :: T.Text -> PuppetDBAPI IO -> IO (Container T.Text) puppetDBFacts ndename pdbapi = getFacts pdbapi (QEqual FCertname ndename) >>= \case S.Right facts@(_:_) -> return (HM.fromList (map (\f -> (f ^. factname, f ^. factval)) facts))
Hiera/Server.hs view
@@ -16,6 +16,7 @@ import qualified Data.Attoparsec.Text as AT import qualified Data.ByteString.Lazy as BS import qualified Data.Vector as V+import qualified Data.List as L import qualified Data.HashMap.Strict as HM import Data.Tuple.Strict import Control.Monad.Writer.Strict@@ -23,13 +24,11 @@ import Control.Applicative import Control.Lens import Data.Aeson.Lens-import Puppet.Lens 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]@@ -53,7 +52,7 @@ pretty (HVariable v) = dullred (string "%{" <> ttext v <> string "}") prettyList = mconcat . map pretty -type HieraCache = F.FileCacheR Doc Y.Value+type HieraCache = F.FileCacheR String Y.Value makeFields ''HieraConfig @@ -96,7 +95,7 @@ -- | 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 :: FilePath -> IO (Either String (HieraQueryFunc IO)) startHiera hieraconfig = Y.decodeFileEither hieraconfig >>= \case Left ex -> return (Left (show ex)) Right cfg -> do@@ -105,7 +104,7 @@ return (Right (query ncfg cache)) -- | A dummy hiera function that will be used when hiera is not detected-dummyHiera :: HieraQueryFunc+dummyHiera :: Monad m => HieraQueryFunc m dummyHiera _ _ _ = return (S.Right ([] :!: S.Nothing)) -- | The combinator for "normal" queries@@ -124,7 +123,7 @@ toA (S.Just (PArray r)) = r toA (S.Just a) = V.singleton a --- | The combinator for hiera_array+-- | The combinator for hiera_hash queryCombinatorHash :: [LogWriter (S.Maybe PValue)] -> LogWriter (S.Maybe PValue) queryCombinatorHash = fmap (S.Just . PHash . mconcat . map toH) . sequence where@@ -132,19 +131,19 @@ toH (S.Just (PHash h)) = h toH _ = throw (ErrorCall "The hiera value was not a hash") -interpolateText :: Container ScopeInformation -> T.Text -> T.Text+interpolateText :: Container T.Text -> 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 :: Container T.Text -> [HieraStringPart] -> Maybe T.Text resolveInterpolable vars = fmap T.concat . mapM (resolveInterpolablePart vars) -resolveInterpolablePart :: Container ScopeInformation -> HieraStringPart -> Maybe T.Text+resolveInterpolablePart :: Container T.Text -> HieraStringPart -> Maybe T.Text resolveInterpolablePart _ (HString x) = Just x-resolveInterpolablePart vars (HVariable v) = getVariable vars "::" v ^? _Right . _PString+resolveInterpolablePart vars (HVariable v) = vars ^. at v -interpolatePValue :: Container ScopeInformation -> PValue -> PValue+interpolatePValue :: Container T.Text -> 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)@@ -152,10 +151,12 @@ 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))+query :: HieraConfig -> HieraCache -> HieraQueryFunc IO+query (HieraConfig b h bd) cache vars hquery qtype = do+ fmap (S.Right . prepout) (runWriterT (sequencerFunction (map query' h))) `catch` (\e -> return . S.Left . string . show $ (e :: SomeException)) where prepout (a,s) = s :!: a+ varlist = hcat (L.intersperse comma (map (dullblue . ttext) (L.sort (HM.keys vars)))) sequencerFunction = case qtype of Priority -> queryCombinator ArrayMerge -> queryCombinatorArray@@ -164,12 +165,12 @@ 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+ Nothing -> warn ("Hiera: could not interpolate " <> pretty strs <> ", known variables are:" <+> varlist) >> 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")+ (JsonBackend d) -> (fmap (strictifyEither . A.eitherDecode') . BS.readFile , d, ".json")+ (YamlBackend d) -> (fmap (strictifyEither . (_Left %~ show)) . Y.decodeFileEither, d, ".yaml") filename = mbd <> datadir <> "/" <> T.unpack hieraname <> extension where mbd = case datadir of@@ -179,8 +180,13 @@ 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+ _ -> warn ("Hiera:" <+> dullred "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.Left r -> do+ let errs = "Hiera: error when reading file " <> string filename <+> string r+ if "Yaml file not found: " `L.isInfixOf` r+ then debug errs+ else warn errs+ return S.Nothing S.Right x -> mfromJSON (x ^? key hquery)
Puppet/Daemon.hs view
@@ -9,11 +9,12 @@ import Puppet.Parser.Types import Puppet.Manifests import Puppet.Interpreter+import Puppet.Interpreter.IO import Puppet.Plugins+import Puppet.PP import Hiera.Server import Erb.Compute -import Puppet.PP import Data.FileCache import qualified System.Log.Logger as LOG import qualified Data.Text as T@@ -76,7 +77,7 @@ is nonexistent. This will need fixing. -}-initDaemon :: Preferences -> IO DaemonMethods+initDaemon :: Preferences IO -> IO DaemonMethods initDaemon prefs = do logDebug "initDaemon" traceEventIO "initDaemon"@@ -100,23 +101,23 @@ let myprefs = prefs & prefExtFuncs %~ HM.union luacontainer return (DaemonMethods (gCatalog myprefs getStatements getTemplate catalogStats hquery) parserStats catalogStats templateStats) -gCatalog :: Preferences+gCatalog :: Preferences IO -> ( 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+ -> HieraQueryFunc IO -> T.Text -> Facts -> IO (S.Either Doc (FinalCatalog, EdgeMap, FinalCatalog, [Resource])) gCatalog prefs getStatements getTemplate stats hquery ndename facts = do logDebug ("Received query for node " <> ndename) traceEventIO ("START gCatalog " <> T.unpack ndename)- (stmts :!: warnings) <- measure stats ndename $ getCatalog getStatements getTemplate (prefs ^. prefPDB) ndename facts (prefs ^. natTypes) (prefs ^. prefExtFuncs) hquery+ (stmts :!: warnings) <- measure stats ndename $ getCatalog interpretMonad getStatements getTemplate (prefs ^. prefPDB) ndename facts (prefs ^. natTypes) (prefs ^. prefExtFuncs) hquery defaultImpureMethods mapM_ (\(p :!: m) -> LOG.logM loggerName p (displayS (renderCompact (ttext ndename <> ":" <+> m)) "")) warnings traceEventIO ("STOP gCatalog " <> T.unpack ndename) return stmts -parseFunction :: Preferences -> FileCache (V.Vector Statement) -> MStats -> TopLevelType -> T.Text -> IO (S.Either Doc Statement)+parseFunction :: Preferences IO -> FileCache (V.Vector Statement) -> MStats -> TopLevelType -> T.Text -> IO (S.Either Doc Statement) parseFunction prefs filecache stats topleveltype toplevelname = case compileFileList prefs topleveltype toplevelname of S.Left rr -> return (S.Left rr)@@ -131,7 +132,7 @@ -- TODO this is wrong, see -- http://docs.puppetlabs.com/puppet/3/reference/lang_namespaces.html#behavior-compileFileList :: Preferences -> TopLevelType -> T.Text -> S.Either Doc T.Text+compileFileList :: Preferences IO -> TopLevelType -> T.Text -> S.Either Doc T.Text compileFileList prefs TopNode _ = S.Right (T.pack (prefs ^. manifestPath) <> "/site.pp") compileFileList prefs _ name = moduleInfo where@@ -145,7 +146,7 @@ parseFile fname = do traceEventIO ("START parsing " ++ fname) cnt <- T.readFile fname- o <- runMyParser puppetParser fname cnt >>= \case+ o <- case runMyParser puppetParser fname cnt of Right r -> traceEventIO ("Stopped parsing " ++ fname) >> return (S.Right r) Left rr -> traceEventIO ("Stopped parsing " ++ fname ++ " (failure: " ++ show rr ++ ")") >> return (S.Left (show rr)) traceEventIO ("STOP parsing " ++ fname)
Puppet/Interpreter.hs view
@@ -20,7 +20,6 @@ import qualified Data.Either.Strict as S import qualified Data.HashSet as HS import qualified Data.HashMap.Strict as HM-import Control.Monad.Trans.RSS.Strict import Control.Monad.Error hiding (mapM,forM) import Control.Lens import qualified Data.Maybe.Strict as S@@ -28,7 +27,7 @@ import qualified Data.Tree as T import Data.Foldable (toList,foldl',Foldable,foldlM) import Data.Traversable (mapM,forM)-import Debug.Trace (traceEventIO)+import Control.Monad.Operational -- helpers vmapM :: (Monad m, Foldable t) => (a -> m b) -> t a -> m [b]@@ -40,25 +39,28 @@ -- (this last one might not be up to date and is only useful for code -- coverage tests)) along with all messages that have been generated by the -- compilation process.-getCatalog :: ( TopLevelType -> T.Text -> IO (S.Either Doc Statement) ) -- ^ get statements function- -> (Either T.Text T.Text -> T.Text -> Container ScopeInformation -> IO (S.Either Doc T.Text)) -- ^ compute template function- -> PuppetDBAPI+getCatalog :: Monad m+ => (InterpreterReader m -> InterpreterState -> InterpreterMonad (FinalCatalog, EdgeMap, FinalCatalog, [Resource]) -> m (Either Doc (FinalCatalog, EdgeMap, FinalCatalog, [Resource]), InterpreterState, InterpreterWriter)) -- ^ A function that will interpret the InterpreterMonad and will convert it to something else (for example, 'interpretIO')+ -> ( TopLevelType -> T.Text -> m (S.Either Doc Statement) ) -- ^ get statements function+ -> (Either T.Text T.Text -> T.Text -> Container ScopeInformation -> m (S.Either Doc T.Text)) -- ^ compute template function+ -> PuppetDBAPI m -> T.Text -- ^ Node name -> Facts -- ^ Facts ... -> Container PuppetTypeMethods -- ^ List of native types -> Container ( [PValue] -> InterpreterMonad PValue )- -> HieraQueryFunc -- ^ Hiera query function- -> IO (Pair (S.Either Doc (FinalCatalog, EdgeMap, FinalCatalog, [Resource])) [Pair Priority Doc])-getCatalog gtStatement gtTemplate pdbQuery ndename facts nTypes extfuncs hquery = do- nameThread ("Catalog " <> T.unpack ndename)- let rdr = InterpreterReader nTypes gtStatement gtTemplate pdbQuery extfuncs ndename hquery+ -> HieraQueryFunc m -- ^ Hiera query function+ -> ImpureMethods m+ -> m (Pair (S.Either Doc (FinalCatalog, EdgeMap, FinalCatalog, [Resource])) [Pair Priority Doc])+getCatalog convertMonad gtStatement gtTemplate pdbQuery ndename facts nTypes extfuncs hquery im = do+ -- nameThread ("Catalog " <> T.unpack ndename)+ let rdr = InterpreterReader nTypes gtStatement gtTemplate pdbQuery extfuncs ndename hquery im dummypos = initialPPos "dummy" initialclass = mempty & at "::" ?~ (IncludeStandard :!: dummypos) 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) <- runRSST (runErrorT (computeCatalog ndename)) rdr stt+ (output, _, warnings) <- convertMonad rdr stt (computeCatalog ndename) return (strictifyEither output :!: warnings) isParent :: T.Text -> CurContainerDesc -> InterpreterMonad Bool@@ -146,12 +148,7 @@ -- check if this is a known class (spurious or inner class) use (nestedDeclarations . at (topleveltype, toplevelname)) >>= \case Just x -> return ([], x) -- it is known !- Nothing -> do- -- load the file- getStmtfunc <- view getStatement- liftIO (getStmtfunc topleveltype toplevelname) >>= \case- S.Right x -> evalTopLevel x- S.Left y -> throwPosError y+ Nothing -> singleton (GetStatement topleveltype toplevelname) >>= evalTopLevel computeCatalog :: T.Text -> InterpreterMonad (FinalCatalog, EdgeMap, FinalCatalog, [Resource]) computeCatalog ndename = do@@ -342,13 +339,12 @@ if et == RealizeCollected then do let q = searchExpressionToPuppetDB resType rsearch- pdb <- view pdbAPI- fqdn <- view thisNodename+ fqdn <- singleton GetNodeName -- 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)+ ) `fmap` singleton (PDBGetResources q) scpdesc <- ContImported `fmap` getScope void $ enterScope SENormal scpdesc "importing" p pushScope scpdesc@@ -533,8 +529,9 @@ return $ ScopeInformation mempty curdefs mempty (CurContainer cont mempty) mempty S.Nothing scopes . at scopename ?= basescope scopes . ix scopename . scopeVariables . at "caller_module_name" ?= (curcaller :!: p :!: cont)- scopes . ix "::" . scopeVariables . at "calling_module" ?= (curcaller :!: p :!: cont) -- hiera compatibility :(+ scopes . ix "::" . scopeVariables . at "calling_module" ?= (curcaller :!: p :!: cont) scopes . ix scopename . scopeVariables . at "module_name" ?= (PString modulename :!: p :!: cont)+ debug ("enterScope, scopename=" <> ttext scopename <+> "caller_module_name=" <> pretty curcaller <+> "module_name=" <> ttext modulename) return scopename dropInitialColons :: T.Text -> T.Text@@ -581,8 +578,8 @@ -> InterpreterMonad [Resource] loadClass rclassname loadedfrom params cincludetype = do let classname = dropInitialColons rclassname- ndn <- view thisNodename- liftIO (traceEventIO ('[' : T.unpack ndn ++ "] loadClass " ++ T.unpack classname))+ ndn <- singleton GetNodeName+ singleton (TraceEvent ('[' : T.unpack ndn ++ "] loadClass " ++ T.unpack classname)) p <- use curPos -- check if the class has already been loaded -- http://docs.puppetlabs.com/puppet/3/reference/lang_classes.html#using-resource-like-declarations@@ -618,7 +615,7 @@ classresource <- if cincludetype == IncludeStandard then do scp <- use curScope- fqdn <- view thisNodename+ fqdn <- singleton GetNodeName return [Resource (RIdentifier "class" classname) (HS.singleton classname) mempty mempty scp Normal mempty p fqdn] else return [] pushScope scopedesc@@ -690,7 +687,7 @@ getClassTags (ContImported _ ) = [] getClassTags (ContImport _ _ ) = [] allScope <- use curScope- fqdn <- view thisNodename+ fqdn <- singleton GetNodeName 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@@ -770,10 +767,7 @@ mainFunctionCall fname args = do p <- use curPos let representation = MainFunctionCall fname mempty p- external <- view externalFunctions- rs <- case external ^. at fname of- Just f -> f args- Nothing -> throwPosError ("Unknown function:" <+> pretty representation)+ rs <- singleton (ExternalFunction fname args) unless (rs == PUndef) $ throwPosError ("This function call should return" <+> pretty PUndef <+> "and not" <+> pretty rs <$> pretty representation) return [] -- Method stuff
+ Puppet/Interpreter/IO.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+-- | This is an internal module.+module Puppet.Interpreter.IO where++import Puppet.PP+import Puppet.Interpreter.Types+import Puppet.Interpreter.PrettyPrinter()+import Puppet.Plugins()++import Control.Monad.Operational+import Control.Monad.RSS.Strict+import Control.Monad.State.Strict+import Control.Lens++import qualified Data.ByteString as BS+import qualified Data.Either.Strict as S++import GHC.Stack+import Debug.Trace (traceEventIO)+import qualified Data.Text as T+import qualified Data.Text.IO as T+import Control.Exception+import qualified Scripting.Lua as Lua+import Control.Concurrent.MVar+import Data.Tuple.Strict (Pair(..))+import System.Log.Logger (Priority(..))++bs :: BS.ByteString -> Doc+bs = string . show++defaultImpureMethods :: (Functor m, MonadIO m) => ImpureMethods m+defaultImpureMethods = ImpureMethods (liftIO currentCallStack)+ (liftIO . file)+ (liftIO . traceEventIO)+ (\c fname args -> liftIO (runlua c fname args))+ where+ file [] = return $ Left ""+ file (x:xs) = fmap Right (T.readFile (T.unpack x)) `catch` (\SomeException{} -> file xs)+ runlua c fname args = liftIO $ withMVar c $ \lstt ->+ catch (fmap Right (Lua.callfunc lstt (T.unpack fname) args)) (\e -> return $ Left $ show (e :: SomeException))++evalInstrGen :: (Functor m, Monad m) => InterpreterReader m -> InterpreterState -> ProgramViewT InterpreterInstr (State InterpreterState) a -> m (Either Doc a, InterpreterState, InterpreterWriter)+evalInstrGen _ stt (Return x) = return (Right x, stt, mempty)+evalInstrGen rdr stt (a :>>= f) =+ let runC a' = interpretMonad rdr stt (f a')+ thpe = interpretMonad rdr stt . throwPosError+ pdb = _pdbAPI rdr+ strFail iof errf = iof >>= \case+ Left rr -> thpe (errf (string rr))+ Right x -> runC x+ canFail iof = iof >>= \case+ S.Left rr -> thpe rr+ S.Right x -> runC x+ logStuff x c = (_3 %~ (x <>)) `fmap` c+ in case a of+ ExternalFunction fname args -> case rdr ^. externalFunctions . at fname of+ Just fn -> interpretMonad rdr stt ( fn args >>= f)+ Nothing -> thpe ("Unknown function: " <> ttext fname)+ GetStatement topleveltype toplevelname+ -> canFail ((rdr ^. getStatement) topleveltype toplevelname)+ ComputeTemplate fn scp cscps -> canFail ((rdr ^. computeTemplateFunction) fn scp cscps)+ WriterTell t -> logStuff t (runC ())+ WriterPass _ -> thpe "WriterPass"+ WriterListen _ -> thpe "WriterListen"+ GetNativeTypes -> runC (rdr ^. nativeTypes)+ ErrorThrow d -> return (Left d, stt, mempty)+ ErrorCatch _ _ -> thpe "ErrorCatch"+ GetNodeName -> runC (rdr ^. thisNodename)+ hq@(HieraQuery scps q t) -> logStuff [DEBUG :!: pretty hq] (canFail ((rdr ^. hieraQuery) scps q t))+ PDBInformation -> pdbInformation pdb >>= runC+ PDBReplaceCatalog w -> canFail (replaceCatalog pdb w)+ PDBReplaceFacts fcts -> canFail (replaceFacts pdb fcts)+ PDBDeactivateNode nn -> canFail (deactivateNode pdb nn)+ PDBGetFacts q -> canFail (getFacts pdb q)+ PDBGetResources q -> canFail (getResources pdb q)+ PDBGetNodes q -> canFail (getNodes pdb q)+ PDBCommitDB -> canFail (commitDB pdb)+ PDBGetResourcesOfNode nn q -> canFail (getResourcesOfNode pdb nn q)+ GetCurrentCallStack -> (rdr ^. ioMethods . imGetCurrentCallStack) >>= runC+ ReadFile fls -> strFail ((rdr ^. ioMethods . imReadFile) fls) (const $ "No file found in " <> list (map ttext fls))+ TraceEvent e -> (rdr ^. ioMethods . imTraceEvent) e >>= runC+ CallLua c fname args -> (rdr ^. ioMethods . imCallLua) c fname args >>= \case+ Right x -> runC x+ Left rr -> thpe (string rr)+++interpretMonad :: (Functor m, Monad m)+ => InterpreterReader m+ -> InterpreterState+ -> InterpreterMonad a+ -> m (Either Doc a, InterpreterState, InterpreterWriter)+interpretMonad rd_ prmstate instr = case runState (viewT instr) prmstate of+ (!a,!nextstate) -> evalInstrGen rd_ nextstate a
Puppet/Interpreter/PrettyPrinter.hs view
@@ -1,4 +1,5 @@ {-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE GADTs #-} module Puppet.Interpreter.PrettyPrinter(containerComma) where import Puppet.PP@@ -15,7 +16,10 @@ import Control.Lens import Data.List import GHC.Exts+import qualified Data.ByteString.Lazy.Char8 as BSL +import Data.Aeson (ToJSON, encode)+ containerComma'' :: Pretty a => [(Doc, a)] -> Doc containerComma'' x = indent 2 ins where@@ -105,3 +109,40 @@ pretty (RAndSearch a b) = parens (pretty a) <+> "&&" <+> parens (pretty b) pretty (ROrSearch a b) = parens (pretty a) <+> "||" <+> parens (pretty b) pretty RAlwaysTrue = mempty++pf :: Doc -> [Doc] -> Doc+pf fn args = bold (red fn) <> tupled (map pretty args)++showQuery :: ToJSON a => Query a -> Doc+showQuery = string . BSL.unpack . encode++instance Pretty (InterpreterInstr a) where+ pretty GetNativeTypes = pf "GetNativeTypes" []+ pretty (GetStatement tlt nm) = pf "GetStatement" [pretty tlt,ttext nm]+ pretty (ComputeTemplate fn scp _) = pf "ComputeTemplate" [fn', ttext scp]+ where+ fn' = case fn of+ Left content -> pretty (PString content)+ Right filena -> ttext filena+ pretty (ExternalFunction fn args) = pf (ttext fn) (map pretty args)+ pretty (CallLua _ f args) = pf (ttext f) (map pretty args)+ pretty GetNodeName = pf "GetNodeName" []+ pretty (HieraQuery _ q _) = pf "HieraQuery" [ttext q]+ pretty GetCurrentCallStack = pf "GetCurrentCallStack" []+ pretty (ErrorThrow rr) = pf "ErrorThrow" [rr]+ pretty (ErrorCatch _ _) = pf "ErrorCatch" []+ pretty (WriterTell t) = pf "WriterTell" (map (pretty . view _2) t)+ pretty (WriterPass _) = pf "WriterPass" []+ pretty (WriterListen _) = pf "WriterListen" []+ pretty PDBInformation = pf "PDBInformation" []+ pretty (PDBReplaceCatalog _) = pf "PDBReplaceCatalog" ["..."]+ pretty (PDBReplaceFacts _) = pf "PDBReplaceFacts" ["..."]+ pretty (PDBDeactivateNode n) = pf "PDBDeactivateNode" [ttext n]+ pretty (PDBGetFacts q) = pf "PDBGetFacts" [showQuery q]+ pretty (PDBGetResources q) = pf "PDBGetResources" [showQuery q]+ pretty (PDBGetNodes q) = pf "PDBGetNodes" [showQuery q]+ pretty PDBCommitDB = pf "PDBCommitDB" []+ pretty (PDBGetResourcesOfNode n q) = pf "PDBGetResourcesOfNode" [ttext n, showQuery q]+ pretty (ReadFile f) = pf "ReadFile" (map ttext f)+ pretty (TraceEvent e) = pf "TraceEvent" [string e]+
Puppet/Interpreter/Resolve.hs view
@@ -32,6 +32,7 @@ import Puppet.Parser.Types import Puppet.Interpreter.PrettyPrinter() import Puppet.Parser.PrettyPrinter(showPos)+import Puppet.Interpreter.RubyRandom import Data.Version (parseVersion) import Text.ParserCombinators.ReadP (readP_to_S)@@ -43,28 +44,26 @@ import qualified Data.HashMap.Strict as HM import qualified Data.HashSet as HS import qualified Data.Text as T-import qualified Data.Text.IO as T import qualified Data.Text.Encoding as T import Data.Monoid import Control.Applicative hiding ((<$>))-import Control.Exception import Control.Monad import Control.Monad.Error import Data.Tuple.Strict as S import Control.Lens+import Data.Maybe (mapMaybe) import Data.Aeson.Lens hiding (key) import Data.Attoparsec.Number import qualified Data.Either.Strict as S import qualified Data.Maybe.Strict as S-import Text.Regex.PCRE.ByteString-import Puppet.Interpreter.RubyRandom import qualified Data.ByteString as BS import qualified Crypto.Hash.MD5 as MD5 import qualified Crypto.Hash.SHA1 as SHA1 import qualified Data.ByteString.Base16 as B16-import Text.Regex.PCRE.ByteString.Utils import Data.Bits import Control.Monad.Writer (tell)+import Control.Monad.Operational (singleton)+import Text.Regex.PCRE.ByteString.Utils -- | A useful type that is used when trying to perform arithmetic on Puppet -- numbers.@@ -74,9 +73,18 @@ -- messages to the main monad. runHiera :: T.Text -> HieraQueryType -> InterpreterMonad (S.Maybe PValue) runHiera q t = do- hquery <- view hieraQuery+ -- We need to merge the current scope with the top level scope scps <- use scopes- (w :!: o) <- interpreterIO (hquery scps q t)+ ctx <- getScopeName+ let getV scp = mapMaybe toStr $ HM.toList $ fmap (view (_1 . _1)) (scps ^. ix scp . scopeVariables)+ -- we can't use _PString, because of dependency cycles+ toStr (k,v) = case v of+ PString x -> Just (k,x)+ _ -> Nothing+ toplevels = map (_1 %~ ("::" <>)) $ getV "::"+ locals = getV ctx+ vars = HM.fromList (toplevels <> locals)+ (w :!: o) <- singleton (HieraQuery vars q t) tell w return o @@ -144,7 +152,7 @@ -- | A simple helper that checks if a given type is native or a define. isNativeType :: T.Text -> InterpreterMonad Bool-isNativeType t = has (ix t) `fmap` view nativeTypes+isNativeType t = has (ix t) `fmap` (singleton GetNativeTypes) -- | A pure function for resolving variables. getVariable :: Container ScopeInformation -- ^ The whole scope data.@@ -214,12 +222,12 @@ resolveExpression (MoreThan a b) = numberCompare a b (>) (>) resolveExpression (LessEqualThan a b) = numberCompare a b (<=) (<=) resolveExpression (MoreEqualThan a b) = numberCompare a b (>=) (>=)-resolveExpression (RegexMatch a (PValue ur@(URegexp _ rv))) = do+resolveExpression (RegexMatch a v@(PValue (URegexp _ rv))) = do ra <- fmap T.encodeUtf8 (resolveExpressionString a)- liftIO (execute rv ra) >>= \case- Left rr -> throwPosError ("Regexp matching critical failure" <+> text (show rr) <+> parens ("Regexp was" <+> pretty ur))- Right Nothing -> return (PBoolean False)- Right _ -> return (PBoolean True)+ case execute' rv ra of+ Left (_,rr) -> throwPosError ("Error when evaluating" <+> pretty v <+> ":" <+> string rr)+ Right Nothing -> return $ PBoolean False+ Right (Just _) -> return $ PBoolean True resolveExpression (RegexMatch _ t) = throwPosError ("The regexp matching operator expects a regular expression, not" <+> pretty t) resolveExpression (NotRegexMatch a v) = resolveExpression (Not (RegexMatch a v)) resolveExpression (Equal a b) = do@@ -262,12 +270,12 @@ rese <- resolveExpression e let checkCond [] = throwPosError ("The selector didn't match anything for input" <+> pretty rese </> pretty stmt) checkCond ((SelectorDefault :!: ce) : _) = resolveExpression ce- checkCond ((SelectorValue ur@(URegexp _ rg) :!: ce) : xs) = do+ checkCond ((SelectorValue v@(URegexp _ rg) :!: ce) : xs) = do rs <- fmap T.encodeUtf8 (resolvePValueString rese)- liftIO (execute rg rs) >>= \case- Left rr -> throwPosError ("Regexp matching critical failure" <+> text (show rr) <+> parens ("Regexp was" <+> pretty ur))- Right Nothing -> checkCond xs- Right _ -> resolveExpression ce+ case execute' rg rs of+ Left (_,rr) -> throwPosError ("Could not match" <+> pretty v <+> ":" <+> string rr)+ Right Nothing -> checkCond xs+ Right (Just _) -> resolveExpression ce checkCond ((SelectorValue uv :!: ce) : xs) = do rv <- resolveValue uv if puppetEquality rese rv@@ -392,25 +400,21 @@ target <- fmap T.encodeUtf8 (resolvePValueString ptarget) regexp <- fmap T.encodeUtf8 (resolvePValueString pregexp) replacement <- fmap T.encodeUtf8 (resolvePValueString preplacement)- liftIO (substituteCompile regexp target replacement) >>= \case- Left rr -> throwPosError ("regsubst" <> parens (pretty pregexp <> comma <> pretty preplacement) <> ":" <+> text rr)+ case substituteCompile' regexp target replacement of+ Left rr -> throwPosError ("regsubst():" <+> string rr) Right x -> fmap PString (safeDecodeUtf8 x) resolveFunction' "regsubst" _ = throwPosError "regsubst(): Expects 3 or 4 arguments" resolveFunction' "split" [psrc, psplt] = do src <- fmap T.encodeUtf8 (resolvePValueString psrc) splt <- fmap T.encodeUtf8 (resolvePValueString psplt)- liftIO (splitCompile splt src) >>= \case- Left rr -> throwPosError ("regsubst():" <+> text rr)- Right x -> fmap (PArray . V.fromList) $ mapM (fmap PString . safeDecodeUtf8) x+ case splitCompile' splt src of+ Left rr -> throwPosError ("splitCompile():" <+> string rr)+ Right x -> fmap (PArray . V.fromList) (mapM (fmap PString . safeDecodeUtf8) x) resolveFunction' "sha1" [pstr] = fmap (PString . T.decodeUtf8 . B16.encode . SHA1.hash . T.encodeUtf8) (resolvePValueString pstr) resolveFunction' "sha1" _ = throwPosError "sha1(): Expects a single argument" resolveFunction' "mysql_password" [pstr] = fmap (PString . T.decodeUtf8 . B16.encode . SHA1.hash . SHA1.hash . T.encodeUtf8) (resolvePValueString pstr) resolveFunction' "mysql_password" _ = throwPosError "mysql_password(): Expects a single argument"-resolveFunction' "file" args = mapM resolvePValueString args >>= fmap PString . interpreterIO . file- where- file :: [T.Text] -> IO (S.Either Doc T.Text)- file [] = return $ S.Left ("No file found in" <+> pretty args)- file (x:xs) = fmap S.Right (T.readFile (T.unpack x)) `catch` (\SomeException{} -> file xs)+resolveFunction' "file" args = mapM resolvePValueString args >>= fmap PString . singleton . ReadFile resolveFunction' "tagged" ptags = do tags <- fmap HS.fromList (mapM resolvePValueString ptags) scp <- getScopeName@@ -447,17 +451,12 @@ resolveFunction' "hiera" _ = throwPosError "hiera(): Expects one, two or three arguments" -- user functions-resolveFunction' fname args = do- external <- view externalFunctions- case external ^. at fname of- Just f -> f args- Nothing -> throwPosError ("Unknown function" <+> dullred (ttext fname))+resolveFunction' fname args = singleton (ExternalFunction fname args) pdbresourcequery :: PValue -> Maybe T.Text -> InterpreterMonad PValue pdbresourcequery q mkey = do- pdb <- view pdbAPI rrv <- case fromJSON (toJSON q) of- Success rq -> interpreterIO (getResources pdb rq)+ Success rq -> singleton (PDBGetResources rq) Error rr -> throwPosError ("Invalid resource query:" <+> Puppet.PP.string rr) rv <- case fromJSON (toJSON rrv) of Success x -> return x@@ -483,11 +482,7 @@ -- 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 cscps)- >>= \case- S.Left rr -> throwPosError ("template error for" <+> ttext fname <+> ":" <$> rr)- S.Right r -> return (PString r)+ PString `fmap` singleton (ComputeTemplate (templatetype fname) scp cscps) resolveExpressionSE :: Expression -> InterpreterMonad PValue resolveExpressionSE e = resolveExpression e >>=
Puppet/Interpreter/Types.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE DeriveGeneric, TemplateHaskell, CPP, ScopedTypeVariables, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, LambdaCase, FlexibleContexts #-}+{-# LANGUAGE GADTs #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Puppet.Interpreter.Types where @@ -15,9 +16,10 @@ import qualified Data.Text.Encoding as T import qualified Data.Vector as V import Data.Tuple.Strict-import Control.Monad.Trans.RSS.Strict-import Control.Monad.Writer hiding ((<>))+import Control.Monad.State.Strict import Control.Monad.Error+import Control.Monad.Writer.Class+import Data.Monoid hiding ((<>)) import Control.Lens import Data.Aeson.Lens import Data.String (IsString(..))@@ -26,7 +28,6 @@ import Data.Hashable import GHC.Generics hiding (to) import qualified Data.Traversable as TR-import Control.Exception import qualified Data.ByteString as BS import System.Log.Logger import Data.List (foldl')@@ -37,6 +38,10 @@ import Data.Attoparsec.Number import Data.Attoparsec.Text (parseOnly,rational) import Data.Scientific+import Control.Monad.Operational+import Control.Exception+import Control.Concurrent.MVar (MVar)+import qualified Scripting.Lua as Lua #ifdef HRUBY import Foreign.Ruby@@ -63,7 +68,10 @@ | 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)))+type HieraQueryFunc m = Container T.Text -- ^ All the variables that Hiera can interpolate, the top level ones being prefixed with ::+ -> T.Text -- ^ The query+ -> HieraQueryType+ -> m (S.Either Doc (Pair InterpreterWriter (S.Maybe PValue))) data RSearchExpression = REqualitySearch !T.Text !PValue@@ -143,15 +151,55 @@ , _resMod :: ![ResourceModifier] } -data InterpreterReader = InterpreterReader { _nativeTypes :: !(Container PuppetTypeMethods)- , _getStatement :: TopLevelType -> T.Text -> IO (S.Either Doc Statement)- , _computeTemplateFunction :: Either T.Text T.Text -> T.Text -> Container ScopeInformation -> IO (S.Either Doc T.Text)- , _pdbAPI :: PuppetDBAPI- , _externalFunctions :: Container ( [PValue] -> InterpreterMonad PValue )- , _thisNodename :: T.Text- , _hieraQuery :: HieraQueryFunc- }+data InterpreterReader m = InterpreterReader { _nativeTypes :: !(Container PuppetTypeMethods)+ , _getStatement :: TopLevelType -> T.Text -> m (S.Either Doc Statement)+ , _computeTemplateFunction :: Either T.Text T.Text -> T.Text -> Container ScopeInformation -> m (S.Either Doc T.Text)+ , _pdbAPI :: PuppetDBAPI m+ , _externalFunctions :: Container ( [PValue] -> InterpreterMonad PValue )+ , _thisNodename :: T.Text+ , _hieraQuery :: HieraQueryFunc m+ , _ioMethods :: ImpureMethods m+ } +data ImpureMethods m = ImpureMethods { _imGetCurrentCallStack :: m [String]+ , _imReadFile :: [T.Text] -> m (Either String T.Text)+ , _imTraceEvent :: String -> m ()+ , _imCallLua :: MVar Lua.LuaState -> T.Text -> [PValue] -> m (Either String PValue)+ }++data InterpreterInstr a where+ -- Utility for using what's in "InterpreterReader"+ GetNativeTypes :: InterpreterInstr (Container PuppetTypeMethods)+ GetStatement :: TopLevelType -> T.Text -> InterpreterInstr Statement+ ComputeTemplate :: Either T.Text T.Text -> T.Text -> Container ScopeInformation -> InterpreterInstr T.Text+ ExternalFunction :: T.Text -> [PValue] -> InterpreterInstr PValue+ GetNodeName :: InterpreterInstr T.Text+ HieraQuery :: Container T.Text -> T.Text -> HieraQueryType -> InterpreterInstr (Pair InterpreterWriter (S.Maybe PValue))+ GetCurrentCallStack :: InterpreterInstr [String]+ -- error+ ErrorThrow :: Doc -> InterpreterInstr a+ ErrorCatch :: InterpreterMonad a -> (Doc -> InterpreterMonad a) -> InterpreterInstr a+ -- writer+ WriterTell :: InterpreterWriter -> InterpreterInstr ()+ WriterPass :: InterpreterMonad (a, InterpreterWriter -> InterpreterWriter) -> InterpreterInstr a+ WriterListen :: InterpreterMonad a -> InterpreterInstr (a, InterpreterWriter)+ -- puppetdb wrappers, see 'PuppetDBAPI' for details+ PDBInformation :: InterpreterInstr Doc+ PDBReplaceCatalog :: WireCatalog -> InterpreterInstr ()+ PDBReplaceFacts :: [(Nodename, Facts)] -> InterpreterInstr ()+ PDBDeactivateNode :: Nodename -> InterpreterInstr ()+ PDBGetFacts :: Query FactField -> InterpreterInstr [PFactInfo]+ PDBGetResources :: Query ResourceField -> InterpreterInstr [Resource]+ PDBGetNodes :: Query NodeField -> InterpreterInstr [PNodeInfo]+ PDBCommitDB :: InterpreterInstr ()+ PDBGetResourcesOfNode :: Nodename -> Query ResourceField -> InterpreterInstr [Resource]+ -- Reading the first file that can be read in a list+ ReadFile :: [T.Text] -> InterpreterInstr T.Text+ -- Tracing events+ TraceEvent :: String -> InterpreterInstr ()+ -- Calling Lua+ CallLua :: MVar Lua.LuaState -> T.Text -> [PValue] -> InterpreterInstr PValue+ newtype Warning = Warning Doc type InterpreterLog = Pair Priority Doc@@ -166,8 +214,18 @@ logWriter :: (Monad m, MonadWriter InterpreterWriter m) => Priority -> Doc -> m () logWriter prio d = tell [prio :!: d] -type InterpreterMonad = ErrorT Doc (RSST InterpreterReader InterpreterWriter InterpreterState IO)+-- | The main monad+type InterpreterMonad = ProgramT InterpreterInstr (State InterpreterState) +instance MonadError Doc InterpreterMonad where+ throwError = singleton . ErrorThrow+ catchError a c = singleton (ErrorCatch a c)++instance MonadWriter InterpreterWriter InterpreterMonad where+ tell = singleton . WriterTell+ pass = singleton . WriterPass+ listen = singleton . WriterListen+ instance Error Doc where noMsg = empty strMsg = text@@ -266,16 +324,16 @@ , _pnodeinfoReportT :: !(S.Maybe UTCTime) } -data PuppetDBAPI = PuppetDBAPI { pdbInformation :: IO Doc- , replaceCatalog :: WireCatalog -> IO (S.Either Doc ()) -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/commands.html#replace-catalog-version-3>- , replaceFacts :: [(Nodename, Facts)] -> IO (S.Either Doc ()) -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/commands.html#replace-facts-version-1>- , deactivateNode :: Nodename -> IO (S.Either Doc ()) -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/commands.html#deactivate-node-version-1>- , getFacts :: Query FactField -> IO (S.Either Doc [PFactInfo]) -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/query/v3/facts.html#get-v3facts>- , getResources :: Query ResourceField -> IO (S.Either Doc [Resource]) -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/query/v3/resources.html#get-v3resources>- , getNodes :: Query NodeField -> IO (S.Either Doc [PNodeInfo])- , commitDB :: IO (S.Either Doc ()) -- ^ This is only here to tell the test PuppetDB to save its content to disk.- , getResourcesOfNode :: Nodename -> Query ResourceField -> IO (S.Either Doc [Resource])- }+data PuppetDBAPI m = PuppetDBAPI { pdbInformation :: m Doc+ , replaceCatalog :: WireCatalog -> m (S.Either Doc ()) -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/commands.html#replace-catalog-version-3>+ , replaceFacts :: [(Nodename, Facts)] -> m (S.Either Doc ()) -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/commands.html#replace-facts-version-1>+ , deactivateNode :: Nodename -> m (S.Either Doc ()) -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/commands.html#deactivate-node-version-1>+ , getFacts :: Query FactField -> m (S.Either Doc [PFactInfo]) -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/query/v3/facts.html#get-v3facts>+ , getResources :: Query ResourceField -> m (S.Either Doc [Resource]) -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/query/v3/resources.html#get-v3resources>+ , getNodes :: Query NodeField -> m (S.Either Doc [PNodeInfo])+ , commitDB :: m (S.Either Doc ()) -- ^ This is only here to tell the test PuppetDB to save its content to disk.+ , getResourcesOfNode :: Nodename -> Query ResourceField -> m (S.Either Doc [Resource])+ } -- | Pretty straightforward way to define the various PuppetDB queries data Query a = QEqual a T.Text@@ -316,6 +374,7 @@ makeClassy ''Resource makeClassy ''InterpreterState makeClassy ''InterpreterReader+makeClassy ''ImpureMethods makeClassy ''CurContainer makeFields ''WireCatalog makeFields ''PFactInfo@@ -324,15 +383,27 @@ rcurcontainer :: Resource -> CurContainerDesc rcurcontainer r = fromMaybe ContRoot (r ^? rscope . _head) -throwPosError :: Doc -> InterpreterMonad a-throwPosError s = do+class MonadThrowPos m where+ throwPosError :: Doc -> m a++class MonadStack m where+ getCallStack :: m [String]++instance MonadStack InterpreterMonad where+ getCallStack = singleton GetCurrentCallStack++tpe :: (MonadStack m, MonadError Doc m, MonadState InterpreterState m) => Doc -> m b+tpe s = do p <- use (curPos . _1)- stack <- liftIO currentCallStack+ stack <- getCallStack let dstack = if null stack then mempty else mempty </> string (renderStack stack) throwError (s <+> "at" <+> showPos p <> dstack) +instance MonadThrowPos InterpreterMonad where+ throwPosError = tpe+ getCurContainer :: InterpreterMonad CurContainer {-# INLINE getCurContainer #-} getCurContainer = do@@ -385,19 +456,23 @@ Error _ -> return Nothing 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+interpreterIO :: (MonadThrowPos m, MonadIO m) => IO (S.Either Doc a) -> m a {-# INLINE interpreterIO #-} interpreterIO f = do liftIO (eitherDocIO f) >>= \case S.Right x -> return x S.Left rr -> throwPosError rr++mightFail :: (MonadError Doc m, MonadThrowPos m) => m (S.Either Doc a) -> m a+mightFail a = a >>= \case+ S.Right x -> return x+ S.Left rr -> throwPosError rr safeDecodeUtf8 :: BS.ByteString -> InterpreterMonad T.Text {-# INLINE safeDecodeUtf8 #-}
Puppet/Lens.hs view
@@ -44,7 +44,6 @@ import qualified Data.HashMap.Strict as HM import qualified Data.Text as T import Data.Tuple.Strict hiding (uncurry)-import System.IO.Unsafe import Data.Bits import Text.Parser.Combinators (eof) @@ -124,12 +123,10 @@ toU (PArray r) = UArray (fmap (PValue . toU) r) toU (PHash h) = UHash (V.fromList $ map (\(k,v) -> (PValue (UString k) :!: PValue (toU v))) $ HM.toList h) --- | Warning, this uses 'unsafePerformIO' to parse (parsing Regexps--- requires IO). _PParse :: Prism' T.Text (V.Vector Statement) _PParse = prism dspl prs where- prs i = case unsafePerformIO (runMyParser (puppetParser <* eof) "dummy" i) of+ prs i = case runMyParser (puppetParser <* eof) "dummy" i of Left _ -> Left i Right x -> Right x dspl = T.pack . displayNocolor . ppStatements
Puppet/Manifests.hs view
@@ -5,7 +5,7 @@ import Puppet.Parser.Types import Puppet.Interpreter.Types -import Text.Regex.PCRE.ByteString+import Text.Regex.PCRE.ByteString.Utils import Control.Lens import Control.Applicative import Control.Monad.Error@@ -30,7 +30,7 @@ checkRegexp :: [Pair Regex Statement] -> ErrorT Doc IO (Maybe Statement) checkRegexp [] = return Nothing checkRegexp ((regexp :!: s):xs) = do- liftIO (execute regexp bsnodename) >>= \case+ case execute' regexp bsnodename of Left rr -> throwError ("Regexp match error:" <+> text (show rr)) Right Nothing -> checkRegexp xs Right (Just _) -> return (Just s)
Puppet/NativeTypes.hs view
@@ -15,6 +15,7 @@ import Puppet.Interpreter.Types import qualified Data.HashMap.Strict as HM import Control.Lens+import Control.Monad.Operational fakeTypes :: [(PuppetTypeName, PuppetTypeMethods)] fakeTypes = map faketype ["class"]@@ -41,7 +42,7 @@ -- pass validateNativeType :: Resource -> InterpreterMonad Resource validateNativeType r = do- tps <- view nativeTypes+ tps <- singleton GetNativeTypes case tps ^. at (r ^. rid . itype) of Just x -> case (x ^. puppetValidate) r of Right nr -> return nr
Puppet/Parser.hs view
@@ -1,13 +1,16 @@-{-# LANGUAGE LambdaCase, GeneralizedNewtypeDeriving, StandaloneDeriving,-FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE FlexibleContexts #-} module Puppet.Parser (puppetParser,expression,runMyParser) where import qualified Data.Text as T+import qualified Data.Text.Encoding as T import qualified Data.Vector as V import qualified Data.HashSet as HS import qualified Data.Maybe.Strict as S import Data.Tuple.Strict hiding (fst,zip)-import Text.Regex.PCRE.String+import Text.Regex.PCRE.ByteString.Utils import Data.Char import Control.Monad@@ -38,15 +41,15 @@ deriving instance (Monad m, CharParsing m) => CharParsing (ParserT m) deriving instance (Monad m, LookAheadParsing m) => LookAheadParsing (ParserT m) -type Parser = ParserT (PP.ParsecT T.Text () IO)+type Parser = ParserT (PP.ParsecT T.Text () Identity) getPosition :: Parser SourcePos getPosition = ParserT PP.getPosition -runMyParser :: Parser a -> SourceName -> T.Text -> IO (Either ParseError a)-runMyParser (ParserT p) = PP.runPT p ()+runMyParser :: Parser a -> SourceName -> T.Text -> Either ParseError a+runMyParser (ParserT p) = PP.runP p () -type OP = PP.ParsecT T.Text () IO+type OP = PP.ParsecT T.Text () Identity instance (CharParsing m, Monad m) => TokenParsing (ParserT m) where someSpace = skipMany (simpleSpace <|> oneLineComment <|> multiLineComment)@@ -259,7 +262,7 @@ <|> fmap (PValue . UString) literalValue compileRegexp :: T.Text -> Parser Regex-compileRegexp p = (liftIO . compile compBlank execBlank . T.unpack) p >>= \case+compileRegexp p = case compile' compBlank execBlank (T.encodeUtf8 p) of Right r -> return r Left ms -> fail ("Can't parse regexp /" ++ T.unpack p ++ "/ : " ++ show ms) @@ -291,7 +294,7 @@ cases <- braces (cas `sepEndBy1` comma) return (ConditionalValue selectedExpression (V.fromList cases)) -expressionTable :: [[Operator T.Text () IO Expression]]+expressionTable :: [[Operator T.Text () Identity Expression]] expressionTable = [ -- [ Infix ( operator "?" >> return ConditionalValue ) AssocLeft ] [ Prefix ( operator' "-" >> return Negate ) ] , [ Prefix ( operator' "!" >> return Not ) ]
Puppet/Plugins.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE FlexibleContexts #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-| This module is used for user plugins. It exports three functions that should@@ -38,6 +39,8 @@ import qualified Data.Vector as V import Control.Monad.IO.Class import Control.Concurrent+import Control.Monad.Error+import Control.Monad.Operational (singleton) import Puppet.Interpreter.Types import Puppet.Utils@@ -93,7 +96,7 @@ {-| Runs a puppet function in the 'CatalogMonad' monad. It takes a state, function name and list of arguments. It returns a valid Puppet value. -}-puppetFunc :: Lua.LuaState -> T.Text -> [PValue] -> InterpreterMonad PValue+puppetFunc :: (MonadThrowPos m, MonadIO m, MonadError Doc m, Monad m) => Lua.LuaState -> T.Text -> [PValue] -> m PValue puppetFunc l fn args = liftIO ( catch (fmap Right (Lua.callfunc l (T.unpack fn) args)) (\e -> return $ Left $ show (e :: SomeException)) ) >>= \case Right x -> return x@@ -114,12 +117,14 @@ initLuaMaster moduledir = do (luastate, luafunctions) <- initLua moduledir c <- newMVar luastate- let callf fname args = do+ let callf fname args = singleton (CallLua c fname args)+ {- r <- liftIO $ withMVar c $ \stt -> catch (fmap Right (Lua.callfunc stt (T.unpack fname) args)) (\e -> return $ Left $ show (e :: SomeException)) case r of Right x -> return x Left rr -> throwPosError (string rr)+ -} return $ HM.fromList [(fname, callf fname) | fname <- luafunctions] -- | Obviously releases the Lua state.
Puppet/Preferences.hs view
@@ -1,4 +1,7 @@ {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-} module Puppet.Preferences where import Puppet.Utils@@ -13,11 +16,11 @@ import qualified Data.HashMap.Strict as HM import Control.Lens -data Preferences = Preferences+data Preferences m = Preferences { _manifestPath :: FilePath -- ^ The path to the manifests. , _modulesPath :: FilePath -- ^ The path to the modules. , _templatesPath :: FilePath -- ^ The path to the template.- , _prefPDB :: PuppetDBAPI+ , _prefPDB :: PuppetDBAPI m , _natTypes :: Container PuppetTypeMethods -- ^ The list of native types. , _prefExtFuncs :: Container ( [PValue] -> InterpreterMonad PValue ) , _hieraPath :: Maybe FilePath@@ -26,7 +29,7 @@ makeClassy ''Preferences genPreferences :: FilePath- -> IO Preferences+ -> IO (Preferences IO) genPreferences basedir = do let manifestdir = basedir <> "/manifests" modulesdir = basedir <> "/modules"
Puppet/Stdlib.hs view
@@ -2,7 +2,6 @@ module Puppet.Stdlib (stdlibFunctions) where import Puppet.PP-import Puppet.Parser.Types import Puppet.Interpreter.Resolve import Puppet.Interpreter.Types @@ -12,8 +11,7 @@ import Data.Char import Data.Monoid import Control.Monad-import Control.Monad.IO.Class-import Text.Regex.PCRE.ByteString+import Text.Regex.PCRE.ByteString.Utils import qualified Data.Vector as V import qualified Data.HashMap.Strict as HM import qualified Data.Text as T@@ -74,13 +72,17 @@ stringArrayFunction _ [a] = throwPosError ("function expects a string or an array of strings, not" <+> pretty a) stringArrayFunction _ _ = throwPosError "function expects a single argument" - compileRE :: T.Text -> InterpreterMonad Regex-compileRE p =- (liftIO . compile compBlank execBlank . T.encodeUtf8) p >>= \case- Right r -> return r- Left ms -> throwPosError ("Can't parse regexp" <+> pretty (URegexp p undefined) <+> ":" <+> text (show ms))+compileRE r = case compile' compBlank execBlank (T.encodeUtf8 r) of+ Left rr -> throwPosError ("Could not compile" <+> ttext r <+> ":" <+> string (show rr))+ Right x -> return x +matchRE :: Regex -> T.Text -> InterpreterMonad Bool+matchRE r t = case execute' r (T.encodeUtf8 t) of+ Left rr -> throwPosError ("Could not match:" <+> string (show rr))+ Right Nothing -> return False+ Right (Just _) -> return True+ puppetAbs :: PValue -> InterpreterMonad PValue puppetAbs y = case y ^? _Number of Just x -> return $ _Number # abs x@@ -261,13 +263,8 @@ validateRe [str, reg] = validateRe [str, reg, PString "Match failed"] validateRe [str, PString reg, msg] = validateRe [str, PArray (V.singleton (PString reg)), msg] validateRe [str, PArray v, msg] = do- rstr <- fmap T.encodeUtf8 (resolvePValueString str)- let matchRE :: Regex -> InterpreterMonad Bool- matchRE r = liftIO (execute r rstr) >>= \case- Left rr -> throwPosError ("Regexp matching critical failure" <+> text (show rr))- Right Nothing -> return False- _ -> return True- rest <- mapM (resolvePValueString >=> compileRE >=> matchRE) (V.toList v)+ rstr <- resolvePValueString str+ rest <- mapM (resolvePValueString >=> compileRE >=> flip matchRE rstr) (V.toList v) if or rest then return PUndef else throwPosError (pretty msg <$> "Source string:" <+> pretty str <> comma <+> "regexps:" <+> pretty (V.toList v))
Puppet/Testing.hs view
@@ -4,6 +4,7 @@ , module Data.Monoid , module Puppet.PP , module Puppet.Interpreter.Types+ , module Puppet.Lens , H.hspec , basicTest , testingDaemon@@ -12,6 +13,14 @@ , describeCatalog , it , shouldBe+ , PSpec+ , PSpecM+ , lCatalog+ , lModuledir+ , lPuppetdir+ , withResource+ , withParameter+ , withFileContent ) where import Prelude hiding (notElem,all)@@ -21,7 +30,7 @@ import Data.Monoid import Control.Monad.Error import Control.Monad.Reader-import Control.Applicative hiding ((<$>))+import Control.Applicative import System.Posix.Files import qualified Data.Either.Strict as S import qualified Data.Text as T@@ -34,14 +43,16 @@ import PuppetDB.Common import Puppet.Preferences-import Puppet.PP+import Puppet.PP hiding ((<$>)) import Puppet.Daemon+import Puppet.Lens import Puppet.Interpreter.Types import Puppet.Interpreter.PrettyPrinter () -data TestEnv = TestEnv { _catalog :: FinalCatalog- , _moduledir :: FilePath- , _puppetdir :: FilePath+-- | The state of the reader monad the tests run in+data TestEnv = TestEnv { _lCatalog :: FinalCatalog+ , _lModuledir :: FilePath+ , _lPuppetdir :: FilePath } makeClassy ''TestEnv @@ -64,6 +75,7 @@ describeCatalog :: Nodename -> FilePath -> FinalCatalog -> PSpec -> H.Spec describeCatalog nd pdir catlg test = H.describe (T.unpack nd) $ runReaderT test (TestEnv catlg (pdir <> "/modules") pdir) +-- | This tests that file sources are valid. basicTest :: PSpec basicTest = hTestFileSources @@ -73,6 +85,41 @@ shouldBe :: (Show a, Eq a) => a -> a -> PSpecM H.Expectation shouldBe a b = return (a `H.shouldBe` b) +-- | Run tests on a specific resource+withResource :: String -- ^ The test description (the thing that goes after should)+ -> T.Text -- ^ Resource type+ -> T.Text -- ^ Resource name+ -> (Resource -> H.Expectation) -- ^ Testing function+ -> PSpec+withResource desc t n o = do+ let ridentifier = RIdentifier t n+ mr <- view (lCatalog . at ridentifier)+ lift $ case mr of+ Nothing -> H.it ("Should have resource " ++ show (pretty ridentifier)) (H.expectationFailure "Resource not found")+ Just v -> H.it ("Resource " ++ show (pretty ridentifier) ++ " should " ++ desc) (o v)++-- | Tests a specific parameter+withParameter :: T.Text -- ^ The parameter name+ -> Resource -- ^ The resource to test+ -> (PValue -> H.Expectation) -- ^ Testing function+ -> H.Expectation+withParameter prm r o = do+ case r ^. rattributes . at prm of+ Nothing -> H.expectationFailure ("Parameter " ++ T.unpack prm ++ " not found")+ Just v -> o v++-- | Retrieves a given file content, and runs a test on it. It works on the+-- explicit "content" parameter, or can resolve the "source" parameter to+-- open the file.+withFileContent :: String -- ^ Test description (the thing that goes after should)+ -> T.Text -- ^ The file path+ -> (T.Text -> H.Expectation) -- ^ Testing function+ -> PSpec+withFileContent desc fn action = withResource desc "file" fn $ \r ->+ case r ^? rattributes . ix "content" . _PString of+ Just v -> action v+ Nothing -> H.expectationFailure "Contentnot found"+ hTestFileSources :: PSpec hTestFileSources = do let getFiles = filter presentFile . toList@@ -81,8 +128,8 @@ | r ^. rattributes . at "source" == Just PUndef = False | otherwise = True getSource = mapMaybe (\r -> (,) `fmap` pure r <*> r ^. rattributes . at "source")- files <- fmap (getSource . getFiles) $ view catalog- pdir <- view puppetdir+ files <- fmap (getSource . getFiles) $ view lCatalog+ pdir <- view lPuppetdir forM_ files $ \(r,filesource) -> it ("should have a source for " ++ r ^. rid . iname . to T.unpack) $ do let testFile :: FilePath -> ErrorT Doc IO ()@@ -107,7 +154,7 @@ -- | Initializes a daemon made for running tests, using the specific test -- puppetDB-testingDaemon :: PuppetDBAPI -- ^ Contains the puppetdb API functions+testingDaemon :: PuppetDBAPI IO -- ^ 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, [Resource])))
PuppetDB/Common.hs view
@@ -38,7 +38,7 @@ tsts = stripPrefix "test" r -- | Given a 'PDBType', will try return a sane default implementation.-getDefaultDB :: PDBType -> IO (S.Either Doc PuppetDBAPI)+getDefaultDB :: PDBType -> IO (S.Either Doc (PuppetDBAPI IO)) getDefaultDB PDBDummy = return (S.Right dummyPuppetDB) getDefaultDB PDBRemote = pdbConnect "http://localhost:8080" getDefaultDB PDBTest = lookupEnv "HOME" >>= \case
PuppetDB/Dummy.hs view
@@ -5,7 +5,7 @@ import Puppet.Interpreter.Types import qualified Data.Either.Strict as S -dummyPuppetDB :: PuppetDBAPI+dummyPuppetDB :: Monad m => PuppetDBAPI m dummyPuppetDB = PuppetDBAPI (return "dummy") (const (return (S.Right () )))
PuppetDB/Remote.hs view
@@ -44,7 +44,7 @@ runRequest req -- | Given an URL (ie. @http://localhost:8080@), will return an incomplete 'PuppetDBAPI'.-pdbConnect :: T.Text -> IO (S.Either Doc PuppetDBAPI)+pdbConnect :: T.Text -> IO (S.Either Doc (PuppetDBAPI IO)) pdbConnect url = return $ S.Right $ PuppetDBAPI (return (ttext url)) (const (return (S.Left "operation not supported")))
PuppetDB/TestDB.hs view
@@ -45,7 +45,7 @@ toJSON (DBContent r f _) = object [("resources", toJSON r), ("facts", toJSON f)] -- | Initializes the test DB using a file to back its content-loadTestDB :: FilePath -> IO (S.Either Doc PuppetDBAPI)+loadTestDB :: FilePath -> IO (S.Either Doc (PuppetDBAPI IO)) loadTestDB fp = decodeFileEither fp >>= \case Left (OtherParseException rr) -> return (S.Left (string (show rr)))@@ -61,13 +61,13 @@ newFile = S.Right <$> genDBAPI (newDB & backingFile ?~ fp ) -- | Starts a new PuppetDB, without any backing file.-initTestDB :: IO PuppetDBAPI+initTestDB :: IO (PuppetDBAPI IO) initTestDB = genDBAPI newDB newDB :: DBContent newDB = DBContent mempty mempty Nothing -genDBAPI :: DBContent -> IO PuppetDBAPI+genDBAPI :: DBContent -> IO (PuppetDBAPI IO) genDBAPI db = do d <- newTVarIO db return (PuppetDBAPI (dbapiInfo d)
language-puppet.cabal view
@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: language-puppet-version: 0.12.2+version: 0.12.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/@@ -54,6 +54,7 @@ , Erb.Ruby , Erb.Evaluate , Puppet.Lens+ , Puppet.Interpreter.IO other-modules: Puppet.Utils , Puppet.NativeTypes.File , Erb.Compute@@ -100,7 +101,7 @@ , time == 1.4.* , filecache >= 0.2.5 && < 0.3 , regex-pcre-builtin >= 0.94.4- , pcre-utils >= 0.1.2 && < 0.2+ , pcre-utils >= 0.1.3 && < 0.2 , process >= 1.1 && < 1.3 , iconv == 0.4.* , http-types == 0.8.*@@ -116,6 +117,7 @@ , stateWriter >= 0.2.1 && < 0.3 , split == 0.2.* , scientific == 0.2.*+ , operational Test-Suite test-lexer hs-source-dirs: tests
progs/PuppetResources.hs view
@@ -143,8 +143,7 @@ import PuppetDB.Dummy import PuppetDB.TestDB import PuppetDB.Common-import Puppet.Testing hiding ((<$>))-import Puppet.Lens+import Puppet.Testing import Puppet.Stats tshow :: Show a => a -> T.Text@@ -161,7 +160,7 @@ hackish as it will generate facts from the local computer ! -} -initializedaemonWithPuppet :: LOG.Priority -> PuppetDBAPI -> FilePath -> Maybe FilePath -> (Facts -> Facts) -> IO (QueryFunc, MStats, MStats, MStats)+initializedaemonWithPuppet :: LOG.Priority -> PuppetDBAPI IO -> FilePath -> Maybe FilePath -> (Facts -> Facts) -> IO (QueryFunc, MStats, MStats, MStats) initializedaemonWithPuppet prio pdbapi puppetdir hierapath overrideFacts = do LOG.updateGlobalLogger "Puppet.Daemon" (LOG.setLevel prio) q <- fmap ((prefPDB .~ pdbapi) . (hieraPath .~ hierapath)) (genPreferences puppetdir) >>= initDaemon@@ -170,7 +169,7 @@ return (f, _dParserStats q, _dCatalogStats q, _dTemplateStats q) parseFile :: FilePath -> IO (Either P.ParseError (V.Vector Statement))-parseFile fp = T.readFile fp >>= runMyParser puppetParser fp+parseFile fp = fmap (runMyParser puppetParser fp) (T.readFile fp) printContent :: T.Text -> FinalCatalog -> IO () printContent filename catalog =@@ -417,7 +416,7 @@ when docommit $ void $ commitDB pdbapi exit -computeCatalogs :: Bool -> QueryFunc -> PuppetDBAPI -> (Doc -> IO ()) -> CommandLine -> T.Text -> IO (Maybe (FinalCatalog, [Resource]), Maybe H.Summary)+computeCatalogs :: Bool -> QueryFunc -> PuppetDBAPI IO -> (Doc -> IO ()) -> CommandLine -> T.Text -> IO (Maybe (FinalCatalog, [Resource]), Maybe H.Summary) computeCatalogs testOnly queryfunc pdbapi printFunc (CommandLine _ showjson showcontent mrt mrn puppetdir _ _ _ _ _ _ _ checkExported) tnodename = queryfunc tnodename >>= \case S.Left rr -> do if testOnly