{-# OPTIONS_HADDOCK hide, prune, ignore-exports #-}
{-# LANGUAGE RankNTypes #-}
module Puppet.Interpreter.Helpers where
import XPrelude
import Control.Monad.Operational
import Control.Monad.Writer.Class
import qualified Data.HashMap.Strict as Map
import qualified Data.Vector as Vector
import qualified Data.List as List
import qualified Data.Maybe.Strict as S
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import qualified System.Log.Logger as Log
import Facter
import Puppet.Interpreter.Types
initialState :: Facts
-> Container Text
-> InterpreterState
initialState facts settings =
InterpreterState baseVars initialclass mempty [ContRoot] (initialPPos mempty) mempty [] []
where
callervars = Map.fromList [("caller_module_name", PString "::" :!: (initialPPos mempty) :!: ContRoot), ("module_name", PString "::" :!: (initialPPos mempty) :!: ContRoot)]
factvars =
let facts' = Map.insert "facts" (PHash facts) facts
in fmap (\x -> x :!: initialPPos "facts" :!: ContRoot) facts'
settingvars = fmap (\x -> PString x :!: initialPPos "settings" :!: ContClass "settings") settings
baseVars = Map.fromList [ ("::", ScopeInformation (factvars `mappend` callervars) mempty mempty (CurContainer ContRoot mempty) mempty S.Nothing)
, ("settings", ScopeInformation settingvars mempty mempty (CurContainer (ContClass "settings") mempty) mempty S.Nothing)
]
initialclass = mempty & at "::" ?~ (ClassIncludeLike :!: (initialPPos mempty))
getModulename :: RIdentifier -> Text
getModulename (RIdentifier t n) =
let gm x =
case Text.splitOn "::" x of
[] -> x
(y:_) -> y
in case t of
"class" -> gm n
_ -> gm t
extractPrism :: Doc -> Prism' a b -> a -> InterpreterMonad b
extractPrism msg p a =
case preview p a of
Just b -> return b
Nothing -> throwPosError ("Could not extract prism in" <+> msg)
popScope :: InterpreterMonad ()
popScope = curScope %= List.tail
pushScope :: CurContainerDesc -> InterpreterMonad ()
pushScope s = curScope %= (s :)
getScopeName :: InterpreterMonad Text
getScopeName = scopeName <$> getScope
scopeName :: CurContainerDesc -> Text
scopeName (ContRoot ) = "::"
scopeName (ContImported x ) = "::imported::" `Text.append` scopeName x
scopeName (ContClass x ) = x
scopeName (ContDefine dt dn _) = "#define/" `Text.append` dt `Text.append` "/" `Text.append` dn
scopeName (ContImport _ x ) = "::import::" `Text.append` scopeName x
containerModName :: CurContainerDesc -> Text
containerModName (ContRoot ) = "::"
containerModName (ContImported x ) = containerModName x
containerModName (ContClass x ) = x
containerModName (ContDefine dt _ _) = dt
containerModName (ContImport _ x ) = containerModName x
getScope :: InterpreterMonad CurContainerDesc
{-# INLINABLE getScope #-}
getScope =
use curScope >>= \s ->
if null s
then throwPosError "Internal error: empty scope!"
else pure (List.head s)
getCurContainer :: InterpreterMonad CurContainer
{-# INLINABLE getCurContainer #-}
getCurContainer = do
scp <- getScopeName
preuse (scopes . ix scp . scopeContainer) >>= \case
Just x -> return x
Nothing -> throwPosError ("Internal error: can't find the current container for" <+> ppline scp)
rcurcontainer :: Resource -> CurContainerDesc
rcurcontainer r = fromMaybe ContRoot (r ^? rscope . _head)
getPuppetPaths :: InterpreterMonad PuppetDirPaths
getPuppetPaths = singleton PuppetPaths
getNodeName:: InterpreterMonad NodeName
getNodeName = singleton GetNodeName
lookupFacts :: Text -> HashMap Text PValue -> Maybe PValue
lookupFacts key facts =
let (k0:ks) = Text.splitOn "." key
f k = \case
Just (PHash h) -> Map.lookup k h
x -> x
in
List.foldr f (Map.lookup k0 facts) ks
askFact :: Text -> InterpreterMonad (Maybe PValue)
askFact key = do
facts <- singleton Facts
pure $ lookupFacts key facts
isIgnoredModule :: Text -> InterpreterMonad Bool
isIgnoredModule m = singleton (IsIgnoredModule m)
checkStrict :: Doc
-> Doc
-> InterpreterMonad ()
checkStrict wrn err = do
extMod <- isExternalModule
let priority =
if extMod
then Log.INFO
else Log.WARNING
str <- singleton IsStrict
if str && not extMod
then throwPosError err
else do
srcname <- use (curPos . _1 . _sourceName)
logWriter priority (wrn <+> "at" <+> ppstring srcname)
isExternalModule :: InterpreterMonad Bool
isExternalModule =
getScope >>= \case
ContClass n -> isExternal n
ContDefine n _ _ -> isExternal n
_ -> return False
where
isExternal = singleton . IsExternalModule . List.head . Text.splitOn "::"
warn :: MonadWriter InterpreterWriter m => Doc -> m ()
warn d = tell [Log.WARNING :!: d]
debug :: MonadWriter InterpreterWriter m => Doc -> m ()
debug d = tell [Log.DEBUG :!: d]
logWriter :: MonadWriter InterpreterWriter m => Log.Priority -> Doc -> m ()
logWriter prio d = tell [prio :!: d]
safeDecodeUtf8 :: ByteString -> InterpreterMonad Text
{-# INLINABLE safeDecodeUtf8 #-}
safeDecodeUtf8 i = pure (Text.decodeUtf8 i)
normalizeRIdentifier :: Text -> Text -> RIdentifier
normalizeRIdentifier = RIdentifier . dropInitialColons
extractScope :: InterpreterState -> Maybe (Text, Container ScopeInformation)
extractScope s =
let cscope = s ^. curScope in
if null cscope
then Nothing
else let scope_name = scopeName (List.head cscope)
classes = (PArray . Vector.fromList . map PString . Map.keys) (s ^. loadedClasses)
scps = s ^. scopes
container_desc = fromMaybe ContRoot (scps ^? ix scope_name . scopeContainer . cctype)
cscps = scps & ix scope_name . scopeVariables . at "classes" ?~ ( classes :!: (initialPPos mempty) :!: container_desc )
in Just (scope_name, cscps)