module Canteven.Config (
canteven
) where
import Control.Applicative ((<$>), liftA2)
import Data.Aeson (Value(String, Object), (.:?), (.!=), (.:))
import Data.Maybe (fromMaybe)
import Data.Yaml (FromJSON(parseJSON), decodeFileEither)
import System.Console.GetOpt(ArgOrder(Permute), ArgDescr(ReqArg, NoArg),
OptDescr(Option), getOpt, usageInfo)
import System.Directory (createDirectoryIfMissing)
import System.Environment (getArgs, getProgName)
import System.Exit (ExitCode(ExitSuccess, ExitFailure))
import System.FilePath (dropFileName)
import System.IO (stdout)
import System.Log (Priority(INFO, DEBUG))
import System.Log.Formatter (simpleLogFormatter)
import System.Log.Handler (setFormatter)
import System.Log.Handler.Simple (fileHandler, streamHandler)
import System.Log.Logger (updateGlobalLogger, setHandlers, setLevel)
import System.Posix.Process (exitImmediately)
import qualified Data.Text as T
canteven :: (FromJSON config) => IO config
canteven = do
configPath <- parseOptions
(userConfig, systemConfig) <- loadConfig configPath
setupLogging systemConfig
return userConfig
data SystemConfig =
SystemConfig {
logging :: Maybe LoggingConfig
}
instance FromJSON SystemConfig where
parseJSON (Object topLevel) = do
logging <- topLevel .:? "logging"
return SystemConfig {logging}
parseJSON value =
fail $ "Couldn't parse system config from value " ++ show value
data Opt = Help
| Config String
deriving Show
data LoggingConfig =
LoggingConfig {
level :: LogPriority,
logfile :: Maybe FilePath,
loggers :: [LoggerDetails]
}
instance FromJSON LoggingConfig where
parseJSON (Object logging) = do
level <- logging .:? "level" .!= LP INFO
logfile <- logging .:? "logfile"
loggers <- logging .:? "loggers" .!= []
return LoggingConfig {level, logfile, loggers}
parseJSON value =
fail $ "Couldn't parse logging config from value " ++ show value
setupLogging :: SystemConfig -> IO ()
setupLogging SystemConfig {logging} =
installLoggingConfig (fromMaybe defaultLoggingConfig logging)
defaultLoggingConfig :: LoggingConfig
defaultLoggingConfig = LoggingConfig {
level = LP INFO,
logfile = Nothing,
loggers = []
}
installLoggingConfig :: LoggingConfig -> IO ()
installLoggingConfig LoggingConfig {logfile, level = LP level, loggers} = do
fileHandlers <-
case logfile of
Nothing -> return []
Just filename -> do
createDirectoryIfMissing True (dropFileName filename)
file <- tweak <$> fileHandler filename DEBUG
return [file]
console <- tweak <$> streamHandler stdout DEBUG
let handlers = console:fileHandlers
updateGlobalLogger "" (setLevel level . setHandlers handlers)
sequence_ [
updateGlobalLogger loggerName (setLevel loggerLevel) |
LoggerDetails {loggerName, loggerLevel = LP loggerLevel} <- loggers
]
where
tweak h = setFormatter h (simpleLogFormatter logFormat)
logFormat = "$prio [$tid] [$time] $loggername - $msg"
loadConfig :: FromJSON a => FilePath -> IO (a, SystemConfig)
loadConfig path = do
eUserConfig <- decodeFileEither path
eSystemConfig <- decodeFileEither path
case liftA2 (,) eUserConfig eSystemConfig of
Left errorMsg -> error $
"Couldn't decode YAML config from file "
++ path ++ ": " ++ show errorMsg
Right configs -> return configs
parseOptions :: IO String
parseOptions = do
args <- getArgs
case getOpt Permute options args of
([], [], []) ->
return "config.yml"
([Config config], [], []) ->
return config
([Help], [], []) -> do
usage
exitImmediately ExitSuccess
error "can't reach this statement"
(_, _, []) -> do
usage
die
(_, _, errors) -> do
mapM_ putStr errors
usage
die
where
options =
[ Option "c" ["config"] (ReqArg Config "FILE") "specify configuration file"
, Option "h" ["help"] (NoArg Help) "display help and exit"
]
usage = do
progName <- getProgName
putStr $ usageInfo ("Usage: " ++ progName ++ " -c FILE") options
die = do
exitImmediately (ExitFailure 1)
error "can't reach this statement"
newtype LogPriority = LP Priority
instance FromJSON LogPriority where
parseJSON (String s) = case reads (T.unpack s) of
[(priority, "")] -> return (LP priority)
_ -> fail $ "couldn't parse Priority from string " ++ show s
parseJSON value = fail $ "Couldn't parse Priority from value " ++ show value
data LoggerDetails =
LoggerDetails {
loggerName :: String,
loggerLevel :: LogPriority
}
instance FromJSON LoggerDetails where
parseJSON (Object details) = do
loggerName <- details .: "logger"
loggerLevel <- details .: "level"
return LoggerDetails {loggerName, loggerLevel}
parseJSON value =
fail $ "Couldn't parse logger details from value " ++ show value