{-# 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
defaultMain :: IO (AppConfig env extra)
-> (AppConfig env extra -> IO Application)
-> IO ()
defaultMain :: forall env extra.
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 (forall environment extra. AppConfig environment extra -> Port
appPort AppConfig env extra
config)
forall a b. (a -> b) -> a -> b
$ HostPreference -> Settings -> Settings
setHost (forall environment extra.
AppConfig environment extra -> HostPreference
appHost AppConfig env extra
config)
forall a b. (a -> b) -> a -> b
$ Settings
defaultSettings
) Application
app
type LogFunc = Loc -> LogSource -> LogLevel -> LogStr -> IO ()
defaultMainLog :: IO (AppConfig env extra)
-> (AppConfig env extra -> IO (Application, LogFunc))
-> IO ()
defaultMainLog :: forall env extra.
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 (forall environment extra. AppConfig environment extra -> Port
appPort AppConfig env extra
config)
forall a b. (a -> b) -> a -> b
$ HostPreference -> Settings -> Settings
setHost (forall environment extra.
AppConfig environment extra -> HostPreference
appHost AppConfig env extra
config)
forall a b. (a -> b) -> a -> b
$ (Maybe Request -> SomeException -> IO ()) -> Settings -> Settings
setOnException (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ \SomeException
e -> forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SomeException -> Bool
shouldLog' SomeException
e) forall a b. (a -> b) -> a -> b
$ LogFunc
logFunc
$(qLocation >>= liftLoc)
LogSource
"yesod"
LogLevel
LevelError
(forall msg. ToLogStr msg => msg -> LogStr
toLogStr forall a b. (a -> b) -> a -> b
$ [Char]
"Exception from Warp: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show SomeException
e))
forall a b. (a -> b) -> a -> b
$ Settings
defaultSettings
) Application
app
where
shouldLog' :: SomeException -> Bool
shouldLog' = SomeException -> Bool
Warp.defaultShouldDisplayException
defaultRunner :: (Application -> IO ()) -> Application -> IO ()
defaultRunner :: (Application -> IO ()) -> Application -> IO ()
defaultRunner Application -> IO ()
f Application
app = do
Bool
exists <- [Char] -> IO Bool
doesDirectoryExist [Char]
staticCache
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
exists forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
removeDirectoryRecursive [Char]
staticCache
#ifdef WINDOWS
f (middlewares app)
#else
ThreadId
tid <- IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ Application -> IO ()
f (Application -> Application
middlewares Application
app) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return ()
MVar ()
flag <- forall a. IO (MVar a)
newEmptyMVar
Handler
_ <- Signal -> Handler -> Maybe SignalSet -> IO Handler
Signal.installHandler Signal
Signal.sigINT (IO () -> Handler
Signal.CatchOnce forall a b. (a -> b) -> a -> b
$ do
[Char] -> IO ()
putStrLn [Char]
"Caught an interrupt"
ThreadId -> IO ()
killThread ThreadId
tid
forall a. MVar a -> a -> IO ()
putMVar MVar ()
flag ()) forall a. Maybe a
Nothing
forall a. MVar a -> IO a
takeMVar MVar ()
flag
#endif
where
middlewares :: Application -> Application
middlewares = GzipSettings -> Application -> Application
gzip GzipSettings
gset forall b c a. (b -> c) -> (a -> b) -> a -> c
. Application -> Application
jsonp forall b c a. (b -> c) -> (a -> b) -> a -> c
. Application -> Application
autohead
gset :: GzipSettings
gset = forall a. Default a => a
def { gzipFiles :: GzipFiles
gzipFiles = [Char] -> GzipFiles
GzipCacheFolder [Char]
staticCache }
staticCache :: [Char]
staticCache = [Char]
".static-cache"
defaultDevelApp
:: IO (AppConfig env extra)
-> (AppConfig env extra -> IO Application)
-> IO (Int, Application)
defaultDevelApp :: forall env extra.
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
[([Char], [Char])]
env <- IO [([Char], [Char])]
getEnvironment
let p :: Port
p = forall a. a -> Maybe a -> a
fromMaybe (forall environment extra. AppConfig environment extra -> Port
appPort AppConfig env extra
conf) forall a b. (a -> b) -> a -> b
$ forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup [Char]
"PORT" [([Char], [Char])]
env forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. Read a => [Char] -> Maybe a
readMaybe
pdisplay :: Port
pdisplay = forall a. a -> Maybe a -> a
fromMaybe Port
p forall a b. (a -> b) -> a -> b
$ forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup [Char]
"DISPLAY_PORT" [([Char], [Char])]
env forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. Read a => [Char] -> Maybe a
readMaybe
[Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ [Char]
"Devel application launched: http://localhost:" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Port
pdisplay
Application
app <- AppConfig env extra -> IO Application
getApp AppConfig env extra
conf
forall (m :: * -> *) a. Monad m => a -> m a
return (Port
p, Application
app)