yesod 1.1

Application.hs

@@ -1,31 +1,29 @@
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE TypeFamilies #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 module Application
-    ( getApplication
+    ( makeApplication
     , getApplicationDev
+    , makeFoundation
     ) where
 
-import Foundation hiding (approot)
+import Import
 import Settings
-import Yesod.Static
 import Yesod.Auth
-import Database.Persist.GenericSql
+import Yesod.Default.Config
+import Yesod.Default.Main
+import Yesod.Default.Handlers
+import Network.Wai.Middleware.RequestLogger (logStdout, logStdoutDev)
+import qualified Database.Persist.Store
+import Database.Persist.GenericSql (runMigration)
+import Network.HTTP.Conduit (newManager, def)
 import Data.IORef
-import Data.Text (Text)
-#if PRODUCTION
-import Control.Concurrent (forkIO, threadDelay)
-import Control.Monad (forever)
-#endif
-import Data.Maybe (catMaybes)
+import Control.Monad
+import Control.Concurrent
+import Database.Persist.GenericSql
+import Data.Maybe
 import qualified Data.Set as Set
-import Data.ByteString (ByteString)
-import Network.HTTP.Conduit (newManager, def)
 
 -- Import all relevant handler modules here.
+-- Don't forget to add new modules to your cabal file!
 import Handler.Root
 import Handler.Profile
 import Handler.User
@@ -42,46 +40,56 @@ import Handler.Bling
 import Handler.Poll
 
 -- This line actually creates our YesodSite instance. It is the second half
--- of the call to mkYesodData which occurs in Haskellers.hs. Please see
+-- of the call to mkYesodData which occurs in Foundation.hs. Please see
 -- the comments there for more details.
-mkYesodDispatch "Haskellers" resourcesHaskellers
-
--- Some default handlers that ship with the Yesod site template. You will
--- very rarely need to modify this.
-getFaviconR :: Handler ()
-getFaviconR = sendFile "image/x-icon" "favicon.ico"
-
-getRobotsR :: Handler RepPlain
-getRobotsR = return $ RepPlain $ toContent ("User-agent: *" :: ByteString)
+mkYesodDispatch "App" resourcesApp
 
 -- This function allocates resources (such as a database connection pool),
 -- performs initialization and creates a WAI application. This is also the
 -- place to put your migrate statements to have automatic database
 -- migrations handled by Yesod.
-getApplication :: Text -> IO Application
-getApplication approot = do
-    p <- Settings.createConnectionPool
+makeApplication :: AppConfig DefaultEnv Extra -> IO Application
+makeApplication conf = do
+    foundation <- makeFoundation conf
+    app <- toWaiAppPlain foundation
+    return $ logWare app
+  where
+    logWare   = if development then logStdoutDev
+                               else logStdout
+
+makeFoundation :: AppConfig DefaultEnv Extra -> IO App
+makeFoundation conf = do
     manager <- newManager def
-    flip runConnectionPool p $ runMigration migrateAll
+    s <- staticSite
+    dbconf <- withYamlEnvironment "config/postgresql.yml" (appEnv conf)
+              Database.Persist.Store.loadConfig >>=
+              Database.Persist.Store.applyEnv
+    p <- Database.Persist.Store.createPoolConfig (dbconf :: Settings.PersistConfig)
+    Database.Persist.Store.runPool dbconf (runMigration migrateAll) p
+
     hprofs <- newIORef ([], 0)
     pprofs <- newIORef []
-#if PRODUCTION
-    _ <- forkIO $ forever $ fillProfs p hprofs pprofs
-                         >> threadDelay (1000 * 1000 * 60 * 5)
-#else
-    fillProfs p hprofs pprofs
-#endif
-    s' <- s
-    let h = Haskellers s' p hprofs pprofs approot manager
-    toWaiApp h
-  where
-    s = static Settings.staticdir
+    if production
+        then do
+            _ <- forkIO $ forever $ do
+                _ <- fillProfs p hprofs pprofs
+                threadDelay (1000 * 1000 * 60 * 5)
+            return ()
+        else fillProfs p hprofs pprofs
+
+    return $ App conf s p manager dbconf hprofs pprofs
 
+-- for yesod devel
 getApplicationDev :: IO (Int, Application)
-getApplicationDev = ((,) 3000) `fmap` getApplication "http://localhost:3000"
+getApplicationDev =
+    defaultDevelApp loader makeApplication
+  where
+    loader = loadConfig (configSettings Development)
+        { csParseExtra = parseExtra
+        }
 
 getHomepageProfs :: ConnectionPool -> IO [Profile]
-getHomepageProfs pool = flip runConnectionPool pool $ do
+getHomepageProfs pool = flip runSqlPool pool $ do
     users <-
         selectList [ UserVerifiedEmail ==. True
                    , UserVisible ==. True
@@ -92,7 +100,7 @@ getHomepageProfs pool = flip runConnectionPool pool $ do
     fmap catMaybes $ mapM userToProfile users
 
 getPublicProfs :: ConnectionPool -> IO [Profile]
-getPublicProfs pool = flip runConnectionPool pool $ do
+getPublicProfs pool = flip runSqlPool pool $ do
     users <-
         selectList [ UserVerifiedEmail ==. True
                    , UserVisible ==. True