76 lines
2.0 KiB
Haskell
76 lines
2.0 KiB
Haskell
{-# LANGUAGE RecordWildCards #-}
|
|
|
|
{-|
|
|
This is the main module, which actually
|
|
run the Breve webserver.
|
|
-}
|
|
module Main where
|
|
|
|
-- Breve modules
|
|
import Application (AppEnv(..), breve, emptyApp)
|
|
import Breve.Settings (AppSettings(..), settings)
|
|
import Breve.UrlTable
|
|
|
|
-- Data conversions
|
|
import Data.String (IsString(..))
|
|
import Data.Maybe (listToMaybe)
|
|
import Data.Text (unpack)
|
|
|
|
-- IO
|
|
import Data.Text.IO as T
|
|
import Control.Exception as E
|
|
import Control.Monad (when, void)
|
|
import Control.Concurrent (forkIO)
|
|
import System.Environment (getArgs)
|
|
|
|
-- Web server
|
|
import Servant (Application)
|
|
import Network.Wai.Handler.Warp (run, defaultSettings, setPort, setHost)
|
|
import Network.Wai.Handler.WarpTLS (runTLS)
|
|
|
|
-- Middlewares
|
|
import Network.Wai.Middleware.RequestLogger (logStdout)
|
|
import Network.Wai.Middleware.ForceSSL (forceSSL)
|
|
|
|
|
|
-- * Helpers
|
|
|
|
-- | Runs Breve on the Warp webserver
|
|
runApp :: AppSettings -> Application -> IO ()
|
|
runApp (AppSettings{..}) =
|
|
runTLS tlsSettings warpSettings
|
|
where
|
|
host = unpack bindHost
|
|
warpSettings = setPort bindPort $
|
|
setHost (fromString host) defaultSettings
|
|
|
|
-- | Main
|
|
--
|
|
-- Reads the configuration (given as the unique cli argument),
|
|
-- sets things accordingly and runs the webserver.
|
|
main :: IO ()
|
|
main = do
|
|
configPath <- fmap listToMaybe getArgs
|
|
config@(AppSettings{..}) <- settings configPath
|
|
table <- load urlTable
|
|
|
|
-- Redirect from HTTP to HTTPS when listening
|
|
-- on the standard port
|
|
when (bindPort == 443) $ void $
|
|
forkIO (run 80 $ forceSSL emptyApp)
|
|
|
|
-- Save the table just before exiting
|
|
let exit E.UserInterrupt = save table urlTable
|
|
exit e = throwIO e
|
|
|
|
-- Middlewares are functions (Application -> Application).
|
|
-- We use one here to add requests
|
|
let middlewares = logStdout
|
|
|
|
-- The environment needed while running
|
|
let env = AppEnv bindUrl table staticDir
|
|
|
|
handle exit $ do
|
|
T.putStrLn ("Serving on " <> bindUrl)
|
|
runApp config (middlewares $ breve env)
|