{-# 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
config <- IO (AppConfig env extra)
load
app <- getApp config
runSettings
( setPort (appPort config)
$ setHost (appHost config)
$ defaultSettings
) 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
config <- IO (AppConfig env extra)
load
(app, logFunc) <- getApp config
runSettings
( setPort (appPort config)
$ setHost (appHost config)
$ setOnException (const $ \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
([Char] -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr ([Char] -> LogStr) -> [Char] -> LogStr
forall a b. (a -> b) -> a -> b
$ [Char]
"Exception from Warp: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ SomeException -> [Char]
forall a. Show a => a -> [Char]
show SomeException
e))
$ defaultSettings
) 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
exists <- [Char] -> IO Bool
doesDirectoryExist [Char]
staticCache
when exists $ removeDirectoryRecursive staticCache
#ifdef WINDOWS
f (middlewares app)
#else
tid <- forkIO $ f (middlewares app) >> return ()
flag <- newEmptyMVar
_ <- Signal.installHandler Signal.sigINT (Signal.CatchOnce $ do
putStrLn "Caught an interrupt"
killThread tid
putMVar flag ()) Nothing
takeMVar 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 = GzipCacheFolder 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
conf <- IO (AppConfig env extra)
load
env <- getEnvironment
let 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
$ [Char] -> [([Char], [Char])] -> Maybe [Char]
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup [Char]
"PORT" [([Char], [Char])]
env Maybe [Char] -> ([Char] -> Maybe Port) -> Maybe Port
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Char] -> Maybe Port
forall a. Read a => [Char] -> Maybe a
readMaybe
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
$ [Char] -> [([Char], [Char])] -> Maybe [Char]
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup [Char]
"DISPLAY_PORT" [([Char], [Char])]
env Maybe [Char] -> ([Char] -> Maybe Port) -> Maybe Port
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Char] -> Maybe Port
forall a. Read a => [Char] -> Maybe a
readMaybe
putStrLn $ "Devel application launched: http://localhost:" ++ show pdisplay
app <- getApp conf
return (p, app)