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 -> PrettyError
bs = PrettyError . 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 PrettyError 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 . getError
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 (PrettyError ("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 $ PrettyError ("No file found in " <> list (map ttext fls)))
TraceEvent e -> (rdr ^. ioMethods . imTraceEvent) e >>= runC
IsIgnoredModule m -> runC (rdr ^. ignoredModules . contains m)
CallLua c fname args -> (rdr ^. ioMethods . imCallLua) c fname args >>= \case
Right x -> runC x
Left rr -> thpe (PrettyError (string rr))
interpretMonad :: (Functor m, Monad m)
=> InterpreterReader m
-> InterpreterState
-> InterpreterMonad a
-> m (Either PrettyError a, InterpreterState, InterpreterWriter)
interpretMonad rd_ prmstate instr = case runState (viewT instr) prmstate of
(!a,!nextstate) -> evalInstrGen rd_ nextstate a