Skip to content

Commit bbe2f64

Browse files
bartavellebartavelle
committed
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.
1 parent 9ccc41d commit bbe2f64

File tree

10 files changed

+253
-86
lines changed

10 files changed

+253
-86
lines changed

‎Puppet/Daemon.hs

+2-1
Original file line numberDiff line numberDiff line change
@@ -9,6 +9,7 @@ import Puppet.Interpreter.Types
99
import Puppet.Parser.Types
1010
import Puppet.Manifests
1111
import Puppet.Interpreter
12+
import Puppet.Interpreter.IO
1213
import Puppet.Plugins
1314
import Hiera.Server
1415
import Erb.Compute
@@ -111,7 +112,7 @@ gCatalog :: Preferences
111112
gCatalog prefs getStatements getTemplate stats hquery ndename facts = do
112113
logDebug ("Received query for node " <> ndename)
113114
traceEventIO ("START gCatalog " <> T.unpack ndename)
114-
(stmts :!: warnings) <- measure stats ndename $ getCatalog getStatements getTemplate (prefs ^. prefPDB) ndename facts (prefs ^. natTypes) (prefs ^. prefExtFuncs) hquery
115+
(stmts :!: warnings) <- measure stats ndename $ getCatalog interpretIO getStatements getTemplate (prefs ^. prefPDB) ndename facts (prefs ^. natTypes) (prefs ^. prefExtFuncs) hquery
115116
mapM_ (\(p :!: m) -> LOG.logM loggerName p (displayS (renderCompact (ttext ndename <> ":" <+> m)) "")) warnings
116117
traceEventIO ("STOP gCatalog " <> T.unpack ndename)
117118
return stmts

‎Puppet/Interpreter.hs

+16-23
Original file line numberDiff line numberDiff line change
@@ -28,7 +28,7 @@ import qualified Data.Graph as G
2828
import qualified Data.Tree as T
2929
import Data.Foldable (toList,foldl',Foldable,foldlM)
3030
import Data.Traversable (mapM,forM)
31-
import Debug.Trace (traceEventIO)
31+
import Control.Monad.Operational
3232

3333
-- helpers
3434
vmapM :: (Monad m, Foldable t) => (a -> m b) -> t a -> m [b]
@@ -40,25 +40,27 @@ vmapM f = mapM f . toList
4040
-- (this last one might not be up to date and is only useful for code
4141
-- coverage tests)) along with all messages that have been generated by the
4242
-- compilation process.
43-
getCatalog :: ( TopLevelType -> T.Text -> IO (S.Either Doc Statement) ) -- ^ get statements function
43+
getCatalog :: Monad m
44+
=> (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')
45+
-> ( TopLevelType -> T.Text -> IO (S.Either Doc Statement) ) -- ^ get statements function
4446
-> (Either T.Text T.Text -> T.Text -> Container ScopeInformation -> IO (S.Either Doc T.Text)) -- ^ compute template function
4547
-> PuppetDBAPI
4648
-> T.Text -- ^ Node name
4749
-> Facts -- ^ Facts ...
4850
-> Container PuppetTypeMethods -- ^ List of native types
4951
-> Container ( [PValue] -> InterpreterMonad PValue )
5052
-> HieraQueryFunc -- ^ Hiera query function
51-
-> IO (Pair (S.Either Doc (FinalCatalog, EdgeMap, FinalCatalog, [Resource])) [Pair Priority Doc])
52-
getCatalog gtStatement gtTemplate pdbQuery ndename facts nTypes extfuncs hquery = do
53-
nameThread ("Catalog " <> T.unpack ndename)
53+
-> m (Pair (S.Either Doc (FinalCatalog, EdgeMap, FinalCatalog, [Resource])) [Pair Priority Doc])
54+
getCatalog convertMonad gtStatement gtTemplate pdbQuery ndename facts nTypes extfuncs hquery = do
55+
-- nameThread ("Catalog " <> T.unpack ndename)
5456
let rdr = InterpreterReader nTypes gtStatement gtTemplate pdbQuery extfuncs ndename hquery
5557
dummypos = initialPPos "dummy"
5658
initialclass = mempty & at "::" ?~ (IncludeStandard :!: dummypos)
5759
stt = InterpreterState baseVars initialclass mempty [ContRoot] dummypos mempty [] []
5860
factvars = facts & each %~ (\x -> PString x :!: initialPPos "facts" :!: ContRoot)
5961
callervars = ifromList [("caller_module_name", PString "::" :!: dummypos :!: ContRoot), ("module_name", PString "::" :!: dummypos :!: ContRoot)]
6062
baseVars = isingleton "::" (ScopeInformation (factvars <> callervars) mempty mempty (CurContainer ContRoot mempty) mempty S.Nothing)
61-
(output, _, warnings) <- runRSST (runErrorT (computeCatalog ndename)) rdr stt
63+
(output, _, warnings) <- runRSST (runErrorT (convertMonad rdr (computeCatalog ndename))) rdr stt
6264
return (strictifyEither output :!: warnings)
6365

6466
isParent :: T.Text -> CurContainerDesc -> InterpreterMonad Bool
@@ -146,12 +148,7 @@ getstt topleveltype toplevelname = do
146148
-- check if this is a known class (spurious or inner class)
147149
use (nestedDeclarations . at (topleveltype, toplevelname)) >>= \case
148150
Just x -> return ([], x) -- it is known !
149-
Nothing -> do
150-
-- load the file
151-
getStmtfunc <- view getStatement
152-
liftIO (getStmtfunc topleveltype toplevelname) >>= \case
153-
S.Right x -> evalTopLevel x
154-
S.Left y -> throwPosError y
151+
Nothing -> singleton (GetStatement topleveltype toplevelname) >>= evalTopLevel
155152

156153
computeCatalog :: T.Text -> InterpreterMonad (FinalCatalog, EdgeMap, FinalCatalog, [Resource])
157154
computeCatalog ndename = do
@@ -342,13 +339,12 @@ evaluateStatement r@(ResourceCollection e resType searchExp mods p) = do
342339
if et == RealizeCollected
343340
then do
344341
let q = searchExpressionToPuppetDB resType rsearch
345-
pdb <- view pdbAPI
346-
fqdn <- view thisNodename
342+
fqdn <- singleton GetNodeName
347343
-- we must filter the resources that originated from this host
348344
-- here ! They are also turned into "normal" resources
349345
res <- ( map (rvirtuality .~ Normal)
350346
. filter ((/= fqdn) . _rnode)
351-
) `fmap` interpreterIO (getResources pdb q)
347+
) `fmap` singleton (PDBGetResources q)
352348
scpdesc <- ContImported `fmap` getScope
353349
void $ enterScope SENormal scpdesc "importing" p
354350
pushScope scpdesc
@@ -581,8 +577,8 @@ loadClass :: T.Text
581577
-> InterpreterMonad [Resource]
582578
loadClass rclassname loadedfrom params cincludetype = do
583579
let classname = dropInitialColons rclassname
584-
ndn <- view thisNodename
585-
liftIO (traceEventIO ('[' : T.unpack ndn ++ "] loadClass " ++ T.unpack classname))
580+
ndn <- singleton GetNodeName
581+
singleton (TraceEvent ('[' : T.unpack ndn ++ "] loadClass " ++ T.unpack classname))
586582
p <- use curPos
587583
-- check if the class has already been loaded
588584
-- http://docs.puppetlabs.com/puppet/3/reference/lang_classes.html#using-resource-like-declarations
@@ -618,7 +614,7 @@ loadClass rclassname loadedfrom params cincludetype = do
618614
classresource <- if cincludetype == IncludeStandard
619615
then do
620616
scp <- use curScope
621-
fqdn <- view thisNodename
617+
fqdn <- singleton GetNodeName
622618
return [Resource (RIdentifier "class" classname) (HS.singleton classname) mempty mempty scp Normal mempty p fqdn]
623619
else return []
624620
pushScope scopedesc
@@ -690,7 +686,7 @@ registerResource rt rn arg vrt p = do
690686
getClassTags (ContImported _ ) = []
691687
getClassTags (ContImport _ _ ) = []
692688
allScope <- use curScope
693-
fqdn <- view thisNodename
689+
fqdn <- singleton GetNodeName
694690
let baseresource = Resource (RIdentifier rt rn) (HS.singleton rn) mempty mempty allScope vrt defaulttags p fqdn
695691
r <- foldM (addAttribute CantOverride) baseresource (itoList arg)
696692
let resid = RIdentifier rt rn
@@ -770,10 +766,7 @@ mainFunctionCall "hiera_include" _ = throwPosError "hiera_include(): This functi
770766
mainFunctionCall fname args = do
771767
p <- use curPos
772768
let representation = MainFunctionCall fname mempty p
773-
external <- view externalFunctions
774-
rs <- case external ^. at fname of
775-
Just f -> f args
776-
Nothing -> throwPosError ("Unknown function:" <+> pretty representation)
769+
rs <- singleton (ExternalFunction fname args)
777770
unless (rs == PUndef) $ throwPosError ("This function call should return" <+> pretty PUndef <+> "and not" <+> pretty rs <$> pretty representation)
778771
return []
779772
-- Method stuff

‎Puppet/Interpreter/IO.hs

+106
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,106 @@
1+
{-# LANGUAGE GADTs #-}
2+
{-# LANGUAGE LambdaCase #-}
3+
{-# LANGUAGE FlexibleContexts #-}
4+
{-# LANGUAGE FlexibleInstances #-}
5+
module Puppet.Interpreter.IO where
6+
7+
import Puppet.PP
8+
import Puppet.Interpreter.Types
9+
import Puppet.Plugins()
10+
11+
import Control.Monad.Operational
12+
import Control.Monad.Error
13+
import Control.Monad.RSS.Strict
14+
import Control.Monad.State.Strict
15+
import Control.Lens
16+
import Control.Exception
17+
import Control.Concurrent.MVar
18+
19+
import qualified Data.Text as T
20+
import qualified Data.Text.IO as T
21+
import qualified Data.ByteString as BS
22+
import qualified Scripting.Lua as Lua
23+
24+
import qualified Data.Either.Strict as S
25+
import Data.Maybe (isJust)
26+
import GHC.Stack
27+
import Debug.Trace (traceEventIO)
28+
import Text.Regex.PCRE.ByteString
29+
import Text.Regex.PCRE.ByteString.Utils
30+
31+
canfailIO :: IO (S.Either Doc a) -> ErrorT Doc (RSST InterpreterReader InterpreterWriter InterpreterState IO) a
32+
canfailIO m = liftIO (eitherDocIO m) >>= \case
33+
S.Right x -> return x
34+
S.Left y -> throwPosError y
35+
36+
bs :: BS.ByteString -> Doc
37+
bs = string . show
38+
39+
interpretIO :: InterpreterReader
40+
-> InterpreterMonad a
41+
-> RSMIO a
42+
interpretIO rdr = intexpr . viewT
43+
where
44+
pdb = _pdbAPI rdr
45+
runC :: RSMIO b -> (b -> InterpreterMonad a) -> RSMIO a
46+
runC c f = do
47+
o <- c
48+
interpretIO rdr (f o)
49+
intexpr :: State InterpreterState (ProgramViewT InterpreterInstr (State InterpreterState) a) -> RSMIO a
50+
intexpr computation = do
51+
initstate <- get
52+
case runState computation initstate of
53+
(!a,!nextstate) -> put nextstate >> evalInstr a
54+
evalInstr :: ProgramViewT InterpreterInstr (State InterpreterState) a -> RSMIO a
55+
evalInstr (Return x) = return x
56+
evalInstr (WriterTell t :>>= f) = tell t >> runC (return ()) f
57+
evalInstr (WriterPass m :>>= f) = runC (pass (interpretIO rdr m)) f
58+
evalInstr (WriterListen m :>>= f) = runC (listen (interpretIO rdr m)) f
59+
evalInstr (GetNativeTypes :>>= f) = interpretIO rdr (f (rdr ^. nativeTypes))
60+
evalInstr (ExternalFunction fname args :>>= f) = case rdr ^. externalFunctions . at fname of
61+
Just fn -> interpretIO rdr ( fn args >>= f)
62+
Nothing -> throwPosError ("Unknown function: " <> ttext fname)
63+
evalInstr (ErrorThrow d :>>= _) = throwError d
64+
evalInstr (ErrorCatch m h :>>= f) = runC (catchError (interpretIO rdr m) (interpretIO rdr . h)) f
65+
evalInstr (GetNodeName :>>= f) = interpretIO rdr (f (rdr ^. thisNodename))
66+
67+
evalInstr (GetStatement topleveltype toplevelname :>>= f) = runC (canfailIO ((rdr ^. getStatement) topleveltype toplevelname)) f
68+
evalInstr (ComputeTemplate fn scp cscps :>>= f) = runC (canfailIO ((rdr ^. computeTemplateFunction) fn scp cscps)) f
69+
evalInstr (HieraQuery scps q t :>>= f) = runC (canfailIO ((rdr ^. hieraQuery) scps q t)) f
70+
evalInstr (GetCurrentCallStack :>>= f) = runC (liftIO currentCallStack) f
71+
evalInstr (ReadFile fls :>>= f) = runC (canfailIO (file fls)) f
72+
where
73+
file :: [T.Text] -> IO (S.Either Doc T.Text)
74+
file [] = return $ S.Left ("No file found in" <+> list (map ttext fls))
75+
file (x:xs) = fmap S.Right (T.readFile (T.unpack x)) `catch` (\SomeException{} -> file xs)
76+
evalInstr (TraceEvent e :>>= f) = runC (liftIO (traceEventIO e)) f
77+
evalInstr (PDBInformation :>>= f) = runC (liftIO (pdbInformation pdb)) f
78+
evalInstr (PDBReplaceCatalog w :>>= f) = runC (canfailIO (replaceCatalog pdb w)) f
79+
evalInstr (PDBReplaceFacts fcts :>>= f) = runC (canfailIO (replaceFacts pdb fcts)) f
80+
evalInstr (PDBDeactivateNode nn :>>= f) = runC (canfailIO (deactivateNode pdb nn)) f
81+
evalInstr (PDBGetFacts q :>>= f) = runC (canfailIO (getFacts pdb q)) f
82+
evalInstr (PDBGetResources q :>>= f) = runC (canfailIO (getResources pdb q)) f
83+
evalInstr (PDBGetNodes q :>>= f) = runC (canfailIO (getNodes pdb q)) f
84+
evalInstr (PDBCommitDB :>>= f) = runC (canfailIO (commitDB pdb)) f
85+
evalInstr (PDBGetResourcesOfNode nn q :>>= f) = runC (canfailIO (getResourcesOfNode pdb nn q)) f
86+
evalInstr (SubstituteCompile regexp target replacement :>>= f) = liftIO (substituteCompile regexp target replacement) >>= \case
87+
Left rr -> throwPosError ("regsubst" <> parens (bs regexp <> comma <> bs replacement) <> ":" <+> string rr)
88+
Right x -> interpretIO rdr (f x)
89+
evalInstr (SplitCompile splt src :>>= f) = liftIO (splitCompile splt src) >>= \case
90+
Left rr -> throwPosError ("split" <> parens (bs splt <> comma <> bs src) <> ":" <+> string rr)
91+
Right x -> interpretIO rdr (f x)
92+
evalInstr (Compile c e r :>>= f) = liftIO (compile c e r) >>= \case
93+
Left rr -> throwPosError ("compile" <> parens (bs r) <> ":" <+> string (show rr))
94+
Right x -> interpretIO rdr (f x)
95+
evalInstr (Execute rv va :>>= f) = liftIO (execute rv va) >>= \case
96+
Left rr -> throwPosError ("execute" <> parens ("/regexp/" <> comma <> bs va) <> ":" <+> string (show rr))
97+
Right x -> interpretIO rdr $ f (isJust x )
98+
evalInstr (CallLua c fname args :>>= f) = runC runlua f
99+
where
100+
runlua = do
101+
r <- liftIO $ withMVar c $ \stt ->
102+
catch (fmap Right (Lua.callfunc stt (T.unpack fname) args)) (\e -> return $ Left $ show (e :: SomeException))
103+
case r of
104+
Right x -> return x
105+
Left rr -> throwPosError (string rr)
106+

0 commit comments

Comments
 (0)