Types.hs

{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}

module Puppet.Interpreter.Types
  ( -- * Operational state
    InterpreterState (InterpreterState),
    scopes,
    definedResources,
    nestedDeclarations,
    resModifiers,
    extraRelations,
    curScope,
    curPos,
    loadedClasses,

    -- * Operational reader
    InterpreterReader (InterpreterReader),
    readerNativeTypes,
    readerGetStatement,
    readerGetTemplate,
    readerPdbApi,
    readerExternalFunc,
    readerNodename,
    readerHieraQuery,
    readerIoMethods,
    readerIgnoredModules,
    readerExternalModules,
    readerIsStrict,
    readerPuppetPaths,
    readerFacts,
    readerRebaseFile,

    -- * Interpreter monad
    InterpreterMonad,
    InterpreterWriter,
    InterpreterInstr (..),
    Strictness (..),

    -- * Io methods
    IoMethods (IoMethods),
    ioGetCurrentCallStack,
    ioReadFile,
    ioTraceEvent,
    MonadThrowPos (..),

    -- * Resource modifier
    ResourceModifier (ResourceModifier),
    rmResType,
    rmDeclaration,
    rmSearch,
    rmType,
    rmMutation,
    rmModifierType,
    ModifierType (..),
    OverrideType (..),
    ResourceCollectorType (..),
    ClassIncludeType (..),
    RSearchExpression (..),

    -- * Scope information
    ScopeInformation (ScopeInformation),
    scopeResDefaults,
    scopeVariables,
    scopeParent,
    scopeOverrides,
    scopeContainer,
    scopeExtraTags,
    CurContainer (CurContainer),
    cctype,
    cctags,

    -- * Resource default
    ResDefaults (ResDefaults),
    resDefValues,
    resDefSrcScope,
    resDefPos,
    resDefType,
    ResRefOverride (..),
    ScopeEnteringContext (..),
    TopLevelType (..),

    -- * Hiera
    HieraQueryLayers (..),
    globalLayer,
    environmentLayer,
    moduleLayer,

    -- * Template
    TemplateSource (..),

    -- * Re-export
    module Puppet.Language,
  )
where

import qualified Control.Monad.Fail as Fail
import Control.Monad.Operational
import Control.Monad.State.Strict
import Control.Monad.Writer.Class
import Data.Aeson as A
import qualified Data.Either.Strict as S
import qualified Data.HashMap.Strict as HM
import qualified Data.List as List
import qualified Data.Maybe.Strict as S
import Facter
import qualified GHC.Show
import qualified GHC.Stack
import Hiera.Server
import Puppet.Language
import Puppet.Parser.Types
import PuppetDB
import qualified System.Log.Logger as Log
import XPrelude.Extra
import XPrelude.PP

-- | The intepreter can run in two modes : a strict mode (recommended), and
-- a permissive mode.
data Strictness
  = Strict
  | Permissive
  deriving (Show, Eq)

instance FromJSON Strictness where
  parseJSON (Bool True) = pure Strict
  parseJSON (Bool False) = pure Permissive
  parseJSON _ = mzero

data RSearchExpression
  = REqualitySearch !Text !PValue
  | RNonEqualitySearch !Text !PValue
  | RAndSearch !RSearchExpression !RSearchExpression
  | ROrSearch !RSearchExpression !RSearchExpression
  | RAlwaysTrue
  deriving (Show, Eq)

-- | Puppet has two main ways to declare classes: include-like and resource-like.
--
-- See <https://docs.puppetlabs.com/puppet/latest/reference/lang_classes.html#include-like-vs-resource-like puppet reference>.
data ClassIncludeType
  = -- | Using the include or contain function
    ClassIncludeLike
  | -- | Resource like declaration
    ClassResourceLike
  deriving (Eq)

-- | Differentiate the distinct top level types such as node, define or class.
data TopLevelType
  = -- | For node entries
    TopNode
  | -- | For defines
    TopDefine
  | -- | For classes
    TopClass
  deriving (Generic, Eq)

instance Hashable TopLevelType

-- | From the evaluation of Resource Default Declaration.
data ResDefaults = ResDefaults
  { _resDefType :: !Text,
    _resDefSrcScope :: !Text,
    _resDefValues :: !(Container PValue),
    _resDefPos :: !PPosition
  }

-- | From the evaluation of Resource Override Declaration.
data ResRefOverride = ResRefOverride
  { _rrid :: !RIdentifier,
    _rrparams :: !(Container PValue),
    _rrpos :: !PPosition
  }
  deriving (Eq)

data ScopeEnteringContext
  = SENormal
  | -- | We enter the scope as the child of another class
    SEChild !Text
  | -- | We enter the scope as the parent of another class
    SEParent !Text

-- | The type of the container together with its tags.
data CurContainer = CurContainer
  { _cctype :: !CurContainerDesc,
    _cctags :: !(HashSet Text)
  }
  deriving (Eq)

data ScopeInformation = ScopeInformation
  { _scopeVariables :: !(Container (Pair (Pair PValue PPosition) CurContainerDesc)),
    _scopeResDefaults :: !(Container ResDefaults),
    _scopeExtraTags :: !(HashSet Text),
    _scopeContainer :: !CurContainer,
    _scopeOverrides :: !(HashMap RIdentifier ResRefOverride),
    _scopeParent :: !(S.Maybe Text)
  }

data InterpreterState = InterpreterState
  { _scopes :: !(Container ScopeInformation),
    _loadedClasses :: !(Container (Pair ClassIncludeType PPosition)),
    _definedResources :: !(HM.HashMap RIdentifier Resource),
    _curScope :: ![CurContainerDesc],
    _curPos :: !PPosition,
    _nestedDeclarations :: !(HashMap (TopLevelType, Text) Statement),
    _extraRelations :: ![LinkInformation],
    _resModifiers :: ![ResourceModifier]
  }

data IoMethods m = IoMethods
  { _ioGetCurrentCallStack :: m [String],
    _ioReadFile :: [Text] -> m (Either String Text),
    _ioTraceEvent :: String -> m ()
  }

-- | All available queries including the global and module layer
-- The environment layer is not implemented.
--
-- The datatype belongs to the "Puppet.Interpreter" module because it serves to implement how Hiera is used within Puppet.
data HieraQueryLayers m = HieraQueryLayers
  { _globalLayer :: HieraQueryFunc m,
    _environmentLayer :: HieraQueryFunc m,
    _moduleLayer :: Container (HieraQueryFunc m)
  }

-- | Whether the template source is specified 'inline' or loaded from a file.
data TemplateSource = Inline Text | Filename FilePath

data InterpreterReader m = InterpreterReader
  { _readerNativeTypes :: !(Container NativeTypeMethods),
    -- | Access to parsed statements
    _readerGetStatement :: TopLevelType -> Text -> m (S.Either PrettyError Statement),
    _readerGetTemplate :: TemplateSource -> InterpreterState -> InterpreterReader m -> m (S.Either PrettyError Text),
    _readerPdbApi :: PuppetDBAPI m,
    -- | External func such as stdlib or puppetlabs
    _readerExternalFunc :: Container ([PValue] -> InterpreterMonad PValue),
    _readerNodename :: Text,
    _readerHieraQuery :: HieraQueryLayers m,
    _readerIoMethods :: IoMethods m,
    _readerIgnoredModules :: HashSet Text,
    _readerExternalModules :: HashSet Text,
    _readerIsStrict :: Bool,
    _readerPuppetPaths :: PuppetDirPaths,
    _readerRebaseFile :: Maybe FilePath,
    -- | Access to the list of facts that were given to the 'Preferences' module
    _readerFacts :: Container PValue
  }

data InterpreterInstr a where
  -- Utility for using what's in 'InterpreterReader'
  GetNativeTypes :: InterpreterInstr (Container NativeTypeMethods)
  GetStatement :: TopLevelType -> Text -> InterpreterInstr Statement
  ComputeTemplate :: TemplateSource -> InterpreterState -> InterpreterInstr Text
  ExternalFunction :: Text -> [PValue] -> InterpreterInstr PValue
  Facts :: InterpreterInstr (Container PValue)
  GetNodeName :: InterpreterInstr Text
  HieraQuery :: Container PValue -> Text -> HieraQueryType -> InterpreterInstr (Maybe PValue)
  GetCurrentCallStack :: InterpreterInstr [String]
  IsIgnoredModule :: Text -> InterpreterInstr Bool
  IsExternalModule :: Text -> InterpreterInstr Bool
  IsStrict :: InterpreterInstr Bool
  PuppetPaths :: InterpreterInstr PuppetDirPaths
  RebaseFile :: InterpreterInstr (Maybe FilePath)
  -- error
  ErrorThrow :: PrettyError -> InterpreterInstr a
  ErrorCatch :: InterpreterMonad a -> (PrettyError -> InterpreterMonad a) -> InterpreterInstr a
  -- writer
  WriterTell :: InterpreterWriter -> InterpreterInstr ()
  WriterPass :: InterpreterMonad (a, InterpreterWriter -> InterpreterWriter) -> InterpreterInstr a
  WriterListen :: InterpreterMonad a -> InterpreterInstr (a, InterpreterWriter)
  -- puppetdb wrappers  , see 'PuppetDBAPI' for details
  PDBInformation :: InterpreterInstr Doc
  PDBReplaceCatalog :: WireCatalog -> InterpreterInstr ()
  PDBReplaceFacts :: [(NodeName, Facts)] -> InterpreterInstr ()
  PDBDeactivateNode :: NodeName -> InterpreterInstr ()
  PDBGetFacts :: Query FactField -> InterpreterInstr [FactInfo]
  PDBGetResources :: Query ResourceField -> InterpreterInstr [Resource]
  PDBGetNodes :: Query NodeField -> InterpreterInstr [NodeInfo]
  PDBCommitDB :: InterpreterInstr ()
  PDBGetResourcesOfNode :: NodeName -> Query ResourceField -> InterpreterInstr [Resource]
  -- Reading the first file that can be read in a list
  ReadFile :: [Text] -> InterpreterInstr Text
  -- Tracing events
  TraceEvent :: String -> InterpreterInstr ()

-- | The main monad
type InterpreterMonad = ProgramT InterpreterInstr (State InterpreterState)

instance Fail.MonadFail InterpreterMonad where
  fail = throwError . PrettyError . ppstring

instance MonadError PrettyError InterpreterMonad where
  throwError = singleton . ErrorThrow
  catchError a c = singleton (ErrorCatch a c)

-- | Log
type InterpreterWriter = [Pair Log.Priority Doc]

instance MonadWriter InterpreterWriter InterpreterMonad where
  tell = singleton . WriterTell
  pass = singleton . WriterPass
  listen = singleton . WriterListen

data ResourceModifier = ResourceModifier
  { _rmResType :: !Text,
    _rmModifierType :: !ModifierType,
    _rmType :: !ResourceCollectorType,
    _rmSearch :: !RSearchExpression,
    _rmMutation :: !(Resource -> InterpreterMonad Resource),
    _rmDeclaration :: !PPosition
  }

instance Show ResourceModifier where
  show (ResourceModifier rt mt ct se _ p) = List.unwords ["ResourceModifier", show rt, show mt, show ct, "(" ++ show se ++ ")", "???", show p]

data ModifierType
  = -- | For collectors, optional resources
    ModifierCollector
  | -- | For stuff like realize
    ModifierMustMatch
  deriving (Show, Eq)

data OverrideType
  = -- | Overriding forbidden, will throw an error
    CantOverride
  | -- | Can silently replace
    Replace
  | -- | Silently ignore errors
    CantReplace
  | -- | Can append values
    AppendAttribute
  deriving (Show, Eq)

data ResourceCollectorType
  = RealizeVirtual
  | RealizeCollected
  | DontRealize
  deriving (Show, Eq)

makeLenses ''ResDefaults
makeLenses ''HieraQueryLayers
makeLenses ''ResourceModifier
makeLenses ''InterpreterReader
makeLenses ''IoMethods
makeLenses ''CurContainer
makeLenses ''ScopeInformation
makeLenses ''InterpreterState

class (Monad m) => MonadThrowPos m where
  throwPosError :: Doc -> m a

-- Useful for mocking for instance in a REPL
instance MonadThrowPos (Either Doc) where
  throwPosError = Left

class MonadStack m where
  getCurrentCallStack :: m [String]

instance MonadStack InterpreterMonad where
  getCurrentCallStack = singleton GetCurrentCallStack

instance MonadThrowPos InterpreterMonad where
  throwPosError s = do
    p <- use (curPos . _1)
    stack <- getCurrentCallStack
    let dstack =
          if null stack
            then line
            else mempty </> ppstring (GHC.Stack.renderStack stack)
    throwError (PrettyError (s <+> "at" <+> showPos p <> dstack))