IO.hs

{-# LANGUAGE GADTs #-}

-- | This is an internal module.
module Puppet.Interpreter.IO
  ( interpretMonad,
  )
where

import Control.Monad.Operational
import Control.Monad.State.Strict
import qualified Data.Either.Strict as S
import qualified Data.Text as Text
import Hiera.Server
import Puppet.Interpreter.PrettyPrinter ()
import Puppet.Interpreter.Types
import PuppetDB
import XPrelude

-- | The operational interpreter function
interpretMonad ::
  (Monad m) =>
  InterpreterReader m ->
  InterpreterState ->
  InterpreterMonad a ->
  m (Either PrettyError a, InterpreterState, InterpreterWriter)
interpretMonad r s0 instr =
  let (!p, !s1) = runState (viewT instr) s0
   in eval r s1 p

-- The internal (not exposed) eval function
eval ::
  (Monad m) =>
  InterpreterReader m ->
  InterpreterState ->
  ProgramViewT InterpreterInstr (State InterpreterState) a ->
  m (Either PrettyError a, InterpreterState, InterpreterWriter)
eval _ s (Return x) = return (Right x, s, mempty)
eval r s (a :>>= k) =
  let runInstr = interpretMonad r s . k -- run one instruction
      thpe = interpretMonad r s . throwPosError . getError
      pdb = r ^. readerPdbApi
      strFail iof errf =
        iof >>= \case
          Left rr -> thpe (errf (ppstring rr))
          Right x -> runInstr x
      canFail iof =
        iof >>= \case
          S.Left err -> thpe err
          S.Right x -> runInstr x
      canFailX iof =
        runExceptT iof >>= \case
          Left err -> thpe err
          Right x -> runInstr x
      logStuff x c = (_3 %~ (x <>)) <$> c
   in case a of
        IsStrict -> runInstr (r ^. readerIsStrict)
        ExternalFunction "Sensitive" [arg] -> interpretMonad r s (k (PSensitive arg))
        ExternalFunction name args ->
          -- #271: namespace is currently ignored when looking up puppetlabs functions
          let (nsp, name') = Text.breakOnEnd "::" name
           in case r ^. readerExternalFunc . at name' of
                Just fn -> interpretMonad r s (fn args >>= k)
                Nothing -> thpe (PrettyError ("Unknown function: (" <> ppline nsp <> ")" <> ppline name'))
        GetStatement toptype topname -> canFail ((r ^. readerGetStatement) toptype topname)
        ComputeTemplate src st -> canFail ((r ^. readerGetTemplate) src st r)
        WriterTell t -> logStuff t (runInstr ())
        WriterPass _ -> thpe "WriterPass"
        WriterListen _ -> thpe "WriterListen"
        PuppetPaths -> runInstr (r ^. readerPuppetPaths)
        Facts -> runInstr (r ^. readerFacts)
        RebaseFile -> runInstr (r ^. readerRebaseFile)
        GetNativeTypes -> runInstr (r ^. readerNativeTypes)
        ErrorThrow d -> return (Left d, s, mempty)
        GetNodeName -> runInstr (r ^. readerNodename)
        HieraQuery scps q t ->
          runExceptT (queryHiera (r ^. readerHieraQuery) scps q t) >>= either thpe runInstr
        PDBInformation -> pdbInformation pdb >>= runInstr
        PDBReplaceCatalog w -> canFailX (replaceCatalog pdb w)
        PDBReplaceFacts fcts -> canFailX (replaceFacts pdb fcts)
        PDBDeactivateNode nn -> canFailX (deactivateNode pdb nn)
        PDBGetFacts q -> canFailX (getPDBFacts pdb q)
        PDBGetResources q -> canFailX (getResources pdb q)
        PDBGetNodes q -> canFailX (getNodes pdb q)
        PDBCommitDB -> canFailX (commitDB pdb)
        PDBGetResourcesOfNode nn q -> canFailX (getResourcesOfNode pdb nn q)
        GetCurrentCallStack -> (r ^. readerIoMethods . ioGetCurrentCallStack) >>= runInstr
        ReadFile fls -> strFail ((r ^. readerIoMethods . ioReadFile) fls) (const $ PrettyError ("No file found in " <> list (map ppline fls)))
        TraceEvent e -> (r ^. readerIoMethods . ioTraceEvent) e >>= runInstr
        IsIgnoredModule m -> runInstr (r ^. readerIgnoredModules . contains m)
        IsExternalModule m -> runInstr (r ^. readerExternalModules . contains m)
        -- on error, the program state is RESET and the logged messages are dropped
        ErrorCatch atry ahandle -> do
          (eres, s', w) <- interpretMonad r s atry
          case eres of
            Left rr -> interpretMonad r s (ahandle rr >>= k)
            Right x -> logStuff w (interpretMonad r s' (k x))

-- query all hiera layers
queryHiera ::
  (Monad m) =>
  HieraQueryLayers m ->
  Container PValue ->
  Text ->
  HieraQueryType ->
  ExceptT PrettyError m (Maybe PValue)
queryHiera layers scps q t = do
  eglobal <- (layers ^. globalLayer) scps q t
  eenvironment <- (layers ^. environmentLayer) scps q t
  let modname =
        case Text.splitOn "::" (Text.dropWhile (== ':') q) of
          [] -> Nothing
          [_] -> Nothing
          (m : _) -> Just m
      layer = modname >>= (\n -> layers ^. moduleLayer . at n)
  emodle <- maybe (pure Nothing) (\hq -> hq scps q t) layer
  case catMaybes [eglobal, eenvironment, emodle] of
    [] -> pure Nothing
    x : xs -> Just <$> foldM (mergeWith t) x xs