module Snap.Http.Server.Config
( Config(..)
, readConfigFromCmdLineArgs
) where
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import Data.ByteString.Internal (c2w)
import Data.ByteString.Char8 ()
import Data.Maybe
import Data.Monoid
import System.Console.GetOpt
import System.Environment
import System.Exit
import System.IO
data Config = Config
{ localHostname :: !ByteString
, bindAddress :: !ByteString
, listenPort :: !Int
, accessLog :: !(Maybe FilePath)
, errorLog :: !(Maybe FilePath)
} deriving (Show)
data Flag = Flag
{ flagLocalHost :: Maybe String
, flagBindAddress :: Maybe String
, flagPort :: Maybe Int
, flagAccessLog :: Maybe String
, flagErrorLog :: Maybe String
, flagUsage :: Bool
}
instance Monoid Flag where
mempty = Flag Nothing Nothing Nothing Nothing Nothing False
(Flag a1 b1 c1 d1 e1 f1) `mappend` (Flag a2 b2 c2 d2 e2 f2) =
Flag (getLast $ Last a1 `mappend` Last a2)
(getLast $ Last b1 `mappend` Last b2)
(getLast $ Last c1 `mappend` Last c2)
(getLast $ Last d1 `mappend` Last d2)
(getLast $ Last e1 `mappend` Last e2)
(f1 || f2)
flagLH :: String -> Flag
flagLH s = mempty { flagLocalHost = Just s }
flagBA :: String -> Flag
flagBA s = mempty { flagBindAddress = Just s }
flagPt :: String -> Flag
flagPt p = mempty { flagPort = Just (read p) }
flagAL :: String -> Flag
flagAL s = mempty { flagAccessLog = Just s }
flagEL :: String -> Flag
flagEL s = mempty { flagErrorLog = Just s }
flagHelp :: Flag
flagHelp = mempty { flagUsage = True }
fromStr :: String -> ByteString
fromStr = B.pack . map c2w
flags2config :: Flag -> Config
flags2config (Flag a b c d e _) =
Config (maybe "localhost" fromStr a)
(maybe "*" fromStr b)
(fromMaybe 8888 c)
d
e
options :: [OptDescr Flag]
options =
[ Option "l" ["localHostname"]
(ReqArg flagLH "STR")
"local hostname, default 'localhost'"
, Option "p" ["listenPort"]
(ReqArg flagPt "NUM")
"port to listen on, default 8888"
, Option "b" ["bindAddress"]
(ReqArg flagBA "STR")
"address to bind to, default '*'"
, Option "a" ["accessLog"]
(ReqArg flagAL "STR")
"access log in the 'combined' format, optional"
, Option "e" ["errorLog"]
(ReqArg flagEL "STR")
"error log, optional"
, Option "h" ["help"]
(NoArg flagHelp)
"display this usage statement" ]
readConfigFromCmdLineArgs :: String
-> IO Config
readConfigFromCmdLineArgs appName = do
argv <- getArgs
progName <- getProgName
case getOpt Permute options argv of
(f,_,[] ) -> withFlags progName f
(_,_,errs) -> bombout progName errs
where
bombout progName errs = do
let hdr = appName ++ "\n\nUsage: " ++ progName ++ " [OPTIONS]"
let msg = concat errs ++ usageInfo hdr options
hPutStrLn stderr msg
exitFailure
withFlags progName fs = do
let f = mconcat fs
if flagUsage f
then bombout progName []
else return $ flags2config f