module Yesod.Default.Main
( defaultMain
, defaultRunner
, defaultDevelApp
, defaultDevelAppWith
) where
import Yesod.Core
import Yesod.Default.Config
import Yesod.Logger (Logger, makeLogger, logString, logLazyText, flushLogger)
import Network.Wai (Application)
import Network.Wai.Handler.Warp (run)
import Network.Wai.Middleware.Debug (debugHandle)
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)
#ifndef WINDOWS
import qualified System.Posix.Signals as Signal
import Control.Concurrent (forkIO, killThread)
import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)
#endif
defaultMain :: (Show e, Read e) => IO (AppConfig e) -> (AppConfig e -> Logger -> (Application -> IO ()) -> IO ()) -> IO ()
defaultMain load withSite = do
config <- load
logger <- makeLogger
withSite config logger $ run (appPort config)
defaultRunner :: (YesodDispatch y y, Yesod y)
=> (Application -> IO a)
-> y
-> IO ()
defaultRunner f h = do
exists <- doesDirectoryExist staticCache
when exists $ removeDirectoryRecursive staticCache
#ifdef WINDOWS
toWaiAppPlain h >>= f . middlewares >> return ()
#else
tid <- forkIO $ toWaiAppPlain h >>= f . middlewares >> return ()
flag <- newEmptyMVar
_ <- Signal.installHandler Signal.sigINT (Signal.CatchOnce $ do
putStrLn "Caught an interrupt"
killThread tid
putMVar flag ()) Nothing
takeMVar flag
#endif
where
middlewares = gzip' gset . jsonp . autohead
gset = def { gzipFiles = GzipCacheFolder staticCache }
staticCache = ".static-cache"
defaultDevelApp :: (AppConfig DefaultEnv -> Logger -> (Application -> IO ()) -> IO ())
-> ((Int, Application) -> IO ())
-> IO ()
defaultDevelApp = defaultDevelAppWith loadDevelopmentConfig
defaultDevelAppWith :: (Show e, Read e)
=> IO (AppConfig e)
-> (AppConfig e -> Logger -> (Application -> IO ()) -> IO ())
-> ((Int, Application) -> IO ()) -> IO ()
defaultDevelAppWith load withSite f = do
conf <- load
logger <- makeLogger
let p = appPort conf
logString logger $ "Devel application launched, listening on port " ++ show p
withSite conf logger $ \app -> f (p, debugHandle (logHandle logger) app)
flushLogger logger
where
logHandle logger msg = logLazyText logger msg >> flushLogger logger