{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TupleSections #-}
module Puppet.Stdlib (stdlibFunctions) where
import Control.Lens
import Control.Monad
import Data.Aeson.Lens
import qualified Data.ByteString.Base16 as B16
import Data.Char
import qualified Data.HashMap.Strict as HM
import Data.List.Split (chunksOf)
import Data.Maybe (mapMaybe)
import Data.Monoid
import qualified Data.Scientific as Scientific
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Data.Traversable (for)
import qualified Data.Vector as V
import Data.Vector.Lens (toVectorOf)
import qualified Text.PrettyPrint.ANSI.Leijen as PP
import Text.Regex.PCRE.ByteString.Utils
import Puppet.Interpreter.Resolve
import Puppet.Interpreter.Types
import Puppet.Interpreter.Utils
import Puppet.PP
-- | Contains the implementation of the StdLib functions.
stdlibFunctions :: Container ( [PValue] -> InterpreterMonad PValue )
stdlibFunctions = HM.fromList [ singleArgument "abs" puppetAbs
, ("any2array", any2array)
, ("assert_private", assertPrivate)
, ("base64", base64)
-- basename
, singleArgument "bool2num" bool2num
-- bool2str
-- camelcase
, ("capitalize", stringArrayFunction (safeEmptyString (\t -> T.cons (toUpper (T.head t)) (T.tail t))))
-- ceiling
, ("chomp", stringArrayFunction (T.dropWhileEnd (\c -> c == '\n' || c == '\r')))
, ("chop", stringArrayFunction (safeEmptyString T.init))
-- clamp
, ("concat", puppetConcat)
-- convert_base
, ("count", puppetCount)
-- deep_merge
, ("defined_with_params", const (throwPosError "defined_with_params can't be implemented with language-puppet"))
, ("delete", delete)
, ("delete_at", deleteAt)
, singleArgument "delete_undef_values" deleteUndefValues
-- delete_values
-- difference
-- dirname
-- dos2unix
, ("downcase", stringArrayFunction T.toLower)
, singleArgument "empty" _empty
-- ensure_packages (in main interpreter module)
-- ensure_resource (in main interpreter module)
, singleArgument "flatten" flatten
-- floor
-- fqdn_rand_string
-- fqdn_rotate
-- get_module_path
, ("getparam", const $ throwPosError "The getparam function is uncool and shall not be implemented in language-puppet")
, singleArgument "getvar" getvar
, ("grep", _grep)
, ("hash", hash)
-- has_interface_with
-- has_ip_address
-- has_ip_network
, ("has_key", hasKey)
-- intersection
-- is_absolute_path
, singleArgument "is_array" isArray
, singleArgument "is_bool" isBool
, singleArgument "is_domain_name" isDomainName
-- is_float
-- is_function_available
, singleArgument "is_hash" isHash
, singleArgument "is_integer" isInteger
-- is_ip_address
-- is_mac_address
-- is_numeric
, singleArgument "is_string" isString
, ("join", puppetJoin)
, ("join_keys_to_values", joinKeysToValues)
, singleArgument "keys" keys
-- load_module_metadata
-- loadyaml
, ("lstrip", stringArrayFunction T.stripStart)
-- max
, ("member", member)
, ("merge", merge)
-- min
-- num2bool
-- parsejson
-- parseyaml
, ("pick", pick)
, ("pick_default", pickDefault)
-- prefix
-- private
-- pw_hash
-- range
-- reject
-- reverse
, ("rstrip", stringArrayFunction T.stripEnd)
-- seeded_rand
-- shuffle
, singleArgument "size" size
-- sort
-- squeeze
, singleArgument "str2bool" str2Bool
-- strtosaltedshar512
-- strftime
, ("strip", stringArrayFunction T.strip)
-- suffix
-- swapcase
-- time
-- to_bytes
-- try_get_value
-- type3x
-- type
-- union
-- unique
-- unix2dos
, ("upcase", stringArrayFunction T.toUpper)
-- uriescape
, ("validate_absolute_path", validateAbsolutePath)
, ("validate_array", validateArray)
-- validate_augeas
, ("validate_bool", validateBool)
-- validate_cmd
, ("validate_hash", validateHash)
, ("validate_integer", validateInteger)
-- validate_ip_address
-- validate_ipv4_address
-- validate_ipv6_address
, ("validate_numeric", validateNumeric)
, ("validate_re", validateRe)
-- validate_slength
, ("validate_string", validateString)
-- validate_x509_rsa_key_pair
-- values_at
, singleArgument "values" pvalues
-- zip
]
singleArgument :: T.Text -> (PValue -> InterpreterMonad PValue) -> (T.Text, [PValue] -> InterpreterMonad PValue )
singleArgument fname ifunc = (fname, ofunc)
where
ofunc [x] = ifunc x
ofunc _ = throwPosError (ttext fname <> "(): Expects a single argument.")
safeEmptyString :: (T.Text -> T.Text) -> T.Text -> T.Text
safeEmptyString _ "" = ""
safeEmptyString f x = f x
stringArrayFunction :: (T.Text -> T.Text) -> [PValue] -> InterpreterMonad PValue
stringArrayFunction f [PString s] = return (PString (f s))
stringArrayFunction f [PArray xs] = fmap PArray (V.mapM (fmap (PString . f) . resolvePValueString) xs)
stringArrayFunction _ [a] = throwPosError ("function expects a string or an array of strings, not" <+> pretty a)
stringArrayFunction _ _ = throwPosError "function expects a single argument"
compileRE :: T.Text -> InterpreterMonad Regex
compileRE r = case compile' compBlank execBlank (T.encodeUtf8 r) of
Left rr -> throwPosError ("Could not compile" <+> ttext r <+> ":" <+> string (show rr))
Right x -> return x
matchRE :: Regex -> T.Text -> InterpreterMonad Bool
matchRE r t = case execute' r (T.encodeUtf8 t) of
Left rr -> throwPosError ("Could not match:" <+> string (show rr))
Right m -> return (has _Just m)
puppetAbs :: PValue -> InterpreterMonad PValue
puppetAbs y = case y ^? _Number of
Just x -> return $ _Number # abs x
Nothing -> throwPosError ("abs(): Expects a number, not" <+> pretty y)
assertPrivate :: [PValue] -> InterpreterMonad PValue
assertPrivate args = case args of
[] -> go Nothing
[t] -> resolvePValueString t >>= go . Just
_ -> throwPosError "assert_private: expects no or a single string argument"
where
go msg = do
scp <- use curScope
case scp of
funScope : callerScope : _ ->
let takeModule = T.takeWhile (/= ':') . moduleName
in if takeModule funScope == takeModule callerScope
then return PUndef
else throwPosError $ maybe ("assert_private: failed: " <> pretty funScope <> " is private") ttext msg
_ -> return PUndef
any2array :: [PValue] -> InterpreterMonad PValue
any2array [PArray v] = return (PArray v)
any2array [PHash h] = return (PArray lst)
where lst = V.fromList $ concatMap arraypair $ HM.toList h
arraypair (a,b) = [PString a, b]
any2array [x] = return (PArray (V.singleton x))
any2array x = return (PArray (V.fromList x))
base64 :: [PValue] -> InterpreterMonad PValue
base64 [pa,pb] = do
b <- fmap T.encodeUtf8 (resolvePValueString pb)
r <- resolvePValueString pa >>= \case
"encode" -> return (B16.encode b)
"decode" -> case B16.decode b of
(x, "") -> return x
_ -> throwPosError ("base64(): could not decode" <+> pretty pb)
a -> throwPosError ("base64(): the first argument must be either 'encode' or 'decode', not" <+> ttext a)
fmap PString (safeDecodeUtf8 r)
base64 _ = throwPosError "base64(): Expects 2 arguments"
bool2num :: PValue -> InterpreterMonad PValue
bool2num (PString "") = return (PBoolean False)
bool2num (PString "1") = return (PBoolean True)
bool2num (PString "t") = return (PBoolean True)
bool2num (PString "y") = return (PBoolean True)
bool2num (PString "true") = return (PBoolean True)
bool2num (PString "yes") = return (PBoolean True)
bool2num (PString "0") = return (PBoolean False)
bool2num (PString "f") = return (PBoolean False)
bool2num (PString "n") = return (PBoolean False)
bool2num (PString "false") = return (PBoolean False)
bool2num (PString "no") = return (PBoolean False)
bool2num (PString "undef") = return (PBoolean False)
bool2num (PString "undefined") = return (PBoolean False)
bool2num x@(PBoolean _) = return x
bool2num x = throwPosError ("bool2num(): Can't convert" <+> pretty x <+> "to boolean")
puppetConcat :: [PValue] -> InterpreterMonad PValue
puppetConcat = return . PArray . V.concat . map toArr
where
toArr (PArray x) = x
toArr x = V.singleton x
puppetCount :: [PValue] -> InterpreterMonad PValue
puppetCount [PArray x] = return (_Integer # V.foldl' cnt 0 x)
where
cnt cur (PString "") = cur
cnt cur PUndef = cur
cnt cur _ = cur + 1
puppetCount [PArray x, y] = return (_Integer # V.foldl' cnt 0 x)
where
cnt cur z | y == z = cur + 1
| otherwise = cur
puppetCount _ = throwPosError "count(): expects 1 or 2 arguments"
delete :: [PValue] -> InterpreterMonad PValue
delete [PString x, y] = fmap (PString . T.concat . (`T.splitOn` x)) (resolvePValueString y)
delete [PArray r, z] = return $ PArray $ V.filter (/= z) r
delete [PHash h, z] = do
tz <- resolvePValueString z
return $ PHash (h & at tz .~ Nothing)
delete [a,_] = throwPosError ("delete(): First argument must be an Array, String, or Hash. Given:" <+> pretty a)
delete _ = throwPosError "delete(): expects 2 arguments"
deleteAt :: [PValue] -> InterpreterMonad PValue
deleteAt [PArray r, z] = case z ^? _Integer of
Just gn ->
let n = fromInteger gn
lr = V.length r
s1 = V.slice 0 n r
s2 = V.slice (n+1) (lr - n - 1) r
in if V.length r <= n
then throwPosError ("delete_at(): Out of bounds access detected, tried to remove index" <+> pretty z <+> "wheras the array only has" <+> string (show lr) <+> "elements")
else return (PArray (s1 <> s2))
_ -> throwPosError ("delete_at(): The second argument must be an integer, not" <+> pretty z)
deleteAt [x,_] = throwPosError ("delete_at(): expects its first argument to be an array, not" <+> pretty x)
deleteAt _ = throwPosError "delete_at(): expects 2 arguments"
deleteUndefValues :: PValue -> InterpreterMonad PValue
deleteUndefValues (PArray r) = return $ PArray $ V.filter (/= PUndef) r
deleteUndefValues (PHash h) = return $ PHash $ HM.filter (/= PUndef) h
deleteUndefValues x = throwPosError ("delete_undef_values(): Expects an Array or a Hash, not" <+> pretty x)
_empty :: PValue -> InterpreterMonad PValue
_empty = return . PBoolean . flip elem [PUndef, PString "", PString "undef", PArray V.empty, PHash HM.empty]
flatten :: PValue -> InterpreterMonad PValue
flatten r@(PArray _) = return $ PArray (flatten' r)
where
flatten' :: PValue -> V.Vector PValue
flatten' (PArray x) = V.concatMap flatten' x
flatten' x = V.singleton x
flatten x = throwPosError ("flatten(): Expects an Array, not" <+> pretty x)
getvar :: PValue -> InterpreterMonad PValue
getvar = resolvePValueString >=> resolveVariable
_grep :: [PValue] -> InterpreterMonad PValue
_grep [PArray vls, rawre] = do
regexp <- resolvePValueString rawre >>= compileRE
rvls <- for vls $ \v -> do
r <- resolvePValueString v
ismatched <- matchRE regexp r
return (r, ismatched)
return $ PArray $ V.map (PString . fst) (V.filter snd rvls)
_grep [x,_] = throwPosError ("grep(): The first argument must be an Array, not" <+> pretty x)
_grep _ = throwPosError "grep(): Expected two arguments."
hash :: [PValue] -> InterpreterMonad PValue
hash [PArray elems] = do
let xs = mapMaybe assocPairs $ chunksOf 2 $ V.toList elems
assocPairs [a,b] = Just (a,b)
assocPairs _ = Nothing
PHash . HM.fromList <$> mapM (\(k,v) -> (,v) <$> resolvePValueString k) xs
hash _ = throwPosError "hash(): Expected and array."
isArray :: PValue -> InterpreterMonad PValue
isArray = return . PBoolean . has _PArray
isDomainName :: PValue -> InterpreterMonad PValue
isDomainName s = do
rs <- resolvePValueString s
let ndrs = if T.last rs == '.'
then T.init rs
else rs
prts = T.splitOn "." ndrs
checkPart x = not (T.null x)
&& (T.length x <= 63)
&& (T.head x /= '-')
&& (T.last x /= '-')
&& T.all (\y -> isAlphaNum y || y == '-') x
return $ PBoolean $ not (T.null rs) && T.length rs <= 255 && all checkPart prts
isInteger :: PValue -> InterpreterMonad PValue
isInteger = return . PBoolean . has _Integer
isHash :: PValue -> InterpreterMonad PValue
isHash = return . PBoolean . has _PHash
isString :: PValue -> InterpreterMonad PValue
isString pv = return $ PBoolean $ case (pv ^? _PString, pv ^? _Number) of
(_, Just _) -> False
(Just _, _) -> True
_ -> False
isBool :: PValue -> InterpreterMonad PValue
isBool = return . PBoolean . has _PBoolean
puppetJoin :: [PValue] -> InterpreterMonad PValue
puppetJoin [PArray rr, PString interc] = do
rrt <- mapM resolvePValueString (V.toList rr)
return (PString (T.intercalate interc rrt))
puppetJoin [_,_] = throwPosError "join(): expected an array of strings, and a string"
puppetJoin _ = throwPosError "join(): expected two arguments"
joinKeysToValues :: [PValue] -> InterpreterMonad PValue
joinKeysToValues [PHash h, separator] = do
ssep <- resolvePValueString separator
fmap (PArray . V.fromList) $ forM (itoList h) $ \(k,v) -> do
sv <- case v of
PUndef -> return ""
_ -> resolvePValueString v
return (PString (k <> ssep <> sv))
joinKeysToValues _ = throwPosError "join_keys_to_values(): expects 2 arguments, an hash and a string"
keys :: PValue -> InterpreterMonad PValue
keys (PHash h) = return (PArray $ V.fromList $ map PString $ HM.keys h)
keys x = throwPosError ("keys(): Expects a Hash, not" <+> pretty x)
member :: [PValue] -> InterpreterMonad PValue
member [PArray v, x] = return $ PBoolean (x `V.elem` v)
member _ = throwPosError "member() expects 2 arguments"
hasKey :: [PValue] -> InterpreterMonad PValue
hasKey [PHash h, k] = do
k' <- resolvePValueString k
return (PBoolean (has (ix k') h))
hasKey [a, _] = throwPosError ("has_key(): expected a Hash, not" <+> pretty a)
hasKey _ = throwPosError "has_key(): expected two arguments."
merge :: [PValue] -> InterpreterMonad PValue
merge xs | length xs < 2 = throwPosError "merge(): Expects at least two hashes"
| otherwise = let hashcontents = mapM (preview _PHash) xs
in case hashcontents of
Nothing -> throwPosError "merge(): Expects hashes"
Just hashes -> return $ PHash (getDual $ foldMap Dual hashes)
pick :: [PValue] -> InterpreterMonad PValue
pick [] = throwPosError "pick(): must receive at least one non empty value"
pick xs = case filter (`notElem` [PUndef, PString "", PString "undef"]) xs of
[] -> throwPosError "pick(): no value suitable to be picked"
(x:_) -> return x
pickDefault :: [PValue] -> InterpreterMonad PValue
pickDefault [] = throwPosError "pick_default(): must receive at least one non empty value"
pickDefault xs = case filter (`notElem` [PUndef, PString "", PString "undef"]) xs of
[] -> return (last xs)
(x:_) -> return x
size :: PValue -> InterpreterMonad PValue
size (PHash h) = return (_Integer # fromIntegral (HM.size h))
size (PArray v) = return (_Integer # fromIntegral (V.length v))
size (PString s) = return (_Integer # fromIntegral (T.length s))
size x = throwPosError ("size(): Expects a hash, and array or a string, not" <+> pretty x)
str2Bool :: PValue -> InterpreterMonad PValue
str2Bool PUndef = return (PBoolean False)
str2Bool a@(PBoolean _) = return a
str2Bool a = do
s <- resolvePValueString a
let b | s `elem` ["", "1", "t", "y", "true", "yes"] = Just True
| s `elem` [ "0", "f", "n", "false", "no"] = Just False
| otherwise = Nothing
case b of
Just x -> return (PBoolean x)
Nothing -> throwPosError "str2bool(): Unknown type of boolean given"
validateAbsolutePath :: [PValue] -> InterpreterMonad PValue
validateAbsolutePath [] = throwPosError "validateAbsolutePath(): wrong number of arguments, must be > 0"
validateAbsolutePath a = mapM_ (resolvePValueString >=> validate) a >> return PUndef
where
validate x | T.head x == '/' = return ()
| otherwise = throwPosError (ttext x <+> "is not an absolute path")
validateArray :: [PValue] -> InterpreterMonad PValue
validateArray [] = throwPosError "validate_array(): wrong number of arguments, must be > 0"
validateArray x = mapM_ vb x >> return PUndef
where
vb (PArray _) = return ()
vb y = throwPosError (pretty y <+> "is not an array.")
validateBool :: [PValue] -> InterpreterMonad PValue
validateBool [] = throwPosError "validate_bool(): wrong number of arguments, must be > 0"
validateBool x = mapM_ vb x >> return PUndef
where
vb (PBoolean _) = return ()
vb y = throwPosError (pretty y <+> "is not a boolean.")
validateHash :: [PValue] -> InterpreterMonad PValue
validateHash [] = throwPosError "validate_hash(): wrong number of arguments, must be > 0"
validateHash x = mapM_ vb x >> return PUndef
where
vb (PHash _) = return ()
vb y = throwPosError (pretty y <+> "is not a hash.")
validateNumeric :: [PValue] -> InterpreterMonad PValue
validateNumeric [] = throwPosError "validate_numeric: invalid arguments"
validateNumeric (arr:extra) = do
(mn, mx) <- case extra of
[mx'] -> (Nothing,) . Just <$> resolvePValueNumber mx'
[PUndef, mi'] -> (,Nothing) . Just <$> resolvePValueNumber mi'
[mx',mi'] -> (,) <$> (Just <$> resolvePValueNumber mi') <*> (Just <$> resolvePValueNumber mx')
[] -> pure (Nothing, Nothing)
_ -> throwPosError "validate_numeric: invalid arguments"
numbers <- case arr of
PArray lst -> mapM resolvePValueNumber (V.toList lst)
_ -> pure <$> resolvePValueNumber arr
forM_ mn $ \mn' -> unless (all (>= mn') numbers) $ throwPosError "validate_numeric: failure"
forM_ mx $ \mx' -> unless (all (<= mx') numbers) $ throwPosError "validate_numeric: failure"
return PUndef
validateRe :: [PValue] -> InterpreterMonad PValue
validateRe [str, reg] = validateRe [str, reg, PString "Match failed"]
validateRe [str, PString reg, msg] = validateRe [str, PArray (V.singleton (PString reg)), msg]
validateRe [str, PArray v, msg] = do
rstr <- resolvePValueString str
rest <- mapM (resolvePValueString >=> compileRE >=> flip matchRE rstr) (V.toList v)
if or rest
then return PUndef
else throwPosError (pretty msg PP.<$> "Source string:" <+> pretty str <> comma <+> "regexps:" <+> pretty (V.toList v))
validateRe [_, r, _] = throwPosError ("validate_re(): expected a regexp or an array of regexps, but not" <+> pretty r)
validateRe _ = throwPosError "validate_re(): wrong number of arguments (#{args.length}; must be 2 or 3)"
validateString :: [PValue] -> InterpreterMonad PValue
validateString [] = throwPosError "validate_string(): wrong number of arguments, must be > 0"
validateString x = mapM_ resolvePValueString x >> return PUndef
validateInteger :: [PValue] -> InterpreterMonad PValue
validateInteger [] = throwPosError "validate_integer(): wrong number of arguments, must be > 0"
validateInteger x = mapM_ vb x >> return PUndef
where
msg d = pretty d <+> "is not an integer."
vb (PNumber n) = unless (Scientific.isInteger n) $ throwPosError (msg (show n))
vb a = throwPosError (msg a)
pvalues :: PValue -> InterpreterMonad PValue
pvalues (PHash h) = return $ PArray (toVectorOf traverse h)
pvalues x = throwPosError ("values(): expected a hash, not" <+> pretty x)