{-# LANGUAGE OverloadedLists #-}
module Puppet.Runner.Puppetlabs (extFunctions) where
import XPrelude
import Crypto.Hash as Crypto
import Data.ByteString (ByteString)
import Data.Char (isDigit)
import Data.Foldable (foldlM)
import qualified Data.HashMap.Strict as Map
import Data.Scientific as Sci
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import Data.Vector (Vector)
import Formatting (scifmt, sformat, (%), (%.))
import qualified Formatting as FMT
import qualified System.Directory as Directory
import System.FilePath ((</>), (<.>))
import System.Random (mkStdGen, randomRs)
import Puppet.Interpreter
md5 :: Text -> Text
md5 = Text.pack . show . (Crypto.hash :: ByteString -> Digest MD5) . Text.encodeUtf8
extFun :: [(Text, Text, [PValue] -> InterpreterMonad PValue)]
extFun = [ ("apache", "bool2httpd", apacheBool2httpd)
, ("docker", "docker_swarm_join_flags", mockDockerSwarmJoinFlags)
, ("docker", "docker_swarm_init_flags", mockDockerSwarmInitFlags)
, ("docker", "docker_run_flags", mockDockerRunFlags)
, ("docker", "docker_stack_flags", mockDockerStackFlags)
, ("docker", "sanitised_name", dockerSanitisedName)
, ("jenkins", "jenkins_port", mockJenkinsPort)
, ("jenkins", "jenkins_prefix", mockJenkinsPrefix)
, ("postgresql", "postgresql_acls_to_resources_hash", pgAclsToHash)
, ("postgresql", "postgresql_password", pgPassword)
, ("puppetdb", "puppetdb_create_subsetting_resource_hash", puppetdbCreateSubsettingResourceHash)
, ("extlib", "random_password", randomPassword)
, ("extlib", "cache_data", mockCacheData)
, ("kubernetes", "kubeadm_init_flags", mockKubernetesInitFlags)
, ("kubernetes", "kubeadm_join_flags", mockKubernetesJoinFlags)
]
extFunctions :: FilePath -> IO (Container ( [PValue] -> InterpreterMonad PValue))
extFunctions modpath = foldlM f Map.empty extFun
where
f acc (nsp, name, fn) = do
test <- testFile (toS nsp) name
if test
then pure $ Map.insert name fn acc
else pure acc
testFile nspath funcname =
let funcpath0 = modpath </> nspath
funcpath1 = funcpath0 </> "lib/puppet"
funcpath2 = funcpath1 </> "parser/functions"
funcpath3 = funcpath1 </> "functions"
in
isJust <$> Directory.findFile [ funcpath0 </> "functions"] (toS funcname <.> "pp")
||^
isJust <$> Directory.findFile [ funcpath2
, funcpath3
, funcpath2 </> nspath
, funcpath3 </> nspath
] (toS funcname <.> "rb")
apacheBool2httpd :: MonadThrowPos m => [PValue] -> m PValue
apacheBool2httpd [PBoolean True] = pure $ PString "On"
apacheBool2httpd [PString "true"] = pure $ PString "On"
apacheBool2httpd [_] = pure $ PString "Off"
apacheBool2httpd arg@_ = throwPosError $ "expect one single argument" <+> pretty arg
pgPassword :: MonadThrowPos m => [PValue] -> m PValue
pgPassword [PString username, PString pwd] =
return $ PString $ "md5" <> md5 (pwd <> username)
pgPassword _ = throwPosError "expects 2 string arguments"
randomPassword :: MonadThrowPos m => [PValue] -> m PValue
randomPassword [PNumber s] =
PString . Text.pack . randomChars <$> scientificToInt s
where
randomChars n = take n $ randomRs ('a', 'z') (mkStdGen 1)
randomPassword _ = throwPosError "expect one single string arguments"
mockJenkinsPrefix :: MonadThrowPos m => [PValue] -> m PValue
mockJenkinsPrefix [] = return $ PString ""
mockJenkinsPrefix arg@_ = throwPosError $ "expect no argument" <+> pretty arg
mockJenkinsPort :: MonadThrowPos m => [PValue] -> m PValue
mockJenkinsPort [] = return $ PString "8080"
mockJenkinsPort arg@_ = throwPosError $ "expect no argument" <+> pretty arg
mockCacheData :: MonadThrowPos m => [PValue] -> m PValue
mockCacheData [_, _, b] = return b
mockCacheData arg@_ = throwPosError $ "expect 3 string arguments" <+> pretty arg
pgAclsToHash :: MonadThrowPos m => [PValue] -> m PValue
pgAclsToHash [PArray as, PString ident, PNumber offset] = PHash <$> aclsToHash as ident offset
pgAclsToHash _ = throwPosError "expects 3 arguments; one array one string and one number"
aclsToHash :: MonadThrowPos m => Vector PValue -> Text -> Scientific -> m (Container PValue)
aclsToHash vec ident offset = ifoldlM f Map.empty vec
where
f :: MonadThrowPos m => Int -> Container PValue -> PValue -> m (Container PValue)
f idx acc (PString acl) = do
let order = offset + scientific (toInteger idx) 0
keymsg = sformat ("postgresql class generated rule " % FMT.stext % " " % FMT.int) ident idx
x <- aclToHash (Text.words acl) order
return $ Map.insert keymsg x acc
f _ _ pval = throwPosError $ "expect a string as acl but get" <+> pretty pval
aclToHash :: (MonadThrowPos m) => [Text] -> Scientific -> m PValue
aclToHash acl@(typ : db : usr : remaining) order = analyze
where
fin remn hs = return $ PHash $
if null remn
then hs
else Map.insert "auth_option" (PString (Text.unwords remn)) hs
analyze = case remaining of
method : remn | typ == "local" ->
fin remn $ baseHash & at "auth_method" ?~ PString method
addr : msk : method : remn | Text.all isDigit msk ->
fin remn $ baseHash & at "address" ?~ PString (Text.unwords [addr,msk])
& at "auth_method" ?~ PString method
addr : method : remn ->
fin remn $ baseHash & at "address" ?~ PString addr
& at "auth_method" ?~ PString method
_ -> throwPosError $ "Unable to parse acl line" <+> squotes (ppline (Text.unwords acl))
baseHash = [ ("type", PString "local")
, ("database", PString db )
, ("user", PString usr)
, ("order", PString (sformat (FMT.left 3 '0' %. scifmt Sci.Fixed (Just 0)) order))
]
aclToHash acl _ = throwPosError $ "Unable to parse acl line" <+> squotes (ppline (Text.unwords acl))
mockDockerRunFlags :: MonadThrowPos m => [PValue] -> m PValue
mockDockerRunFlags arg@[PHash _]= (pure . PString . show . head) arg
mockDockerRunFlags arg@_ = throwPosError $ "Expect an hash as argument but was" <+> pretty arg
mockDockerStackFlags :: MonadThrowPos m => [PValue] -> m PValue
mockDockerStackFlags arg@[PHash _]= (pure . PString . show . head) arg
mockDockerStackFlags arg@_ = throwPosError $ "Expect an hash as argument but was" <+> pretty arg
mockDockerSwarmJoinFlags :: MonadThrowPos m => [PValue] -> m PValue
mockDockerSwarmJoinFlags arg@[PHash _]= (pure . PString . show . head) arg
mockDockerSwarmJoinFlags arg@_ = throwPosError $ "Expect an hash as argument but was" <+> pretty arg
mockDockerSwarmInitFlags :: MonadThrowPos m => [PValue] -> m PValue
mockDockerSwarmInitFlags arg@[PHash _]= (pure . PString . show . head) arg
mockDockerSwarmInitFlags arg@_ = throwPosError $ "Expect an hash as argument but was" <+> pretty arg
mockKubernetesInitFlags :: MonadThrowPos m => [PValue] -> m PValue
mockKubernetesInitFlags arg@[PHash _]= (pure . PString . show . head) arg
mockKubernetesInitFlags arg@_ = throwPosError $ "Expect an hash as argument but was" <+> pretty arg
mockKubernetesJoinFlags :: MonadThrowPos m => [PValue] -> m PValue
mockKubernetesJoinFlags arg@[PHash _]= (pure . PString . show . head) arg
mockKubernetesJoinFlags arg@_ = throwPosError $ "Expect an hash as argument but was" <+> pretty arg
scientificToInt :: MonadThrowPos m => Scientific -> m Int
scientificToInt s = maybe (throwPosError $ "Unable to convert" <+> pretty s <+> "into an int.")
pure
(Sci.toBoundedInteger s)
puppetdbCreateSubsettingResourceHash :: MonadThrowPos m => [PValue] -> m PValue
puppetdbCreateSubsettingResourceHash [PHash s, PHash args] = do
let res_hash = [ (k, PHash h)
| (k,v) <- itoList s
, let h = [ ( "subsetting", PString k) , ("value", v)] `Map.union` args
]
pure $ PHash (Map.fromList res_hash)
puppetdbCreateSubsettingResourceHash arg@_ = throwPosError $ "Expect 2 hashes as arguments but was" <+> pretty arg
dockerSanitisedName :: MonadThrowPos m => [PValue] -> m PValue
dockerSanitisedName [PString s] =
pure $ PString s
dockerSanitisedName arg@_ = throwPosError $ "Expect an hash as argument but was" <+> pretty arg