diff --git a/Erb/Compute.hs b/Erb/Compute.hs --- a/Erb/Compute.hs +++ b/Erb/Compute.hs @@ -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 diff --git a/Facter.hs b/Facter.hs --- a/Facter.hs +++ b/Facter.hs @@ -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)) diff --git a/Hiera/Server.hs b/Hiera/Server.hs --- a/Hiera/Server.hs +++ b/Hiera/Server.hs @@ -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) diff --git a/Puppet/Daemon.hs b/Puppet/Daemon.hs --- a/Puppet/Daemon.hs +++ b/Puppet/Daemon.hs @@ -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) diff --git a/Puppet/Interpreter.hs b/Puppet/Interpreter.hs --- a/Puppet/Interpreter.hs +++ b/Puppet/Interpreter.hs @@ -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 diff --git a/Puppet/Interpreter/IO.hs b/Puppet/Interpreter/IO.hs new file mode 100644 --- /dev/null +++ b/Puppet/Interpreter/IO.hs @@ -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 diff --git a/Puppet/Interpreter/PrettyPrinter.hs b/Puppet/Interpreter/PrettyPrinter.hs --- a/Puppet/Interpreter/PrettyPrinter.hs +++ b/Puppet/Interpreter/PrettyPrinter.hs @@ -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] + diff --git a/Puppet/Interpreter/Resolve.hs b/Puppet/Interpreter/Resolve.hs --- a/Puppet/Interpreter/Resolve.hs +++ b/Puppet/Interpreter/Resolve.hs @@ -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 >>= diff --git a/Puppet/Interpreter/Types.hs b/Puppet/Interpreter/Types.hs --- a/Puppet/Interpreter/Types.hs +++ b/Puppet/Interpreter/Types.hs @@ -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 ()) -- ^ - , replaceFacts :: [(Nodename, Facts)] -> IO (S.Either Doc ()) -- ^ - , deactivateNode :: Nodename -> IO (S.Either Doc ()) -- ^ - , getFacts :: Query FactField -> IO (S.Either Doc [PFactInfo]) -- ^ - , getResources :: Query ResourceField -> IO (S.Either Doc [Resource]) -- ^ - , 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 ()) -- ^ + , replaceFacts :: [(Nodename, Facts)] -> m (S.Either Doc ()) -- ^ + , deactivateNode :: Nodename -> m (S.Either Doc ()) -- ^ + , getFacts :: Query FactField -> m (S.Either Doc [PFactInfo]) -- ^ + , getResources :: Query ResourceField -> m (S.Either Doc [Resource]) -- ^ + , 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 #-} diff --git a/Puppet/Lens.hs b/Puppet/Lens.hs --- a/Puppet/Lens.hs +++ b/Puppet/Lens.hs @@ -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 diff --git a/Puppet/Manifests.hs b/Puppet/Manifests.hs --- a/Puppet/Manifests.hs +++ b/Puppet/Manifests.hs @@ -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) diff --git a/Puppet/NativeTypes.hs b/Puppet/NativeTypes.hs --- a/Puppet/NativeTypes.hs +++ b/Puppet/NativeTypes.hs @@ -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 diff --git a/Puppet/Parser.hs b/Puppet/Parser.hs --- a/Puppet/Parser.hs +++ b/Puppet/Parser.hs @@ -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 ) ] diff --git a/Puppet/Plugins.hs b/Puppet/Plugins.hs --- a/Puppet/Plugins.hs +++ b/Puppet/Plugins.hs @@ -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. diff --git a/Puppet/Preferences.hs b/Puppet/Preferences.hs --- a/Puppet/Preferences.hs +++ b/Puppet/Preferences.hs @@ -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" diff --git a/Puppet/Stdlib.hs b/Puppet/Stdlib.hs --- a/Puppet/Stdlib.hs +++ b/Puppet/Stdlib.hs @@ -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)) diff --git a/Puppet/Testing.hs b/Puppet/Testing.hs --- a/Puppet/Testing.hs +++ b/Puppet/Testing.hs @@ -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]))) diff --git a/PuppetDB/Common.hs b/PuppetDB/Common.hs --- a/PuppetDB/Common.hs +++ b/PuppetDB/Common.hs @@ -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 diff --git a/PuppetDB/Dummy.hs b/PuppetDB/Dummy.hs --- a/PuppetDB/Dummy.hs +++ b/PuppetDB/Dummy.hs @@ -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 () ))) diff --git a/PuppetDB/Remote.hs b/PuppetDB/Remote.hs --- a/PuppetDB/Remote.hs +++ b/PuppetDB/Remote.hs @@ -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"))) diff --git a/PuppetDB/TestDB.hs b/PuppetDB/TestDB.hs --- a/PuppetDB/TestDB.hs +++ b/PuppetDB/TestDB.hs @@ -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) diff --git a/language-puppet.cabal b/language-puppet.cabal --- a/language-puppet.cabal +++ b/language-puppet.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: language-puppet -version: 0.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 diff --git a/progs/PuppetResources.hs b/progs/PuppetResources.hs --- a/progs/PuppetResources.hs +++ b/progs/PuppetResources.hs @@ -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