Merge pull request #85 from gregwebs/settings2

add a Settings.yaml file for dynamic settings

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..."
@@ -102,6 +101,13 @@ scaffold = do
     mkDir "config"
     mkDir "Model"
 
+    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/Controller_hs.cg

@@ -35,14 +35,22 @@ getRobotsR = return $ RepPlain $ toContent ("User-agent: *" :: ByteString)
 -- 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.
-with~sitearg~ :: (Application -> IO a) -> IO a
-with~sitearg~ f = Settings.withConnectionPool $ \p -> do
+with~sitearg~ :: AppConfig -> (Application -> IO a) -> IO a
+with~sitearg~ conf f = do
+  Settings.withConnectionPool conf $ \p -> do
     runConnectionPool (runMigration migrateAll) p
-    let h = ~sitearg~ s p
+    let h = ~sitearg~ conf s p
     toWaiApp h >>= f
   where
-    s = static Settings.staticdir
+    s = static Settings.staticDir
+
+with~sitearg~LoadConfig :: Settings.AppEnvironment -> (Application -> IO a) -> IO a
+with~sitearg~LoadConfig env f = do
+  conf <- Settings.loadConfig Settings.Development
+  withFoobar conf f
+
 
 withDevelApp :: Dynamic
-withDevelApp = toDyn (with~sitearg~ :: (Application -> IO ()) -> IO ())
+withDevelApp = do
+  toDyn ((with~sitearg~LoadConfig Settings.Development):: (Application -> IO ()) -> IO ())
 

scaffold/Settings_hs.cg

@@ -12,13 +12,14 @@ module Settings
     , juliusFile
     , luciusFile
     , widgetFile
-    , connStr
     , ConnectionPool
     , withConnectionPool
     , runConnectionPool
-    , approot
-    , staticroot
-    , staticdir
+    , staticRoot
+    , staticDir
+    , loadConfig
+    , AppEnvironment(..)
+    , AppConfig(..)
     ) where
 
 import qualified Text.Hamlet as H
@@ -27,30 +28,76 @@ 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 qualified Data.Object.Yaml as YAML
+import Control.Monad (join)
 
--- | The base URL for your application. This will usually be different for
--- development and production. Yesod automatically constructs URLs for you,
--- so this value must be accurate to create valid links.
--- Please note that there is no trailing slash.
-approot :: Text
-approot =
-#ifdef PRODUCTION
--- You probably want to change this. If your domain name was "yesod.com",
--- you would probably want it to be:
--- > "http://yesod.com"
-  "http://localhost:3000"
-#else
-  "http://localhost:3000"
-#endif
+data AppEnvironment = Test
+                    | Development
+                    | Staging
+                    | Production
+                    deriving (Eq, Show, Read, Enum, Bounded)
+
+-- | Dynamic per-environment configuration loaded from the YAML file Settings.yaml.
+-- Use dynamic settings to avoid the need to re-compile the application (between staging and production environments).
+--
+-- By convention these settings should be overwritten by any command line arguments.
+-- See config/~sitearg~.hs for command line arguments
+-- Command line arguments provide some convenience but are also required for hosting situations where a setting is read from the environment (appPort on Heroku).
+--
+data AppConfig = AppConfig {
+    appEnv :: AppEnvironment
+
+  , appPort :: Int
+
+    -- | Your application will keep a connection pool and take connections from
+    -- there as necessary instead of continually creating new connections. This
+    -- value gives the maximum number of connections to be open at a given time.
+    -- If your application requests a connection when all connections are in
+    -- use, that request will fail. Try to choose a number that will work well
+    -- with the system resources available to you while providing enough
+    -- connections for your expected load.
+    --
+    -- Connections are returned to the pool as quickly as possible by
+    -- Yesod to avoid resource exhaustion. A connection is only considered in
+    -- use while within a call to runDB.
+  , connectionPoolSize :: Int
+
+    -- | The base URL for your application. This will usually be different for
+    -- development and production. Yesod automatically constructs URLs for you,
+    -- so this value must be accurate to create valid links.
+    -- Please note that there is no trailing slash.
+    --
+    -- You probably want to change this! If your domain name was "yesod.com",
+    -- you would probably want it to be:
+    -- > "http://yesod.com"
+  , appRoot :: Text
+} deriving (Show)
+
+loadConfig :: AppEnvironment -> IO AppConfig
+loadConfig env = do
+    allSettings <- (join $ YAML.decodeFile ("config/settings.yml" :: String)) >>= fromMapping
+    settings <- lookupMapping (show env) allSettings
+    appPortS <- lookupScalar "appPort" settings
+    appRootS <- lookupScalar "appRoot" settings
+    connectionPoolSizeS <- lookupScalar "connectionPoolSize" settings
+    return $ AppConfig {
+      appEnv = env
+    , appPort = read $ appPortS
+    , appRoot = read $ (show appRootS)
+    , connectionPoolSize = read $ connectionPoolSizeS
+    }
+
+-- Static setting below. Changing these requires a recompile
 
 -- | The location of static files on your system. This is a file system
 -- path. The default value works properly with your scaffolded site.
-staticdir :: FilePath
-staticdir = "static"
+staticDir :: FilePath
+staticDir = "static"
 
 -- | The base URL for your static files. As you can see by the default
 -- value, this can simply be "static" appended to your application root.
@@ -65,36 +112,40 @@ staticdir = "static"
 -- have to make a corresponding change here.
 --
 -- To see how this value is used, see urlRenderOverride in ~sitearg~.hs
-staticroot :: Text
-staticroot = approot `mappend` "/static"
+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
-
--- | Your application will keep a connection pool and take connections from
--- there as necessary instead of continually creating new connections. This
--- value gives the maximum number of connections to be open at a given time.
--- If your application requests a connection when all connections are in
--- use, that request will fail. Try to choose a number that will work well
--- with the system resources available to you while providing enough
--- connections for your expected load.
---
--- Also, connections are returned to the pool as quickly as possible by
--- Yesod to avoid resource exhaustion. A connection is only considered in
--- use while within a call to runDB.
-connectionCount :: Int
-connectionCount = 10
 
 -- 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
@@ -150,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 => (ConnectionPool -> m a) -> m a
-withConnectionPool = with~upper~Pool connStr connectionCount
-
-runConnectionPool :: MonadControlIO m => SqlPersist m a -> ConnectionPool -> m a
-runConnectionPool = runSqlPool

scaffold/cabal.cg

@@ -57,11 +57,13 @@ executable         ~project~
                  , text
                  , persistent
                  , persistent-template
-                 , persistent-~lower~ >= 0.5 && < 0.6
+                 , persistent-~backendLower~ >= 0.5 && < 0.6
                  , template-haskell
                  , hamlet
                  , hjsmin
                  , transformers
+                 , data-object
+                 , data-object-yaml
                  , warp
                  , blaze-builder
-
+                 , cmdargs

scaffold/mini-Controller_hs.cg

@@ -34,13 +34,13 @@ getRobotsR = return $ RepPlain $ toContent ("User-agent: *" :: ByteString)
 -- 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.
-with~sitearg~ :: (Application -> IO a) -> IO a
-with~sitearg~ f = do
-    let h = ~sitearg~ s
+with~sitearg~ :: AppEnvironment -> (Application -> IO a) -> IO a
+with~sitearg~ appEnv f = do
+    let h = ~sitearg~ appEnv s
     toWaiApp h >>= f
   where
     s = static Settings.staticdir
 
 withDevelApp :: Dynamic
-withDevelApp = toDyn (with~sitearg~ :: (Application -> IO ()) -> IO ())
+withDevelApp = toDyn (with~sitearg~ Development :: (Application -> IO ()) -> IO ())
 

scaffold/mini-cabal.cg

@@ -55,6 +55,8 @@ executable         ~project~
                  , template-haskell
                  , hamlet
                  , transformers
+                 , data-object
+                 , data-object-yaml
                  , wai
                  , warp
                  , blaze-builder

scaffold/mini-sitearg_hs.cg

@@ -30,7 +30,8 @@ import qualified Data.Text as T
 -- starts running, such as database connections. Every handler will have
 -- access to the data present here.
 data ~sitearg~ = ~sitearg~
-    { getStatic :: Static -- ^ Settings for static file serving.
+    { appEnv :: Settings.AppEnvironment
+    , getStatic :: Static -- ^ Settings for static file serving.
     }
 
 -- | A useful synonym; most of the handler functions in your application

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,20 @@
+Default: &defaults
+  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/settings_yml.cg

@@ -0,0 +1,16 @@
+Default: &defaults
+  appRoot: http://localhost
+  appPort: 3000
+  connectionPoolSize: 10
+
+Development:
+  <<: *defaults
+
+Test:
+  <<: *defaults
+
+Staging:
+  <<: *defaults
+
+Production:
+  <<: *defaults

scaffold/sitearg_hs.cg

@@ -40,7 +40,8 @@ import qualified Data.Text as T
 -- starts running, such as database connections. Every handler will have
 -- access to the data present here.
 data ~sitearg~ = ~sitearg~
-    { getStatic :: Static -- ^ Settings for static file serving.
+    { settings :: Settings.AppConfig
+    , getStatic :: Static -- ^ Settings for static file serving.
     , connPool :: Settings.ConnectionPool -- ^ Database connection pool.
     }
 
@@ -76,7 +77,7 @@ mkYesodData "~sitearg~" $(parseRoutesFile "config/routes")
 -- Please see the documentation for the Yesod typeclass. There are a number
 -- of settings which can be configured by overriding methods here.
 instance Yesod ~sitearg~ where
-    approot _ = Settings.approot
+    approot = Settings.appRoot . settings
 
     defaultLayout widget = do
         mmsg <- getMessage
@@ -86,9 +87,9 @@ instance Yesod ~sitearg~ where
         hamletToRepHtml $(Settings.hamletFile "default-layout")
 
     -- This is done to provide an optimization for serving static files from
-    -- a separate domain. Please see the staticroot setting in Settings.hs
-    urlRenderOverride a (StaticR s) =
-        Just $ uncurry (joinPath a Settings.staticroot) $ renderRoute s
+    -- a separate domain. Please see the staticRoot setting in Settings.hs
+    urlRenderOverride y (StaticR s) =
+        Just $ uncurry (joinPath y (Settings.staticRoot $ settings y)) $ renderRoute s
     urlRenderOverride _ _ = Nothing
 
     -- The page to be redirected to when authentication is required.
@@ -106,7 +107,7 @@ instance Yesod ~sitearg~ where
                             Left _ -> content
                             Right y -> y
                     else content
-        let statictmp = Settings.staticdir ++ "/tmp/"
+        let statictmp = Settings.staticDir ++ "/tmp/"
         liftIO $ createDirectoryIfMissing True statictmp
         let fn' = statictmp ++ fn
         exists <- liftIO $ doesFileExist fn'

scaffold/sqlite_yml.cg

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

scaffold/test_hs.cg

@@ -1,20 +1,57 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP, DeriveDataTypeable #-}
+import qualified Settings as Settings
+import Settings (AppConfig(..))
+import Controller (with~sitearg~)
+import Network.Wai.Handler.Warp (run)
+import System.Console.CmdArgs
+import Data.Char (toUpper, toLower)
+
 #if PRODUCTION
-import Controller (with~sitearg~)
-import Network.Wai.Handler.Warp (run)
-
-main :: IO ()
-main = with~sitearg~ $ run 3000
-#else
-import Controller (with~sitearg~)
-import System.IO (hPutStrLn, stderr)
-import Network.Wai.Middleware.Debug (debug)
-import Network.Wai.Handler.Warp (run)
-
 main :: IO ()
 main = do
-    let port = 3000
-    hPutStrLn stderr $ "Application launched, listening on port " ++ show port
-    with~sitearg~ $ run port . debug
+    args <- cmdArgs argConfig
+    appEnv <- getAppEnv args
+    config <- Settings.loadConfig appEnv
+    let c = if (port args) /= 0 then config {appPort = (port args) } else config
+    with~sitearg~ c $ run (appPort c)
+
+#else
+
+import System.IO (hPutStrLn, stderr)
+import Network.Wai.Middleware.Debug (debug)
+main :: IO ()
+main = do
+    args <- cmdArgs argConfig
+    appEnv <- getAppEnv args
+    config <- Settings.loadConfig appEnv
+    let c = if (port args) /= 0 then config {appPort = (port args) } else config
+    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}
+                 deriving (Show, Data, Typeable)
+
+argConfig = ArgConfig{ environment = def 
+  &= help ("application environment, one of: " ++ (foldl1 (\a b -> a ++ ", " ++ b) environments))
+  &= typ "ENVIRONMENT"
+  ,port = def &= typ "PORT"
+}
+
+environments :: [String]
+environments = map ((map toLower) . show) ([minBound..maxBound] :: [Settings.AppEnvironment])
+
+-- | retrieve the -e environment option
+getAppEnv :: ArgConfig ->  IO Settings.AppEnvironment
+getAppEnv cfg = do
+    let e = if (environment cfg) /= "" then (environment cfg)
+            else
+#if PRODUCTION
+                  "production"
+#else
+                  "development"
+#endif
+    return $ read $ capitalize e
+  where
+    capitalize [] = []
+    capitalize (x:xs) = toUpper x : map toLower xs

tests/runscaffold.sh

@@ -0,0 +1,4 @@
+#!/bin/sh
+
+cabal clean && cabal install &&
+  rm -rf foobar && runghc scaffold.hs init < tests/sample-input.txt && cd foobar && cabal install && cabal install -fdevel && cd ..

tests/sample-input.txt

@@ -0,0 +1,4 @@
+Michael
+foobar
+Foobar
+s