content: {-# LANGUAGE TemplateHaskell #-}
  {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
  
  {-# HLINT ignore "Use camelCase" #-}
  --  Private modules.
  --  Function and data types that are used to define the native types.
  module Puppet.Language.NativeTypes.Helpers
    ( module Exports,
      ipaddr,
      nativetypemethods,
      NativeTypeName,
      NativeTypeValidate,
      NativeTypeMethods,
      HasNativeTypeMethods (..),
      paramname,
      rarray,
      string,
      strings,
      string_s,
      noTrailingSlash,
      fullyQualified,
      fullyQualifieds,
      values,
      defaultvalue,
      nameval,
      defaultValidate,
      integer,
      integers,
      mandatory,
      mandatoryIfNotAbsent,
      inrange,
      faketype,
      defaulttype,
      runarray,
      perror,
      validateSourceOrContent,
    )
  where
  
  import Data.Char as Char
  import qualified Data.HashMap.Strict as Map
  import qualified Data.HashSet as HS
  import qualified Data.Text as Text
  import qualified Data.Vector as V
  import Puppet.Language.Core as Exports
  import Puppet.Language.Resource as Exports
  import Puppet.Language.Value as Exports
  import qualified Text.Read
  import XPrelude as Exports
  
  metaparameters :: HS.HashSet Text
  metaparameters = HS.fromList ["tag", "stage", "name", "title", "alias", "audit", "check", "loglevel", "noop", "schedule", "EXPORTEDSOURCE", "require", "before", "register", "notify"]
  
  type NativeTypeName = Text
  
  type NativeTypeValidate = Resource -> Either PrettyError Resource
  
  -- | Attributes (and providers) of a puppet resource type bundled with validation rules
  data NativeTypeMethods = NativeTypeMethods
    { _puppetValidate :: NativeTypeValidate,
      _puppetFields :: HS.HashSet Text
    }
  
  makeClassy ''NativeTypeMethods
  
  paramname :: Text -> Doc
  paramname = red . ppline
  
  -- | Useful helper for buiding error messages
  perror :: Doc -> Either PrettyError Resource
  perror = Left . PrettyError
  
  -- | Smart constructor for 'NativeTypeMethods'.
  nativetypemethods :: [(Text, [Text -> NativeTypeValidate])] -> NativeTypeValidate -> NativeTypeMethods
  nativetypemethods def extraV =
    let params = fromKeys def
     in NativeTypeMethods (defaultValidate params >=> parameterFunctions def >=> extraV) params
    where
      fromKeys = HS.fromList . map fst
  
  faketype :: NativeTypeName -> (NativeTypeName, NativeTypeMethods)
  faketype tname = (tname, NativeTypeMethods Right HS.empty)
  
  defaulttype :: NativeTypeName -> (NativeTypeName, NativeTypeMethods)
  defaulttype tname = (tname, NativeTypeMethods (defaultValidate HS.empty) HS.empty)
  
  -- | Validate resources given a list of valid parameters:
  --
  --      * checks that no unknown parameters have been set (except metaparameters)
  defaultValidate :: HS.HashSet Text -> NativeTypeValidate
  defaultValidate validparameters = checkParameterList validparameters >=> addDefaults
  
  checkParameterList :: HS.HashSet Text -> NativeTypeValidate
  checkParameterList validparameters res
    | HS.null validparameters = Right res
    | otherwise =
        if HS.null setdiff
          then Right res
          else perror $ "Unknown parameters: " <+> list (map paramname $ HS.toList setdiff)
    where
      keyset = HS.fromList $ Map.keys (res ^. rattributes)
      setdiff = HS.difference keyset (metaparameters `HS.union` validparameters)
  
  -- | This validator always accept the resources, but add the default parameters (to be defined :)
  addDefaults :: NativeTypeValidate
  addDefaults res = Right (res & rattributes %~ newparams)
    where
      def PUndef = False
      def _ = True
      newparams p = Map.filter def $ Map.union p defaults
      defaults = Map.empty
  
  -- | Helper function that runs a validor on a 'PArray'
  runarray :: Text -> (Text -> PValue -> NativeTypeValidate) -> NativeTypeValidate
  runarray param func res = case res ^. rattributes . at param of
    Just (PArray x) -> V.foldM (flip (func param)) res x
    Just x -> perror $ "Parameter" <+> paramname param <+> "should be an array, not" <+> pretty x
    Nothing -> Right res
  
  -- | This checks that a given parameter is a string. If it is a 'PBoolean' or
  -- 'PNumber' it will convert them to a string.
  string :: Text -> NativeTypeValidate
  string param res = case res ^. rattributes . at param of
    Just x -> string' param x res
    Nothing -> Right res
  
  strings :: Text -> NativeTypeValidate
  strings param = runarray param string'
  
  -- |  Validates a string or an array of strings
  string_s :: Text -> NativeTypeValidate
  string_s param res = case res ^. rattributes . at param of
    Nothing -> Right res
    Just (PArray _) -> strings param res
    Just _ -> string param res
  
  string' :: Text -> PValue -> NativeTypeValidate
  string' param rev res = case rev of
    PString _ -> Right res
    PBoolean True -> Right (res & rattributes . at param ?~ PString "true")
    PBoolean False -> Right (res & rattributes . at param ?~ PString "false")
    PNumber n -> Right (res & rattributes . at param ?~ PString (scientific2text n))
    PSensitive x -> case string' param x res of
      Right v -> Right v
      Left _ -> perror $ "Parameter" <+> paramname param <+> "should be a string, and not" <+> pretty x
    x -> perror $ "Parameter" <+> paramname param <+> "should be a string, and not" <+> pretty x
  
  -- | Makes sure that the parameter, if defined, has a value among this list.
  values :: [Text] -> Text -> NativeTypeValidate
  values valuelist param res = case res ^. rattributes . at param of
    Just (PString x) ->
      if x `elem` valuelist
        then Right res
        else perror $ "Parameter" <+> paramname param <+> "value should be one of" <+> list (map ppline valuelist) <+> "and not" <+> ppline x
    Just x -> perror $ "Parameter" <+> paramname param <+> "value should be one of" <+> list (map ppline valuelist) <+> "and not" <+> pretty x
    Nothing -> Right res
  
  -- | This fills the default values of unset parameters.
  defaultvalue :: Text -> Text -> NativeTypeValidate
  defaultvalue value param = Right . over (rattributes . at param) (Just . fromMaybe (PString value))
  
  -- | Checks that a given parameter, if set, is a 'PNumber'.
  -- If it is a 'PString' it will attempt to parse it.
  integer :: Text -> NativeTypeValidate
  integer prm res = string prm res >>= integer' prm
    where
      integer' pr rs = case rs ^. rattributes . at pr of
        Just x -> integer'' prm x res
        Nothing -> Right rs
  
  integers :: Text -> NativeTypeValidate
  integers param = runarray param integer''
  
  integer'' :: Text -> PValue -> NativeTypeValidate
  integer'' param val res = case val ^? _PValueInteger of
    Just v -> Right (res & rattributes . at param ?~ PNumber (fromIntegral v))
    _ -> perror $ "Parameter" <+> paramname param <+> "must be an integer"
  
  -- | Copies the "name" value into the parameter if this is not set.
  -- It implies the `string` validator.
  nameval :: Text -> NativeTypeValidate
  nameval prm res =
    string prm res >>= \r ->
      case r ^. rattributes . at prm of
        Just (PString al) -> Right (res & rid . iname .~ al)
        Just x -> perror ("The alias must be a string, not" <+> pretty x)
        Nothing -> Right (r & rattributes . at prm ?~ PString (r ^. rid . iname))
  
  -- | Checks that a given parameter is set unless the resources "ensure" is set to absent
  mandatoryIfNotAbsent :: Text -> NativeTypeValidate
  mandatoryIfNotAbsent param res =
    case res ^. rattributes . at param of
      Just _ -> Right res
      Nothing -> case res ^. rattributes . at "ensure" of
        Just "absent" -> Right res
        _ -> perror $ "Parameter" <+> paramname param <+> "should be set."
  
  -- | Checks that a given parameter is set.
  mandatory :: Text -> NativeTypeValidate
  mandatory param res = case res ^. rattributes . at param of
    Just _ -> Right res
    Nothing -> perror $ "Parameter" <+> paramname param <+> "should be set."
  
  -- Helper that takes a list of stuff and will generate a validator.
  parameterFunctions :: [(Text, [Text -> NativeTypeValidate])] -> NativeTypeValidate
  parameterFunctions argrules rs = foldM parameterFunctions' rs argrules
    where
      parameterFunctions' :: Resource -> (Text, [Text -> NativeTypeValidate]) -> Either PrettyError Resource
      parameterFunctions' r (param, validationfunctions) = foldM (parameterFunctions'' param) r validationfunctions
      parameterFunctions'' :: Text -> Resource -> (Text -> NativeTypeValidate) -> Either PrettyError Resource
      parameterFunctions'' param r validationfunction = validationfunction param r
  
  -- checks that a parameter is fully qualified
  fullyQualified :: Text -> NativeTypeValidate
  fullyQualified param res = case res ^. rattributes . at param of
    Just path -> fullyQualified' param path res
    Nothing -> Right res
  
  noTrailingSlash :: Text -> NativeTypeValidate
  noTrailingSlash param res =
    case res ^. rattributes . at param of
      Just (PString x) ->
        if Text.last x == '/'
          then perror ("Parameter" <+> paramname param <+> "should not have a trailing slash")
          else Right res
      _ -> Right res
  
  fullyQualifieds :: Text -> NativeTypeValidate
  fullyQualifieds param = runarray param fullyQualified'
  
  fullyQualified' :: Text -> PValue -> NativeTypeValidate
  fullyQualified' param path res =
    case path of
      PString "" -> perror $ "Empty path for parameter" <+> paramname param
      PString p ->
        if Text.head p == '/'
          then Right res
          else perror $ "Path must be absolute, not" <+> ppline p <+> "for parameter" <+> paramname param
      x -> perror $ "SHOULD NOT HAPPEN: path is not a resolved string, but" <+> pretty x <+> "for parameter" <+> paramname param
  
  rarray :: Text -> NativeTypeValidate
  rarray param res = case res ^. rattributes . at param of
    Just (PArray _) -> Right res
    Just x -> Right $ res & rattributes . at param ?~ PArray (V.singleton x)
    Nothing -> Right res
  
  ipaddr :: Text -> NativeTypeValidate
  ipaddr param res =
    case res ^. rattributes . at param of
      Nothing -> Right res
      Just (PString ip) ->
        if checkipv4 ip 0
          then Right res
          else perror $ "Invalid IP address for parameter" <+> paramname param
      Just x -> perror $ "Parameter" <+> paramname param <+> "should be an IP address string, not" <+> pretty x
  
  checkipv4 :: Text -> Int -> Bool
  checkipv4 _ 4 = False -- means that there are more than 4 groups
  checkipv4 "" _ = False -- should never get an empty string
  checkipv4 ip v =
    let (cur, nxt) = Text.break (== '.') ip
        nextfunc =
          if Text.null nxt
            then v == 3
            else checkipv4 (Text.tail nxt) (v + 1)
        goodcur = not (Text.null cur) && Text.all Char.isDigit cur && (let rcur = Text.Read.read (Text.unpack cur) :: Int in (rcur >= 0) && (rcur <= 255))
     in goodcur && nextfunc
  
  inrange :: Integer -> Integer -> Text -> NativeTypeValidate
  inrange mi ma param res =
    let va = res ^. rattributes . at param
        na = va ^? traverse . _PValueNumber
     in case (va, na) of
          (Nothing, _) -> Right res
          (_, Just v) ->
            if (v >= fromIntegral mi) && (v <= fromIntegral ma)
              then Right res
              else perror $ "Parameter" <+> paramname param <> "'s value should be between" <+> pretty mi <+> "and" <+> pretty ma
          (Just x, _) -> perror $ "Parameter" <+> paramname param <+> "should be an integer, and not" <+> pretty x
  
  validateSourceOrContent :: NativeTypeValidate
  validateSourceOrContent res =
    let parammap = res ^. rattributes
        source = Map.member "source" parammap
        content = Map.member "content" parammap
     in if source && content
          then perror "Source and content can't be specified at the same time"
          else Right res
  