breve/src/Main.hs

{-# 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)