Permalink
Browse files

Turn the InterpreterMonad into a Program

This patch modifies the main interpreter monad so that it becomes a
Program (from the operational package). All IO operations are now
handled at the same place, in the Puppet.Interpreter.IO module.
  • Loading branch information...
1 parent 9ccc41d commit bbe2f64879d502f77146dc9216e29b6925da9718 @bartavelle committed Feb 26, 2014
View
@@ -9,6 +9,7 @@ import Puppet.Interpreter.Types
import Puppet.Parser.Types
import Puppet.Manifests
import Puppet.Interpreter
+import Puppet.Interpreter.IO
import Puppet.Plugins
import Hiera.Server
import Erb.Compute
@@ -111,7 +112,7 @@ gCatalog :: Preferences
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 interpretIO getStatements getTemplate (prefs ^. prefPDB) ndename facts (prefs ^. natTypes) (prefs ^. prefExtFuncs) hquery
mapM_ (\(p :!: m) -> LOG.logM loggerName p (displayS (renderCompact (ttext ndename <> ":" <+> m)) "")) warnings
traceEventIO ("STOP gCatalog " <> T.unpack ndename)
return stmts
View
@@ -28,7 +28,7 @@ import qualified Data.Graph as G
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 +40,27 @@ vmapM f = mapM f . toList
-- (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
+getCatalog :: Monad m
+ => (InterpreterReader -> InterpreterMonad (FinalCatalog, EdgeMap, FinalCatalog, [Resource]) -> RSM m (FinalCatalog, EdgeMap, FinalCatalog, [Resource])) -- ^ A function that will interpret the InterpreterMonad and will convert it to something else (for example, 'interpretIO')
+ -> ( 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
-> 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)
+ -> m (Pair (S.Either Doc (FinalCatalog, EdgeMap, FinalCatalog, [Resource])) [Pair Priority Doc])
+getCatalog convertMonad gtStatement gtTemplate pdbQuery ndename facts nTypes extfuncs hquery = do
+ -- nameThread ("Catalog " <> T.unpack ndename)
let rdr = InterpreterReader nTypes gtStatement gtTemplate pdbQuery extfuncs ndename hquery
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) <- runRSST (runErrorT (convertMonad rdr (computeCatalog ndename))) rdr stt
@HeinrichApfelmus
HeinrichApfelmus Feb 28, 2014

The RSMIO monad can be avoided entirely by providing an interpretIO function that is essentially a fusion of runRSST with the old interpretIO function, along the lines of

interpretIO' :: ProgramT ... -> Reader -> State -> IO (Output, Warnings)
interpretIO' m rdr stt = runRSST (runErrorT (interpretIOOld rdr m)) rdr stt

(The idea is to now inline the right-hand side of this specification.)

return (strictifyEither output :!: warnings)
isParent :: T.Text -> CurContainerDesc -> InterpreterMonad Bool
@@ -146,12 +148,7 @@ getstt topleveltype toplevelname = do
-- 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 @@ evaluateStatement r@(ResourceCollection e resType searchExp mods p) = do
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
@@ -581,8 +577,8 @@ loadClass :: T.Text
-> 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 +614,7 @@ loadClass rclassname loadedfrom params cincludetype = do
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 +686,7 @@ registerResource rt rn arg vrt p = do
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 +766,7 @@ mainFunctionCall "hiera_include" _ = throwPosError "hiera_include(): This functi
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
@@ -0,0 +1,106 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+module Puppet.Interpreter.IO where
+
+import Puppet.PP
+import Puppet.Interpreter.Types
+import Puppet.Plugins()
+
+import Control.Monad.Operational
+import Control.Monad.Error
+import Control.Monad.RSS.Strict
+import Control.Monad.State.Strict
+import Control.Lens
+import Control.Exception
+import Control.Concurrent.MVar
+
+import qualified Data.Text as T
+import qualified Data.Text.IO as T
+import qualified Data.ByteString as BS
+import qualified Scripting.Lua as Lua
+
+import qualified Data.Either.Strict as S
+import Data.Maybe (isJust)
+import GHC.Stack
+import Debug.Trace (traceEventIO)
+import Text.Regex.PCRE.ByteString
+import Text.Regex.PCRE.ByteString.Utils
+
+canfailIO :: IO (S.Either Doc a) -> ErrorT Doc (RSST InterpreterReader InterpreterWriter InterpreterState IO) a
+canfailIO m = liftIO (eitherDocIO m) >>= \case
+ S.Right x -> return x
+ S.Left y -> throwPosError y
+
+bs :: BS.ByteString -> Doc
+bs = string . show
+
+interpretIO :: InterpreterReader
+ -> InterpreterMonad a
+ -> RSMIO a
+interpretIO rdr = intexpr . viewT
+ where
+ pdb = _pdbAPI rdr
+ runC :: RSMIO b -> (b -> InterpreterMonad a) -> RSMIO a
+ runC c f = do
+ o <- c
+ interpretIO rdr (f o)
+ intexpr :: State InterpreterState (ProgramViewT InterpreterInstr (State InterpreterState) a) -> RSMIO a
+ intexpr computation = do
+ initstate <- get
+ case runState computation initstate of
+ (!a,!nextstate) -> put nextstate >> evalInstr a
+ evalInstr :: ProgramViewT InterpreterInstr (State InterpreterState) a -> RSMIO a
+ evalInstr (Return x) = return x
+ evalInstr (WriterTell t :>>= f) = tell t >> runC (return ()) f
+ evalInstr (WriterPass m :>>= f) = runC (pass (interpretIO rdr m)) f
+ evalInstr (WriterListen m :>>= f) = runC (listen (interpretIO rdr m)) f
+ evalInstr (GetNativeTypes :>>= f) = interpretIO rdr (f (rdr ^. nativeTypes))
+ evalInstr (ExternalFunction fname args :>>= f) = case rdr ^. externalFunctions . at fname of
+ Just fn -> interpretIO rdr ( fn args >>= f)
+ Nothing -> throwPosError ("Unknown function: " <> ttext fname)
+ evalInstr (ErrorThrow d :>>= _) = throwError d
+ evalInstr (ErrorCatch m h :>>= f) = runC (catchError (interpretIO rdr m) (interpretIO rdr . h)) f
+ evalInstr (GetNodeName :>>= f) = interpretIO rdr (f (rdr ^. thisNodename))
+
+ evalInstr (GetStatement topleveltype toplevelname :>>= f) = runC (canfailIO ((rdr ^. getStatement) topleveltype toplevelname)) f
+ evalInstr (ComputeTemplate fn scp cscps :>>= f) = runC (canfailIO ((rdr ^. computeTemplateFunction) fn scp cscps)) f
+ evalInstr (HieraQuery scps q t :>>= f) = runC (canfailIO ((rdr ^. hieraQuery) scps q t)) f
+ evalInstr (GetCurrentCallStack :>>= f) = runC (liftIO currentCallStack) f
+ evalInstr (ReadFile fls :>>= f) = runC (canfailIO (file fls)) f
+ where
+ file :: [T.Text] -> IO (S.Either Doc T.Text)
+ file [] = return $ S.Left ("No file found in" <+> list (map ttext fls))
+ file (x:xs) = fmap S.Right (T.readFile (T.unpack x)) `catch` (\SomeException{} -> file xs)
+ evalInstr (TraceEvent e :>>= f) = runC (liftIO (traceEventIO e)) f
+ evalInstr (PDBInformation :>>= f) = runC (liftIO (pdbInformation pdb)) f
+ evalInstr (PDBReplaceCatalog w :>>= f) = runC (canfailIO (replaceCatalog pdb w)) f
+ evalInstr (PDBReplaceFacts fcts :>>= f) = runC (canfailIO (replaceFacts pdb fcts)) f
+ evalInstr (PDBDeactivateNode nn :>>= f) = runC (canfailIO (deactivateNode pdb nn)) f
+ evalInstr (PDBGetFacts q :>>= f) = runC (canfailIO (getFacts pdb q)) f
+ evalInstr (PDBGetResources q :>>= f) = runC (canfailIO (getResources pdb q)) f
+ evalInstr (PDBGetNodes q :>>= f) = runC (canfailIO (getNodes pdb q)) f
+ evalInstr (PDBCommitDB :>>= f) = runC (canfailIO (commitDB pdb)) f
+ evalInstr (PDBGetResourcesOfNode nn q :>>= f) = runC (canfailIO (getResourcesOfNode pdb nn q)) f
+ evalInstr (SubstituteCompile regexp target replacement :>>= f) = liftIO (substituteCompile regexp target replacement) >>= \case
+ Left rr -> throwPosError ("regsubst" <> parens (bs regexp <> comma <> bs replacement) <> ":" <+> string rr)
+ Right x -> interpretIO rdr (f x)
+ evalInstr (SplitCompile splt src :>>= f) = liftIO (splitCompile splt src) >>= \case
+ Left rr -> throwPosError ("split" <> parens (bs splt <> comma <> bs src) <> ":" <+> string rr)
+ Right x -> interpretIO rdr (f x)
+ evalInstr (Compile c e r :>>= f) = liftIO (compile c e r) >>= \case
+ Left rr -> throwPosError ("compile" <> parens (bs r) <> ":" <+> string (show rr))
+ Right x -> interpretIO rdr (f x)
+ evalInstr (Execute rv va :>>= f) = liftIO (execute rv va) >>= \case
+ Left rr -> throwPosError ("execute" <> parens ("/regexp/" <> comma <> bs va) <> ":" <+> string (show rr))
+ Right x -> interpretIO rdr $ f (isJust x )
+ evalInstr (CallLua c fname args :>>= f) = runC runlua f
+ where
+ runlua = do
+ 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)
+
Oops, something went wrong.

0 comments on commit bbe2f64

Please sign in to comment.