module JmlSvc.Web
( Config(..)
, flags
, run
) where
import Protolude
import qualified Network.Wai as Wai
import qualified Network.Wai.Handler.Warp as Warp
import qualified Network.Wai.Middleware.RequestLogger as RL
import qualified Options.Applicative as Options
data Config = Config
{ port :: Warp.Port
, accessLogs :: AccessLogs
, debugExceptions :: Bool
} deriving (Eq, Show)
flags :: Options.Parser Config
flags =
Config <$>
Options.option Options.auto (fold [Options.long "port", Options.metavar "PORT", Options.help "Port to listen on"]) <*>
Options.option
(Options.eitherReader parseAccessLogs)
(fold [Options.long "access-logs", Options.help "How to log HTTP access", Options.value Disabled]) <*>
Options.switch (fold [Options.long "debug-exceptions", Options.help "Show exceptions on 500."])
where
parseAccessLogs "none" = pure Disabled
parseAccessLogs "basic" = pure Enabled
parseAccessLogs "dev" = pure DevMode
parseAccessLogs _ = throwError "One of 'none', 'basic', or 'dev'"
data AccessLogs
= Disabled
| Enabled
| DevMode
deriving (Eq, Show)
run :: MonadIO io => Config -> Wai.Application -> io ()
run config@Config {..} app = liftIO $ Warp.runSettings settings (logging app)
where
settings = warpSettings config
logging =
case accessLogs of
Disabled -> identity
Enabled -> RL.logStdout
DevMode -> RL.logStdoutDev
warpSettings :: Config -> Warp.Settings
warpSettings Config {..} =
Warp.setOnExceptionResponse exceptionHandler . Warp.setBeforeMainLoop printPort . Warp.setPort port $
Warp.defaultSettings
where
printPort = putText $ "Listening on: " <> show port
exceptionHandler
| debugExceptions = Warp.exceptionResponseForDebug
| otherwise = Warp.defaultOnExceptionResponse