{-# LANGUAGE AutoDeriveTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
module Puppet.Interpreter.Types (
InterpreterState(InterpreterState)
, scopes
, definedResources
, nestedDeclarations
, resModifiers
, extraRelations
, curScope
, curPos
, loadedClasses
, InterpreterReader(InterpreterReader)
, readerNativeTypes
, readerGetStatement
, readerGetTemplate
, readerPdbApi
, readerExternalFunc
, readerNodename
, readerHieraQuery
, readerIoMethods
, readerIgnoredModules
, readerExternalModules
, readerIsStrict
, readerPuppetPaths
, readerFacts
, readerRebaseFile
, InterpreterMonad
, InterpreterWriter
, InterpreterInstr(..)
, Strictness(..)
, IoMethods(IoMethods)
, ioGetCurrentCallStack
, ioReadFile
, ioTraceEvent
, MonadThrowPos(..)
, ResourceModifier(ResourceModifier)
, rmResType
, rmDeclaration
, rmSearch
, rmType
, rmMutation
, rmModifierType
, ModifierType(..)
, OverrideType(..)
, ResourceCollectorType(..)
, ClassIncludeType(..)
, RSearchExpression(..)
, ScopeInformation(ScopeInformation)
, scopeResDefaults
, scopeVariables
, scopeParent
, scopeOverrides
, scopeContainer
, scopeExtraTags
, CurContainer(CurContainer)
, cctype
, cctags
, ResDefaults(ResDefaults)
, resDefValues
, resDefSrcScope
, resDefPos
, resDefType
, ResRefOverride(..)
, ScopeEnteringContext(..)
, TopLevelType(..)
, HieraQueryLayers(..)
, globalLayer
, environmentLayer
, moduleLayer
, TemplateSource(..)
, module Puppet.Language
) where
import XPrelude.Extra
import XPrelude.PP
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 qualified GHC.Show
import qualified GHC.Stack
import qualified System.Log.Logger as Log
import Facter
import Hiera.Server
import Puppet.Language
import Puppet.Parser.Types
import PuppetDB
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)
data ClassIncludeType
= ClassIncludeLike
| ClassResourceLike
deriving (Eq)
data TopLevelType
= TopNode
| TopDefine
| TopClass
deriving (Generic, Eq)
instance Hashable TopLevelType
data ResDefaults = ResDefaults
{ _resDefType :: !Text
, _resDefSrcScope :: !Text
, _resDefValues :: !(Container PValue)
, _resDefPos :: !PPosition
}
data ResRefOverride = ResRefOverride
{ _rrid :: !RIdentifier
, _rrparams :: !(Container PValue)
, _rrpos :: !PPosition
} deriving (Eq)
data ScopeEnteringContext
= SENormal
| SEChild !Text
| SEParent !Text
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 ()
}
data HieraQueryLayers m = HieraQueryLayers
{ _globalLayer :: HieraQueryFunc m
, _environmentLayer :: HieraQueryFunc m
, _moduleLayer :: Container (HieraQueryFunc m)
}
data TemplateSource= Inline Text | Filename FilePath
data InterpreterReader m = InterpreterReader
{ _readerNativeTypes :: !(Container NativeTypeMethods)
, _readerGetStatement :: TopLevelType -> Text -> m (S.Either PrettyError Statement)
, _readerGetTemplate :: TemplateSource -> InterpreterState -> InterpreterReader m -> m (S.Either PrettyError Text)
, _readerPdbApi :: PuppetDBAPI m
, _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
, _readerFacts :: Container PValue
}
data InterpreterInstr a where
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)
ErrorThrow :: PrettyError -> InterpreterInstr a
ErrorCatch :: InterpreterMonad a -> (PrettyError -> InterpreterMonad a) -> InterpreterInstr a
WriterTell :: InterpreterWriter -> InterpreterInstr ()
WriterPass :: InterpreterMonad (a, InterpreterWriter -> InterpreterWriter) -> InterpreterInstr a
WriterListen :: InterpreterMonad a -> InterpreterInstr (a, InterpreterWriter)
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]
ReadFile :: [Text] -> InterpreterInstr Text
TraceEvent :: String -> InterpreterInstr ()
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)
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
= ModifierCollector
| ModifierMustMatch
deriving (Show, Eq)
data OverrideType
= CantOverride
| Replace
| CantReplace
| 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
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))