make database settings configurable

development.md

@@ -0,0 +1,5 @@
+# Scaffolding
+
+## Test suite
+
+  shelltest test/scaffold.shelltest

scaffold.hs

@@ -73,12 +73,11 @@ scaffold = do
     puts $(codegen "database")
     backendS <- prompt $ flip elem ["s", "p", "m"]
     let pconn1 = $(codegen "pconn1")
-    let pconn2 = $(codegen "pconn2")
-    let (lower, upper, connstr1, connstr2, importDB) =
+    let (backendLower, upper, connstr, importDB) =
             case backendS of
-                "s" -> ("sqlite", "Sqlite", "debug.db3", "production.db3", "import Database.Persist.Sqlite\n")
-                "p" -> ("postgresql", "Postgresql", pconn1, pconn2, "import Database.Persist.Postgresql\n")
-                "m" -> ("FIXME lower", "FIXME upper", "FIXME connstr1", "FIXME connstr2", "")
+                "s" -> ("sqlite", "Sqlite", "    return database", "import Database.Persist.Sqlite\n")
+                "p" -> ("postgresql", "Postgresql", pconn1, "import Database.Persist.Postgresql\n")
+                "m" -> ("FIXME lower", "FIXME upper", "FIXME connstr1", "")
                 _ -> error $ "Invalid backend: " ++ backendS
 
     putStrLn "That's it! I'm creating your files now..."
@@ -100,7 +99,13 @@ scaffold = do
     mkDir "static/css"
     mkDir "config"
 
-    writeFile' ("config/Settings.yaml") $(codegen "Settings_yaml")
+    case backendS of
+        "s" -> writeFile' ("config/" ++ backendLower ++ ".yml") $(codegen ("sqlite_yml"))
+        "p" -> writeFile' ("config/" ++ backendLower ++ ".yml") $(codegen ("postgresql_yml"))
+        "m" -> return ()
+        _ -> error $ "Invalid backend: " ++ backendS
+
+    writeFile' ("config/settings.yml") $(codegen "settings_yml")
     writeFile' ("config/" ++ project ++ ".hs") $(codegen "test_hs")
     writeFile' (project ++ ".cabal") $ if backendS == "m" then $(codegen "mini-cabal") else $(codegen "cabal")
     writeFile' ".ghci" $(codegen "dotghci")

scaffold/Settings_hs.cg

@@ -12,7 +12,6 @@ module Settings
     , juliusFile
     , luciusFile
     , widgetFile
-    , connStr
     , ConnectionPool
     , withConnectionPool
     , runConnectionPool
@@ -29,12 +28,12 @@ import qualified Text.Julius as H
 import qualified Text.Lucius as H
 import Language.Haskell.TH.Syntax
 ~importDB~
-import Yesod (MonadControlIO, addWidget, addCassius, addJulius, addLucius)
+import Yesod (liftIO, MonadControlIO, addWidget, addCassius, addJulius, addLucius)
 import Data.Monoid (mempty, mappend)
 import System.Directory (doesFileExist)
 import Data.Text (Text)
 import Data.Object
-import Data.Object.Yaml
+import qualified Data.Object.Yaml as YAML
 import Control.Monad (join)
 
 data AppEnvironment = Test
@@ -81,7 +80,7 @@ data AppConfig = AppConfig {
 
 loadConfig :: AppEnvironment -> IO AppConfig
 loadConfig env = do
-    allSettings <- (join $ decodeFile ("config/Settings.yaml" :: String)) >>= fromMapping
+    allSettings <- (join $ YAML.decodeFile ("config/settings.yml" :: String)) >>= fromMapping
     settings <- lookupMapping (show env) allSettings
     appPortS <- lookupScalar "appPort" settings
     appRootS <- lookupScalar "appRoot" settings
@@ -117,19 +116,36 @@ staticRoot :: AppConfig ->  Text
 staticRoot conf = (appRoot conf) `mappend` "/static"
 
 
--- | The database connection string. The meaning of this string is backend-
--- specific.
-connStr :: Text
-connStr =
-#ifdef PRODUCTION
-  "~connstr2~"
-#else
-  "~connstr1~"
-#endif
-
 -- 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. It is used internally
+-- by the scaffolded application, and therefore you will rarely need to use
+-- them yourself.
+runConnectionPool :: MonadControlIO m => SqlPersist m a -> ConnectionPool -> m a
+runConnectionPool = runSqlPool
+
+-- | The database connection string. The meaning of this string is backend-
+-- specific.
+loadConnStr :: AppEnvironment -> IO Text
+loadConnStr env = do
+    allSettings <- (join $ YAML.decodeFile ("config/~backendLower~.yml" :: String)) >>= fromMapping
+    settings <- lookupMapping (show env) allSettings
+    database <- lookupScalar "database" settings
+~connstr~
+
+withConnectionPool :: MonadControlIO m => AppConfig -> (ConnectionPool -> m a) -> m a
+withConnectionPool conf f = do
+    cs <- liftIO $ loadConnStr (appEnv conf)
+    with~upper~Pool cs (connectionPoolSize conf) f
+
+-- Example of making a dynamic configuration static
+-- use /return $(mkConnStr Production)/ instead of loadConnStr
+-- mkConnStr :: AppEnvironment -> Q Exp
+-- mkConnStr env = qRunIO (loadConnStr env) >>= return . LitE . StringL
+
+
 -- The following three functions are used for calling HTML, CSS and
 -- Javascript templates from your Haskell code. During development,
 -- the "Debug" versions of these functions are used so that changes to
@@ -185,13 +201,3 @@ widgetFile x = do
     unlessExists tofn f = do
         e <- qRunIO $ doesFileExist $ tofn x
         if e then f x else [|mempty|]
-
--- The next two functions are for allocating a connection pool and running
--- database actions using a pool, respectively. It is used internally
--- by the scaffolded application, and therefore you will rarely need to use
--- them yourself.
-withConnectionPool :: MonadControlIO m => AppConfig -> (ConnectionPool -> m a) -> m a
-withConnectionPool conf = with~upper~Pool connStr (connectionPoolSize conf)
-
-runConnectionPool :: MonadControlIO m => SqlPersist m a -> ConnectionPool -> m a
-runConnectionPool = runSqlPool

scaffold/cabal.cg

@@ -57,7 +57,7 @@ executable         ~project~
                  , text
                  , persistent
                  , persistent-template
-                 , persistent-~lower~ >= 0.5 && < 0.6
+                 , persistent-~backendLower~ >= 0.5 && < 0.6
                  , template-haskell
                  , hamlet
                  , hjsmin

scaffold/pconn1.cg

@@ -1 +1,5 @@
-user=~project~ password=~project~ host=localhost port=5432 dbname=~project~_debug
+    user <- lookupScalar "user"
+    password <- lookupScalar "user"
+    host <- lookupScalar "host"
+    port <- lookupScalar "port"
+    return $ "user=" ++ user ++ "password=" ++ password ++ "host=" ++ host ++ "port=" ++ port ++ "dbname= ++ database"

scaffold/pconn2.cg

@@ -1 +0,0 @@
-user=~project~ password=~project~ host=localhost port=5432 dbname=~project~_production

scaffold/postgresql_yml.cg

@@ -0,0 +1,21 @@
+Default: &defaults
+  adapter: postgres
+  user: ~project~
+  password: ~project~
+  host: localhost
+  port: 5432
+  database: ~project~
+
+Development:
+  <<: *defaults
+
+Test:
+  database: ~project~_test
+  <<: *defaults
+
+Staging:
+  <<: *defaults
+
+Production:
+  database: ~project~_production
+  <<: *defaults

scaffold/sqlite_yml.cg

@@ -0,0 +1,17 @@
+Default: &defaults
+  adapter: sqlite
+  database: ~project~.sqlite3
+
+Development:
+  <<: *defaults
+
+Test:
+  database: ~project~_test.sqlite3
+  <<: *defaults
+
+Staging:
+  <<: *defaults
+
+Production:
+  database: ~project~_production.sqlite3
+  <<: *defaults

scaffold/test_hs.cg

@@ -25,8 +25,8 @@ main = do
     appEnv <- getAppEnv args
     config <- Settings.loadConfig appEnv
     let c = if (port args) /= 0 then config {appPort = (port args) } else config
-    do hPutStrLn stderr $ (show appEnv) ++ " application launched, listening on port " ++ show (appPort c)
-       with~sitearg~ c $ run (appPort c) . debug
+    hPutStrLn stderr $ (show appEnv) ++ " application launched, listening on port " ++ show (appPort c)
+    with~sitearg~ c $ run (appPort c) . debug
 #endif
 
 data ArgConfig = ArgConfig {environment :: String, port :: Int}