{-# LANGUAGE TemplateHaskell #-}
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 XPrelude as Exports
import Data.Aeson.Lens (_Integer, _Number)
import Data.Char (isDigit)
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
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
data NativeTypeMethods = NativeTypeMethods
{ _puppetValidate :: NativeTypeValidate
, _puppetFields :: HS.HashSet Text
}
makeClassy ''NativeTypeMethods
paramname :: Text -> Doc
paramname = red . ppline
perror :: Doc -> Either PrettyError Resource
perror = Left . PrettyError
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)
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)
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
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
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'
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))
x -> perror $ "Parameter" <+> paramname param <+> "should be a string, and not" <+> pretty x
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
defaultvalue :: Text -> Text -> NativeTypeValidate
defaultvalue value param = Right . over (rattributes . at param) (Just . fromMaybe (PString value))
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 ^? _Integer of
Just v -> Right (res & rattributes . at param ?~ PNumber (fromIntegral v))
_ -> perror $ "Parameter" <+> paramname param <+> "must be an integer"
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))
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."
mandatory :: Text -> NativeTypeValidate
mandatory param res = case res ^. rattributes . at param of
Just _ -> Right res
Nothing -> perror $ "Parameter" <+> paramname param <+> "should be set."
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
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
checkipv4 "" _ = False
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 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 . _Number
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