From d84b462a711ce95593ff05a7581e722562c3835a Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 14 Mar 2017 01:06:28 +0100 Subject: Implement old bar.hs --- Application.hs | 180 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 180 insertions(+) create mode 100644 Application.hs (limited to 'Application.hs') diff --git a/Application.hs b/Application.hs new file mode 100644 index 0000000..048a316 --- /dev/null +++ b/Application.hs @@ -0,0 +1,180 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Application + ( getApplicationDev + , appMain + , develMain + , makeFoundation + , makeLogWare + -- * for DevelMain + , getApplicationRepl + , shutdownApp + -- * for GHCI + , handler + , db + ) where + +import Control.Monad.Logger (liftLoc, runLoggingT) +import Database.Persist.Postgresql (createPostgresqlPool, pgConnStr, + pgPoolSize, runSqlPool) +import Import +import Language.Haskell.TH.Syntax (qLocation) +import Network.Wai (Middleware) +import Network.Wai.Handler.Warp (Settings, defaultSettings, + defaultShouldDisplayException, + runSettings, setHost, + setOnException, setPort, getPort) +import Network.Wai.Middleware.RequestLogger (Destination (Logger), + IPAddrSource (..), + OutputFormat (..), destination, + mkRequestLogger, outputFormat) +import System.Log.FastLogger (defaultBufSize, newStdoutLoggerSet, + toLogStr) + +-- Import all relevant handler modules here. +-- Don't forget to add new modules to your cabal file! +import Handler.InventoryListing +import Handler.UpdateItem +import Handler.OpenItem +import Handler.DeleteItem +import Handler.Item + +-- This line actually creates our YesodDispatch instance. It is the second half +-- of the call to mkYesodData which occurs in Foundation.hs. Please see the +-- comments there for more details. +mkYesodDispatch "App" resourcesApp + +-- | This function allocates resources (such as a database connection pool), +-- performs initialization and returns a foundation datatype value. This is also +-- the place to put your migrate statements to have automatic database +-- migrations handled by Yesod. +makeFoundation :: AppSettings -> IO App +makeFoundation appSettings = do + -- Some basic initializations: HTTP connection manager, logger, and static + -- subsite. + appHttpManager <- newManager + appLogger <- newStdoutLoggerSet defaultBufSize >>= makeYesodLogger + + -- We need a log function to create a connection pool. We need a connection + -- pool to create our foundation. And we need our foundation to get a + -- logging function. To get out of this loop, we initially create a + -- temporary foundation without a real connection pool, get a log function + -- from there, and then create the real foundation. + let mkFoundation appConnPool = App { appStatic = eStatic, ..} + -- The App {..} syntax is an example of record wild cards. For more + -- information, see: + -- https://ocharles.org.uk/blog/posts/2014-12-04-record-wildcards.html + tempFoundation = mkFoundation $ error "connPool forced in tempFoundation" + logFunc = messageLoggerSource tempFoundation appLogger + + -- Create the database connection pool + pool <- flip runLoggingT logFunc $ createPostgresqlPool + (pgConnStr $ appDatabaseConf appSettings) + (pgPoolSize $ appDatabaseConf appSettings) + + -- Perform database migration using our application's logging settings. + runLoggingT (runSqlPool (runMigration migrateAll) pool) logFunc + + -- Return the foundation + return $ mkFoundation pool + +-- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and +-- applying some additional middlewares. +makeApplication :: App -> IO Application +makeApplication foundation = do + logWare <- makeLogWare foundation + -- Create the WAI application and apply middlewares + appPlain <- toWaiAppPlain foundation + return $ logWare $ defaultMiddlewaresNoLogging appPlain + +makeLogWare :: App -> IO Middleware +makeLogWare foundation = + mkRequestLogger def + { outputFormat = + if appDetailedRequestLogging $ appSettings foundation + then Detailed True + else Apache + (if appIpFromHeader $ appSettings foundation + then FromFallback + else FromSocket) + , destination = Logger $ loggerSet $ appLogger foundation + } + + +-- | Warp settings for the given foundation value. +warpSettings :: App -> Settings +warpSettings foundation = + setPort (appPort $ appSettings foundation) + $ setHost (appHost $ appSettings foundation) + $ setOnException (\_req e -> + when (defaultShouldDisplayException e) $ messageLoggerSource + foundation + (appLogger foundation) + $(qLocation >>= liftLoc) + "yesod" + LevelError + (toLogStr $ "Exception from Warp: " ++ show e)) + defaultSettings + +-- | For yesod devel, return the Warp settings and WAI Application. +getApplicationDev :: IO (Settings, Application) +getApplicationDev = do + settings <- getAppSettings + foundation <- makeFoundation settings + wsettings <- getDevSettings $ warpSettings foundation + app <- makeApplication foundation + return (wsettings, app) + +getAppSettings :: IO AppSettings +getAppSettings = loadYamlSettings [configSettingsYml] [] useEnv + +-- | main function for use by yesod devel +develMain :: IO () +develMain = develMainHelper getApplicationDev + +-- | The @main@ function for an executable running this site. +appMain :: IO () +appMain = do + -- Get the settings from all relevant sources + settings <- loadYamlSettingsArgs + -- fall back to compile-time values, set to [] to require values at runtime + [configSettingsYmlValue] + + -- allow environment variables to override + useEnv + + -- Generate the foundation from the settings + foundation <- makeFoundation settings + + -- Generate a WAI Application from the foundation + app <- makeApplication foundation + + -- Run the application with Warp + runSettings (warpSettings foundation) app + + +-------------------------------------------------------------- +-- Functions for DevelMain.hs (a way to run the app from GHCi) +-------------------------------------------------------------- +getApplicationRepl :: IO (Int, App, Application) +getApplicationRepl = do + settings <- getAppSettings + foundation <- makeFoundation settings + wsettings <- getDevSettings $ warpSettings foundation + app1 <- makeApplication foundation + return (getPort wsettings, foundation, app1) + +shutdownApp :: App -> IO () +shutdownApp _ = return () + + +--------------------------------------------- +-- Functions for use in development with GHCi +--------------------------------------------- + +-- | Run a handler +handler :: Handler a -> IO a +handler h = getAppSettings >>= makeFoundation >>= flip unsafeHandler h + +-- | Run DB queries +db :: ReaderT SqlBackend (HandlerT App IO) a -> IO a +db = handler . runDB -- cgit v1.2.3