module Hyena.Config
( Config(..),
configFromFlags,
defaultConfig
) where
import Control.Monad (when)
import Data.Monoid (Monoid(..))
import System.Console.GetOpt
import System.Directory (createDirectoryIfMissing, getCurrentDirectory)
import System.Environment (getArgs, getProgName)
import System.Exit (exitFailure)
import System.FilePath ((</>), dropFileName)
import System.IO (BufferMode(..), Handle, IOMode(..), hSetBuffering, openFile,
stderr)
data Config = Config
{ address :: String
, daemonize :: Bool
, debug :: Bool
, logHandle :: Handle
, port :: Int
} deriving Show
flagsToConfig :: Flags -> IO Config
flagsToConfig flags = do
when (flag flagDaemonize) $
createDirectoryIfMissing True $ dropFileName (flag flagLogFile)
logHandle' <- if flag flagDaemonize
then openFile (flag flagLogFile) AppendMode
else return stderr
hSetBuffering logHandle' LineBuffering
return Config
{ address = flag flagAddress
, daemonize = flag flagDaemonize
, debug = flag flagDebug
, logHandle = logHandle'
, port = flag flagPort
}
where flag field = fromFlag $ field flags
configFromFlags :: IO Config
configFromFlags = do
argv <- getArgs
cwd <- getCurrentDirectory
progName <- getProgName
case parseArgs argv progName of
Left err -> putStr err >> exitFailure
Right flags -> flagsToConfig $ defaultFlags cwd `mappend` flags
defaultConfig :: IO Config
defaultConfig = do
cwd <- getCurrentDirectory
flagsToConfig $ defaultFlags cwd
data Flag a = Flag a | NoFlag deriving Show
instance Functor Flag where
fmap f (Flag x) = Flag (f x)
fmap _ NoFlag = NoFlag
instance Monoid (Flag a) where
mempty = NoFlag
_ `mappend` f@(Flag _) = f
f `mappend` NoFlag = f
fromFlag :: Flag a -> a
fromFlag (Flag x) = x
fromFlag NoFlag = error "fromFlag NoFlag"
data Flags = Flags
{ flagAddress :: Flag String
, flagDaemonize :: Flag Bool
, flagDebug :: Flag Bool
, flagLogFile :: Flag FilePath
, flagPort :: Flag Int
} deriving Show
defaultFlags :: FilePath -> Flags
defaultFlags cwd =
Flags { flagAddress = Flag "0.0.0.0"
, flagDaemonize = Flag False
, flagDebug = Flag False
, flagLogFile = Flag $ cwd </> "log/hyena.log"
, flagPort = Flag 3000
}
emptyFlags :: Flags
emptyFlags = mempty
instance Monoid Flags where
mempty = Flags
{ flagAddress = mempty
, flagDaemonize = mempty
, flagDebug = mempty
, flagLogFile = mempty
, flagPort = mempty
}
mappend a b = Flags
{ flagAddress = combine flagAddress
, flagDaemonize = combine flagDaemonize
, flagDebug = combine flagDebug
, flagLogFile = combine flagLogFile
, flagPort = combine flagPort
}
where combine field = field a `mappend` field b
flagToPort :: String -> Int
flagToPort str =
case reads str of
[(i, "")] -> i
_ -> error $ "--port: invalid port `" ++ str ++ "'"
options :: [OptDescr (Flags -> Flags)]
options =
[Option "a" ["address"]
(reqArgFlag "ADDRESS" flagAddress
(\v flags -> flags {flagAddress = v}))
"bind to ADDRESS (hostname or IP) on localhost"
,Option "d" ["daemonize"]
(trueArg flagDaemonize (\v flags -> flags {flagDaemonize = v}))
"run in the background"
,Option "B" ["debug"]
(trueArg flagDebug (\v flags -> flags {flagDebug = v}))
"print lots of debug information"
,Option "l" ["log"]
(reqArgFlag "FILE" flagLogFile
(\v flags -> flags {flagLogFile = v}))
"dump log messages to FILE when daemonized"
,Option "p" ["port"]
(reqArg "PORT" (Flag . flagToPort)
flagPort (\v flags -> flags {flagPort = v}))
"bind to PORT on localhost"
]
parseArgs :: [String] -> String -> Either String Flags
parseArgs argv progName =
case getOpt Permute options argv of
(flags, _, []) -> Right $ foldl (flip id) emptyFlags flags
(_, _, errs) -> Left $ concat errs ++ usageInfo header options
where header = "Usage: " ++ progName ++ " [OPTION]..."
reqArg :: (Monoid a) =>
String -> (String -> a) -> (t -> a) -> (a -> t -> t1)
-> ArgDescr (t -> t1)
reqArg name mkFlag get set =
ReqArg (\v flags -> set (get flags `mappend` mkFlag v) flags) name
noArg :: (Monoid a) => a -> (t -> a) -> (a -> t -> t1) -> ArgDescr (t -> t1)
noArg flag get set =
NoArg (\flags -> set (get flags `mappend` flag) flags)
trueArg :: (t -> Flag Bool) -> (Flag Bool -> t -> t1)
-> ArgDescr (t -> t1)
trueArg = noArg (Flag True)
reqArgFlag :: String -> (t -> Flag String) -> (Flag String -> t -> t1)
-> ArgDescr (t -> t1)
reqArgFlag name = reqArg name Flag