Scaffolding uses PersistConfig

yesod-core/Yesod/Config.hs

@@ -1,15 +1,11 @@
+{-# LANGUAGE OverloadedStrings #-}
 module Yesod.Config
     ( AppConfig(..)
-    , PostgresConf(..)
-    , SqliteConf(..)
-    , MongoConf(..)
     , loadConfig
-    , loadPostgresql
-    , loadSqlite
-    , loadMongo
+    , withYamlEnvironment
     ) where
 
-import Control.Monad (join, forM)
+import Control.Monad (join)
 import Data.Maybe (fromMaybe)
 import Data.Object
 import Data.Object.Yaml
@@ -25,28 +21,6 @@ data AppConfig e = AppConfig
     , appRoot :: Text
     } deriving (Show)
 
--- separate types means more code here, but it's easier to use in the
--- scaffold
-
--- | Information required to connect to a postgres database
-data PostgresConf = PostgresConf
-    { pgConnStr  :: Text
-    , pgPoolSize :: Int
-    }
-
--- | Information required to connect to a sqlite database
-data SqliteConf = SqliteConf
-    { sqlDatabase :: Text
-    , sqlPoolSize :: Int
-    }
-
--- | Information required to connect to a mongo database
-data MongoConf = MongoConf
-    { mgDatabase :: String
-    , mgHost     :: String
-    , mgPoolSize :: Int
-    }
-
 -- | Load an @'AppConfig'@ from @config\/settings.yml@.
 --
 --   Some examples:
@@ -77,7 +51,8 @@ data MongoConf = MongoConf
 --   > -- automatically.
 --
 loadConfig :: Show e => e -> IO (AppConfig e)
-loadConfig env = withYamlEnvironment "config/settings.yml" env $ \e -> do
+loadConfig env = withYamlEnvironment "config/settings.yml" env $ \e' -> do
+    e <- maybe (fail "Expected map") return $ fromMapping e'
     let mssl     = lookupScalar "ssl"     e
     let mhost    = lookupScalar "host"    e
     let mport    = lookupScalar "port"    e
@@ -89,94 +64,49 @@ loadConfig env = withYamlEnvironment "config/settings.yml" env $ \e -> do
 
     approot <- case (mhost, mapproot) of
         (_        , Just ar) -> return ar
-        (Just host, _      ) -> return $ (if ssl then "https://" else "http://") ++ host ++ (addPort ssl port)
+        (Just host, _      ) -> return $ T.concat
+            [ if ssl then "https://" else "http://"
+            , host
+            , addPort ssl port
+            ]
         _                    -> fail "You must supply either a host or approot"
 
     return $ AppConfig
         { appEnv  = env
         , appPort = port
-        , appRoot = T.pack approot
+        , appRoot = approot
         }
 
     where
-        toBool :: String -> Bool
+        toBool :: Text -> Bool
         toBool = (`elem` ["true", "TRUE", "yes", "YES", "Y", "1"])
 
-        addPort :: Bool -> Int -> String
+        addPort :: Bool -> Int -> Text
         addPort True  443 = ""
         addPort False 80  = ""
-        addPort _     p   = ":" ++ show p
-
--- | Load a @'PostgresConf'@ from @config\/postgresql.yml@.
--- 
---   > Production:
---   >   user: jsmith
---   >   password: secret
---   >   host: localhost
---   >   port: 5432
---   >   database: some_db
---   >   poolsize: 100
---
-loadPostgresql :: Show e => e -> IO PostgresConf
-loadPostgresql env = withYamlEnvironment "config/postgresql.yml" env $ \e -> do
-    db   <- lookupScalar "database" e
-    pool <- safeRead "poolsize" =<< lookupScalar "poolsize" e
-
-    -- TODO: default host/port?
-    connparts <- forM ["user", "password", "host", "port"] $ \k -> do
-        v <- lookupScalar k e
-        return $ k ++ "=" ++ v ++ " "
-
-    conn <- return $ concat connparts
-
-    return $ PostgresConf (T.pack $ conn ++ " dbname=" ++ db) pool
-
--- | Load a @'SqliteConf'@ from @config\/sqlite.yml@.
---
---   > Production:
---   >   database: foo.s3db
---   >   poolsize: 100
---
-loadSqlite :: Show e => e -> IO SqliteConf
-loadSqlite env = withYamlEnvironment "config/sqlite.yml" env $ \e -> do
-    db   <- lookupScalar "database" e
-    pool <- safeRead "poolsize" =<< lookupScalar "poolsize" e
-
-    return $ SqliteConf (T.pack db) pool
-
--- | Load a @'MongoConf'@ from @config\/mongoDB.yml@.
---
---   > Production:
---   >   database: some_db
---   >   host:     localhost
---   >   poolsize: 100
---
-loadMongo :: Show e => e -> IO MongoConf
-loadMongo env = withYamlEnvironment "config/mongoDB.yml" env $ \e -> do
-    db   <- lookupScalar "database" e
-    host <- lookupScalar "host"     e
-    pool <- safeRead "poolsize" =<< lookupScalar "poolsize" e
-
-    return $ MongoConf db host pool
+        addPort _     p   = T.pack $ ':' : show p
 
 -- | Loads the configuration block in the passed file named by the
 --   passed environment, yeilds to the passed function as a mapping.
 --
 --   Errors in the case of a bad load or if your function returns
 --   @Nothing@.
-withYamlEnvironment :: (IsYamlScalar v, Show e)
+withYamlEnvironment :: Show e
                     => FilePath -- ^ the yaml file
                     -> e        -- ^ the environment you want to load
-                    -> ([(String, Object String v)] -> IO a) -- ^ what to do with the mapping
+                    -> (TextObject -> IO a) -- ^ what to do with the mapping
                     -> IO a
 withYamlEnvironment fp env f = do
     obj <- join $ decodeFile fp
     envs <- fromMapping obj
-    conf <- lookupMapping (show env) envs
+    conf <- maybe (fail $ "Could not find environment: " ++ show env) return
+          $ lookup (T.pack $ show env) envs
     f conf
 
 -- | Returns 'fail' if read fails
-safeRead :: Monad m => String -> String -> m Int
-safeRead name s = case reads s of
+safeRead :: Monad m => String -> Text -> m Int
+safeRead name t = case reads s of
     (i, _):_ -> return i
     []       -> fail $ concat ["Invalid value for ", name, ": ", s]
+  where
+    s = T.unpack t

yesod/Scaffolding/Scaffolder.hs

@@ -66,9 +66,9 @@ scaffold = do
     backendC <- prompt $ flip elem $ map (return . toLower . head . show) backends
     let (backend, importGenericDB, dbMonad, importPersist, mkPersistSettings) =
             case backendC of
-                "s" -> (Sqlite,     "GenericSql", "SqlPersist", "Sqlite\n", "sqlSettings")
-                "p" -> (Postgresql, "GenericSql", "SqlPersist", "Postgresql\n", "sqlSettings")
-                "m" -> (MongoDB,    "MongoDB", "Action", "MongoDB\nimport Control.Applicative (Applicative)\n", "MkPersistSettings { mpsBackend = ConT ''Action }")
+                "s" -> (Sqlite,     "GenericSql", "SqlPersist", "Sqlite", "sqlSettings")
+                "p" -> (Postgresql, "GenericSql", "SqlPersist", "Postgresql", "sqlSettings")
+                "m" -> (MongoDB,    "MongoDB", "Action", "MongoDB", "MkPersistSettings { mpsBackend = ConT ''Action }")
                 "t" -> (Tiny, "","","",undefined)
                 _ -> error $ "Invalid backend: " ++ backendC
         (modelImports) = case backend of
@@ -84,7 +84,26 @@ scaffold = do
     let runMigration  =
           case backend of
             MongoDB -> ""
-            _ -> "\n        runConnectionPool (runMigration migrateAll) p"
+            _ -> "\n        Database.Persist.Base.runPool dbconf (runMigration migrateAll) p"
+
+    let importMigration =
+          case backend of
+            MongoDB -> ""
+            _ -> "\nimport Database.Persist.GenericSql (runMigration)"
+
+    let dbConfigFile =
+          case backend of
+            MongoDB -> "mongoDB"
+            Sqlite -> "sqlite"
+            Postgresql -> "postgres"
+            Tiny -> error "Accessing dbConfigFile for Tiny"
+
+    let configPersist =
+          case backend of
+            MongoDB -> "MongoConf"
+            Sqlite -> "SqliteConf"
+            Postgresql -> "PostgresConf"
+            Tiny -> error "Accessing configPersist for Tiny"
 
     putStrLn "That's it! I'm creating your files now..."
 

yesod/scaffold/Application.hs.cg

@@ -15,9 +15,9 @@ import Yesod.Auth
 import Yesod.Default.Config
 import Yesod.Default.Main
 import Yesod.Logger (Logger)
-import Database.Persist.~importGenericDB~
 import Data.ByteString (ByteString)
 import Data.Dynamic (Dynamic, toDyn)
+import qualified Database.Persist.Base~importMigration~
 
 -- Import all relevant handler modules here.
 import Handler.Root
@@ -46,7 +46,9 @@ with~sitearg~ conf logger f = do
 #else
     s <- staticDevel Settings.staticDir
 #endif
-    Settings.withConnectionPool conf $ \p -> do~runMigration~
+    dbconf <- withYamlEnvironment "config/~dbConfigFile~.yml" (appEnv conf)
+            $ either error return . Database.Persist.Base.loadConfig
+    Database.Persist.Base.withPool (dbconf :: Settings.PersistConfig) $ \p -> do~runMigration~
         let h = ~sitearg~ conf logger s p
         defaultRunner f h
 

yesod/scaffold/Foundation.hs.cg

@@ -27,6 +27,7 @@ import Yesod.Default.Util (addStaticContentExternal)
 import Yesod.Logger (Logger, logLazyText)
 import qualified Settings
 import qualified Data.ByteString.Lazy as L
+import qualified Database.Persist.Base
 import Database.Persist.~importGenericDB~
 import Settings (widgetFile)
 import Model
@@ -47,7 +48,7 @@ data ~sitearg~ = ~sitearg~
     { settings :: AppConfig DefaultEnv
     , getLogger :: Logger
     , getStatic :: Static -- ^ Settings for static file serving.
-    , connPool :: Settings.ConnectionPool -- ^ Database connection pool.
+    , connPool :: Database.Persist.Base.PersistConfigPool Settings.PersistConfig -- ^ Database connection pool.
     }
 
 -- Set up i18n messages. See the message folder.
@@ -121,7 +122,7 @@ instance Yesod ~sitearg~ where
 instance YesodPersist ~sitearg~ where
     type YesodPersistBackend ~sitearg~ = ~dbMonad~
     runDB f = liftIOHandler
-            $ fmap connPool getYesod >>= Settings.runConnectionPool f
+            $ fmap connPool getYesod >>= Database.Persist.Base.runPool (undefined :: Settings.PersistConfig) f
 
 instance YesodAuth ~sitearg~ where
     type AuthId ~sitearg~ = UserId

yesod/scaffold/Settings.hs.cg

@@ -8,21 +8,21 @@
 -- declared in the Foundation.hs file.
 module Settings
     ( widgetFile
-    , ConnectionPool
-    , withConnectionPool
-    , runConnectionPool
+    , PersistConfig
     , staticRoot
     , staticDir
     ) where
 
 import Text.Shakespeare.Text (st)
 import Language.Haskell.TH.Syntax
-import Database.Persist.~importPersist~
-import Yesod (liftIO, MonadControlIO)
+import Database.Persist.~importPersist~ (~configPersist~)
 import Yesod.Default.Config
 import qualified Yesod.Default.Util
 import Data.Text (Text)
 
+-- | Which Persistent backend this site is using.
+type PersistConfig = ~configPersist~
+
 -- Static setting below. Changing these requires a recompile
 
 -- | The location of static files on your system. This is a file system
@@ -50,12 +50,6 @@ staticRoot conf = [st|#{appRoot conf}/static|]
 -- The rest of this file contains settings which rarely need changing by a
 -- user.
 
--- The next functions are for allocating a connection pool and running
--- database actions using a pool, respectively. They are used internally
--- by the scaffolded application, and therefore you will rarely need to use
--- them yourself.
-~withConnectionPool~
-
 widgetFile :: String -> Q Exp
 #if PRODUCTION
 widgetFile = Yesod.Default.Util.widgetFileProduction