{-# LANGUAGE CPP                #-}
{-# LANGUAGE OverloadedStrings  #-}
{-# LANGUAGE TemplateHaskell    #-}
module Yesod.Default.Main
    ( defaultMain
    , defaultMainLog
    , defaultRunner
    , defaultDevelApp
    , LogFunc
    ) where

import Yesod.Default.Config
import Network.Wai (Application)
import Network.Wai.Handler.Warp
    (runSettings, defaultSettings, setPort, setHost, setOnException)
import qualified Network.Wai.Handler.Warp as Warp
import System.Directory (doesDirectoryExist, removeDirectoryRecursive)
import Network.Wai.Middleware.Gzip (gzip, GzipFiles (GzipCacheFolder), gzipFiles, def)
import Network.Wai.Middleware.Autohead (autohead)
import Network.Wai.Middleware.Jsonp (jsonp)
import Control.Monad (when)
import System.Environment (getEnvironment)
import Data.Maybe (fromMaybe)
import Text.Read (readMaybe)
import Control.Monad.Logger (Loc, LogSource, LogLevel (LevelError), liftLoc)
import System.Log.FastLogger (LogStr, toLogStr)
import Language.Haskell.TH.Syntax (qLocation)

#ifndef WINDOWS
import qualified System.Posix.Signals as Signal
import Control.Concurrent (forkIO, killThread)
import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)
#endif

-- | Run your app, taking environment and port settings from the
--   commandline.
--
--   @'fromArgs'@ helps parse a custom configuration
--
--   > main :: IO ()
--   > main = defaultMain (fromArgs parseExtra) makeApplication
--
defaultMain :: IO (AppConfig env extra)
            -> (AppConfig env extra -> IO Application)
            -> IO ()
defaultMain :: IO (AppConfig env extra)
-> (AppConfig env extra -> IO Application) -> IO ()
defaultMain IO (AppConfig env extra)
load AppConfig env extra -> IO Application
getApp = do
    AppConfig env extra
config <- IO (AppConfig env extra)
load
    Application
app <- AppConfig env extra -> IO Application
getApp AppConfig env extra
config
    Settings -> Application -> IO ()
runSettings 
        ( Port -> Settings -> Settings
setPort (AppConfig env extra -> Port
forall environment extra. AppConfig environment extra -> Port
appPort AppConfig env extra
config)
        (Settings -> Settings) -> Settings -> Settings
forall a b. (a -> b) -> a -> b
$ HostPreference -> Settings -> Settings
setHost (AppConfig env extra -> HostPreference
forall environment extra.
AppConfig environment extra -> HostPreference
appHost AppConfig env extra
config)
        (Settings -> Settings) -> Settings -> Settings
forall a b. (a -> b) -> a -> b
$ Settings
defaultSettings
        ) Application
app

type LogFunc = Loc -> LogSource -> LogLevel -> LogStr -> IO ()

-- | Same as @defaultMain@, but gets a logging function back as well as an
-- @Application@ to install Warp exception handlers.
--
-- Since 1.2.5
defaultMainLog :: IO (AppConfig env extra)
               -> (AppConfig env extra -> IO (Application, LogFunc))
               -> IO ()
defaultMainLog :: IO (AppConfig env extra)
-> (AppConfig env extra -> IO (Application, LogFunc)) -> IO ()
defaultMainLog IO (AppConfig env extra)
load AppConfig env extra -> IO (Application, LogFunc)
getApp = do
    AppConfig env extra
config <- IO (AppConfig env extra)
load
    (Application
app, LogFunc
logFunc) <- AppConfig env extra -> IO (Application, LogFunc)
getApp AppConfig env extra
config
    Settings -> Application -> IO ()
runSettings 
        ( Port -> Settings -> Settings
setPort (AppConfig env extra -> Port
forall environment extra. AppConfig environment extra -> Port
appPort AppConfig env extra
config)
        (Settings -> Settings) -> Settings -> Settings
forall a b. (a -> b) -> a -> b
$ HostPreference -> Settings -> Settings
setHost (AppConfig env extra -> HostPreference
forall environment extra.
AppConfig environment extra -> HostPreference
appHost AppConfig env extra
config)
        (Settings -> Settings) -> Settings -> Settings
forall a b. (a -> b) -> a -> b
$ (Maybe Request -> SomeException -> IO ()) -> Settings -> Settings
setOnException ((SomeException -> IO ()) -> Maybe Request -> SomeException -> IO ()
forall a b. a -> b -> a
const ((SomeException -> IO ())
 -> Maybe Request -> SomeException -> IO ())
-> (SomeException -> IO ())
-> Maybe Request
-> SomeException
-> IO ()
forall a b. (a -> b) -> a -> b
$ \SomeException
e -> Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SomeException -> Bool
shouldLog' SomeException
e) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ LogFunc
logFunc
            $(qLocation >>= liftLoc)
            LogSource
"yesod"
            LogLevel
LevelError
            (String -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr (String -> LogStr) -> String -> LogStr
forall a b. (a -> b) -> a -> b
$ String
"Exception from Warp: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SomeException -> String
forall a. Show a => a -> String
show SomeException
e))
        (Settings -> Settings) -> Settings -> Settings
forall a b. (a -> b) -> a -> b
$ Settings
defaultSettings
        ) Application
app
  where
    shouldLog' :: SomeException -> Bool
shouldLog' = SomeException -> Bool
Warp.defaultShouldDisplayException

-- | Run your application continuously, listening for SIGINT and exiting
--   when received
--
--   > withYourSite :: AppConfig DefaultEnv -> Logger -> (Application -> IO a) -> IO ()
--   > withYourSite conf logger f = do
--   >     Settings.withConnectionPool conf $ \p -> do
--   >         runConnectionPool (runMigration yourMigration) p
--   >         defaultRunner f $ YourSite conf logger p
defaultRunner :: (Application -> IO ()) -> Application -> IO ()
defaultRunner :: (Application -> IO ()) -> Application -> IO ()
defaultRunner Application -> IO ()
f Application
app = do
    -- clear the .static-cache so we don't have stale content
    Bool
exists <- String -> IO Bool
doesDirectoryExist String
staticCache
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
exists (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
removeDirectoryRecursive String
staticCache
#ifdef WINDOWS
    f (middlewares app)
#else
    ThreadId
tid <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ Application -> IO ()
f (Application -> Application
middlewares Application
app) IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    MVar ()
flag <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
    Handler
_ <- Signal -> Handler -> Maybe SignalSet -> IO Handler
Signal.installHandler Signal
Signal.sigINT (IO () -> Handler
Signal.CatchOnce (IO () -> Handler) -> IO () -> Handler
forall a b. (a -> b) -> a -> b
$ do
        String -> IO ()
putStrLn String
"Caught an interrupt"
        ThreadId -> IO ()
killThread ThreadId
tid
        MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
flag ()) Maybe SignalSet
forall a. Maybe a
Nothing
    MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
flag
#endif
  where
    middlewares :: Application -> Application
middlewares = GzipSettings -> Application -> Application
gzip GzipSettings
gset (Application -> Application)
-> (Application -> Application) -> Application -> Application
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Application -> Application
jsonp (Application -> Application)
-> (Application -> Application) -> Application -> Application
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Application -> Application
autohead

    gset :: GzipSettings
gset = GzipSettings
forall a. Default a => a
def { gzipFiles :: GzipFiles
gzipFiles = String -> GzipFiles
GzipCacheFolder String
staticCache }
    staticCache :: String
staticCache = String
".static-cache"

-- | Run your development app using a custom environment type and loader
--   function
defaultDevelApp
    :: IO (AppConfig env extra) -- ^ A means to load your development @'AppConfig'@
    -> (AppConfig env extra -> IO Application) -- ^ Get your @Application@
    -> IO (Int, Application)
defaultDevelApp :: IO (AppConfig env extra)
-> (AppConfig env extra -> IO Application)
-> IO (Port, Application)
defaultDevelApp IO (AppConfig env extra)
load AppConfig env extra -> IO Application
getApp = do
    AppConfig env extra
conf   <- IO (AppConfig env extra)
load
    [(String, String)]
env <- IO [(String, String)]
getEnvironment
    let p :: Port
p = Port -> Maybe Port -> Port
forall a. a -> Maybe a -> a
fromMaybe (AppConfig env extra -> Port
forall environment extra. AppConfig environment extra -> Port
appPort AppConfig env extra
conf) (Maybe Port -> Port) -> Maybe Port -> Port
forall a b. (a -> b) -> a -> b
$ String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"PORT" [(String, String)]
env Maybe String -> (String -> Maybe Port) -> Maybe Port
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Maybe Port
forall a. Read a => String -> Maybe a
readMaybe
        pdisplay :: Port
pdisplay = Port -> Maybe Port -> Port
forall a. a -> Maybe a -> a
fromMaybe Port
p (Maybe Port -> Port) -> Maybe Port -> Port
forall a b. (a -> b) -> a -> b
$ String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"DISPLAY_PORT" [(String, String)]
env Maybe String -> (String -> Maybe Port) -> Maybe Port
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Maybe Port
forall a. Read a => String -> Maybe a
readMaybe
    String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Devel application launched: http://localhost:" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Port -> String
forall a. Show a => a -> String
show Port
pdisplay
    Application
app <- AppConfig env extra -> IO Application
getApp AppConfig env extra
conf
    (Port, Application) -> IO (Port, Application)
forall (m :: * -> *) a. Monad m => a -> m a
return (Port
p, Application
app)