{-# LANGUAGE CPP                #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE OverloadedStrings  #-}
{-# LANGUAGE TemplateHaskell    #-}
module Yesod.Default.MainTLS
    ( defaultMainTLS
    , defaultMainLogTLS
    , LogFunc
    ) where

import Yesod.Default.Config
import Yesod.Default.Main (LogFunc)
import Network.Wai (Application)
import Network.Wai.Handler.Warp
    (defaultSettings, settingsPort, settingsHost, settingsOnException)
import Network.Wai.Handler.WarpTLS (runTLS, tlsSettings)
import qualified Network.Wai.Handler.Warp as Warp
import Control.Monad (when)
import Control.Monad.Logger (Loc, LogSource, LogLevel (LevelError), liftLoc)
import System.Log.FastLogger (LogStr, toLogStr)
import Language.Haskell.TH.Syntax (qLocation)

-- | Run your app, taking environment, port, and TLS settings from the
--   commandline.
--
--   @'fromArgs'@ helps parse a custom configuration
--
--   > main :: IO ()
--   > main = cert key defaultMain (fromArgs parseExtra) makeApplication
--
defaultMainTLS :: (Show env, Read env)
            => FilePath
            -> FilePath
            -> IO (AppConfig env extra)
            -> (AppConfig env extra -> IO Application)
            -> IO ()
defaultMainTLS cert key load getApp = do
    config <- load
    app <- getApp config
    runTLS (tlsSettings cert key) defaultSettings
        { settingsPort = appPort config
        , settingsHost = appHost config
        } app

-- | Same as @defaultMain@, but gets a logging function back as well as an
-- @Application@ to install Warp exception handlers.
--
defaultMainLogTLS :: (Show env, Read env)
               => FilePath
               -> FilePath
               -> IO (AppConfig env extra)
               -> (AppConfig env extra -> IO (Application, LogFunc))
               -> IO ()
defaultMainLogTLS cert key load getApp = do
    config <- load
    (app, logFunc) <- getApp config
    runTLS (tlsSettings cert key) defaultSettings
        { settingsPort = appPort config
        , settingsHost = appHost config
        , settingsOnException = const $ \e -> when (shouldLog' e) $ logFunc
            $(qLocation >>= liftLoc)
            "yesod"
            LevelError
            (toLogStr $ "Exception from Warp: " ++ show e)
        } app
  where
    shouldLog' = Warp.defaultShouldDisplayException