Helpers.hs

{-# LANGUAGE RankNTypes #-}
{-# OPTIONS_HADDOCK hide, prune, ignore-exports #-}

-- | Internal helpers module.
module Puppet.Interpreter.Helpers where

import Control.Monad.Operational
import Control.Monad.Writer.Class
import qualified Data.HashMap.Strict as Map
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 Data.Vector as Vector
import Facter
import GHC.Err as Err
import Puppet.Interpreter.Types
import qualified System.Log.Logger as Log
import XPrelude hiding (key)

initialState ::
  Facts ->
  -- | Server settings
  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 =
      -- add the `facts` key: https://docs.puppet.com/puppet/4.10/lang_facts_and_builtin_vars.html#accessing-facts-from-puppet-code
      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)

-- Scope
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
{-# INLINEABLE getScope #-}
getScope =
  use curScope >>= \s ->
    if null s
      then throwPosError "Internal error: empty scope!"
      else pure (List.head s)

getCurContainer :: InterpreterMonad CurContainer
{-# INLINEABLE 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)

-- Singleton getters available in the InterpreterMonad --
getPuppetPaths :: InterpreterMonad PuppetDirPaths
getPuppetPaths = singleton PuppetPaths

getNodeName :: InterpreterMonad NodeName
getNodeName = singleton GetNodeName

-- | Give key such as "os.family"
-- look an hash of facts to retrieve deepest PValue
lookupFacts :: Text -> HashMap Text PValue -> Maybe PValue
lookupFacts key facts =
  let (k0, ks) = case Text.splitOn "." key of
        a : b -> (a, b)
        _ -> Err.error "should not happen"
      f k = \case
        Just (PHash h) -> Map.lookup k h
        x -> x
   in List.foldr f (Map.lookup k0 facts) ks

-- | Ask the value of a fact given a specified key
-- The fact set comes from the reader used by the interpreter monad.
askFact :: Text -> InterpreterMonad (Maybe PValue)
askFact key = do
  facts <- singleton Facts
  pure $ lookupFacts key facts

isIgnoredModule :: Text -> InterpreterMonad Bool
isIgnoredModule m = singleton (IsIgnoredModule m)

-- | Throws an error if we are in strict mode
-- A warning in permissive mode
checkStrict ::
  -- | The warning message.
  Doc ->
  -- | The error message.
  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 "::"

-- Logging --
error :: (MonadWriter InterpreterWriter m) => Doc -> m ()
error d = tell [Log.ERROR :!: d]

critical :: (MonadWriter InterpreterWriter m) => Doc -> m ()
critical d = tell [Log.CRITICAL :!: d]

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
{-# INLINEABLE 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) -- get the current containder description
              cscps = scps & ix scope_name . scopeVariables . at "classes" ?~ ((classes :!: initialPPos mempty) :!: container_desc)
           in Just (scope_name, cscps)