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...
bartavelle committed Feb 26, 2014
1 parent 9ccc41d commit bbe2f64879d502f77146dc9216e29b6925da9718
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

This comment has been minimized.

Show comment
Hide comment
@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.)

@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
View
@@ -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.