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.

Author: bartavelle

Puppet/Daemon.hs

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

Puppet/Interpreter.hs

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

Puppet/Interpreter/IO.hs

@@ -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)
+