Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
tree: ee349f001a
Fetching contributors…

Cannot retrieve contributors at this time

213 lines (185 sloc) 7.273 kb
------------------------------------------------------------------------
-- |
-- Module : Hyena.Config
-- Copyright : (c) Johan Tibell 2008
-- License : BSD3-style (see LICENSE)
--
-- Maintainer : johan.tibell@gmail.com
-- Stability : experimental
-- Portability : portable
--
-- This module specifies the server configuration.
--
------------------------------------------------------------------------
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)
-- ---------------------------------------------------------------------
-- Config type
-- | The server configuration.
data Config = Config
{ address :: String
-- ^ Address (hostname or IP) to bind to when listening for
-- connections.
, daemonize :: Bool
-- ^ Run in the background.
, debug :: Bool
-- ^ Print lots of debug information.
, logHandle :: Handle
-- ^ Where to dump log messages in daemon mode.
, port :: Int
-- ^ Port to bind to when listening for connections.
} deriving Show
-- | Converts a set of flags into a server configuration.
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
-- | Reads the server options from the command line. Settings from
-- 'defaultConfig' is used for unspecified options. Creates missing
-- directories as needed for the log file referred to by the @--log@
-- flag when in 'daemonize'd mode.
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
-- | A set of default options most users should use. Creates missing
-- directories as needed for the default log file when in 'daemonize'd
-- mode.
defaultConfig :: IO Config
defaultConfig = do
cwd <- getCurrentDirectory
flagsToConfig $ defaultFlags cwd
-- ---------------------------------------------------------------------
-- Flag type
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"
-- ---------------------------------------------------------------------
-- Config flags
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 =
-- NOTE: If we add a flag to change the working directory it has
-- to be taken into account here.
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
-- ---------------------------------------------------------------------
-- Args parsing
-- | Converts a 'String' containing a port number to an integer and
-- fails with an 'error' if the 'String' contained non-digit
-- characters.
flagToPort :: String -> Int
flagToPort str =
case reads str of
[(i, "")] -> i
_ -> error $ "--port: invalid port `" ++ str ++ "'"
-- | The command line options.
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"
]
-- | Parses the given command line arguments. Returns either the
-- parsed flags or a 'String' explaining the error on failure.
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]..."
-- ---------------------------------------------------------------------
-- GetOpt helpers
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
Jump to Line
Something went wrong with that request. Please try again.