{-# 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 :: 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 ()

-- | 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 :: 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

-- | 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 <- [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"

-- | 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 :: 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)