fix/improve scaffolding

scaffold/Controller.hs.cg

@@ -46,10 +46,10 @@ with~sitearg~ conf f = do
 
 with~sitearg~LoadConfig :: Settings.AppEnvironment -> (Application -> IO a) -> IO a
 with~sitearg~LoadConfig env f = do
-  conf <- Settings.loadConfig Settings.Development
+  conf <- Settings.loadConfig env
   withFoobar conf f
 
-
+-- for yesod devel
 withDevelApp :: Dynamic
 withDevelApp = do
   toDyn ((with~sitearg~LoadConfig Settings.Development):: (Application -> IO ()) -> IO ())

scaffold/Handler/Root.hs.cg

@@ -2,6 +2,7 @@
 module Handler.Root where
 
 import ~sitearg~
+import Data.Text
 
 -- This is a handler function for the GET request method on the RootR
 -- resource pattern. All of your resource patterns are defined in
@@ -17,4 +18,3 @@ getRootR = do
         h2id <- lift newIdent
         setTitle "~project~ homepage"
         addWidget $(widgetFile "homepage")
-

scaffold/config/Settings.hs.cg

@@ -31,7 +31,8 @@ import Language.Haskell.TH.Syntax
 import Yesod (liftIO, MonadControlIO, addWidget, addCassius, addJulius, addLucius)
 import Data.Monoid (mempty, mappend)
 import System.Directory (doesFileExist)
-import Data.Text (Text)
+import Prelude hiding (concat)
+import Data.Text (Text, snoc, append, pack, concat)
 import Data.Object
 import qualified Data.Object.Yaml as YAML
 import Control.Monad (join)

scaffold/config/routes.cg

@@ -5,4 +5,3 @@
 /robots.txt RobotsR GET
 
 / RootR GET
-

scaffold/mini/Controller.hs.cg

@@ -34,13 +34,19 @@ 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~ :: AppEnvironment -> (Application -> IO a) -> IO a
+with~sitearg~ :: AppConfig -> (Application -> IO a) -> IO a
-with~sitearg~ appEnv f = do
+with~sitearg~ conf f = do
-    let h = ~sitearg~ appEnv s
+    let h = ~sitearg~ conf s
     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 env
+  withFoobar conf f
 
 withDevelApp :: Dynamic
-withDevelApp = toDyn (with~sitearg~ Development :: (Application -> IO ()) -> IO ())
+withDevelApp = do
+  toDyn ((with~sitearg~LoadConfig Settings.Development):: (Application -> IO ()) -> IO ())
 

scaffold/mini/Handler/Root.hs.cg

@@ -5,7 +5,7 @@ import ~sitearg~
 
 -- This is a handler function for the GET request method on the RootR
 -- resource pattern. All of your resource patterns are defined in
--- ~sitearg~.hs; look for the line beginning with mkYesodData.
+-- config/routes
 --
 -- The majority of the code you will write in Yesod lives in these handler
 -- functions. You can spread them across multiple files if you are so

scaffold/mini/cabal.cg

@@ -60,5 +60,8 @@ executable         ~project~
                  , wai
                  , warp
                  , blaze-builder
+                 , cmdargs
+                 , data-object
+                 , data-object-yaml
     ghc-options:   -Wall -threaded
 

scaffold/mini/config/Settings.hs.cg

@@ -12,9 +12,11 @@ module Settings
     , juliusFile
     , luciusFile
     , widgetFile
-    , approot
+    , staticRoot
-    , staticroot
+    , staticDir
-    , staticdir
+    , loadConfig
+    , AppEnvironment(..)
+    , AppConfig(..)
     ) where
 
 import qualified Text.Hamlet as H
@@ -26,25 +28,55 @@ import Yesod.Widget (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
+data AppEnvironment = Test
--- development and production. Yesod automatically constructs URLs for you,
+                    | Development
--- so this value must be accurate to create valid links.
+                    | Staging
-approot :: Text
+                    | Production
-#ifdef PRODUCTION
+                    deriving (Eq, Show, Read, Enum, Bounded)
--- You probably want to change this. If your domain name was "yesod.com",
+
--- you would probably want it to be:
+-- | Dynamic per-environment configuration loaded from the YAML file Settings.yaml.
--- > approot = "http://www.yesod.com"
+-- Use dynamic settings to avoid the need to re-compile the application (between staging and production environments).
--- Please note that there is no trailing slash.
+--
-approot = "http://localhost:3000"
+-- By convention these settings should be overwritten by any command line arguments.
-#else
+-- See config/~sitearg~.hs for command line arguments
-approot = "http://localhost:3000"
+-- Command line arguments provide some convenience but are also required for hosting situations where a setting is read from the environment (appPort on Heroku).
-#endif
+--
+data AppConfig = AppConfig {
+    appEnv :: AppEnvironment
+
+  , appPort :: 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
+    return $ AppConfig {
+      appEnv = env
+    , appPort = read $ appPortS
+    , appRoot = read $ (show appRootS)
+    }
 
 -- | 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 :: FilePath
-staticdir = "static"
+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.
@@ -59,8 +91,8 @@ staticdir = "static"
 -- have to make a corresponding change here.
 --
 -- To see how this value is used, see urlRenderOverride in ~project~.hs
-staticroot :: Text
+staticRoot :: AppConfig ->  Text
-staticroot = approot `mappend` "/static"
+staticRoot conf = (appRoot conf) `mappend` "/static"
 
 -- The rest of this file contains settings which rarely need changing by a
 -- user.

scaffold/mini/sitearg.hs.cg

@@ -30,7 +30,7 @@ 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~
-    { appEnv :: Settings.AppEnvironment
+    { settings :: Settings.AppConfig
     , getStatic :: Static -- ^ Settings for static file serving.
     }
 
@@ -66,7 +66,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
@@ -77,8 +77,8 @@ instance Yesod ~sitearg~ where
 
     -- 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) =
+    urlRenderOverride y (StaticR s) =
-        Just $ uncurry (joinPath a Settings.staticroot) $ renderRoute s
+        Just $ uncurry (joinPath y (Settings.staticRoot $ settings y)) $ renderRoute s
     urlRenderOverride _ _ = Nothing
 
     -- This function creates static content files in the static folder
@@ -87,7 +87,7 @@ instance Yesod ~sitearg~ where
     -- users receiving stale content.
     addStaticContent ext' _ content = do
         let fn = base64md5 content ++ '.' : T.unpack ext'
-        let statictmp = Settings.staticdir ++ "/tmp/"
+        let statictmp = Settings.staticDir ++ "/tmp/"
         liftIO $ createDirectoryIfMissing True statictmp
         let fn' = statictmp ++ fn
         exists <- liftIO $ doesFileExist fn'

scaffold/pconn1.cg

@@ -1,5 +1,5 @@
-    user <- lookupScalar "user"
+    connPart <- fmap concat $ (flip mapM) ["user", "password", "host", "port"] $ \key -> do
-    password <- lookupScalar "user"
+      value <- lookupScalar key settings
-    host <- lookupScalar "host"
+      return $ append (snoc (pack key) '=') (snoc value ' ')
-    port <- lookupScalar "port"
+    return $ append connPart (append " dbname= " database)
-    return $ "user=" ++ user ++ "password=" ++ password ++ "host=" ++ host ++ "port=" ++ port ++ "dbname= ++ database"
+

scaffold/project.hs.cg

@@ -7,24 +7,20 @@ import System.Console.CmdArgs
 import Data.Char (toUpper, toLower)
 
 #if PRODUCTION
-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
-    with~sitearg~ c $ run (appPort c)
-
 #else
-
 import System.IO (hPutStrLn, stderr)
 import Network.Wai.Middleware.Debug (debug)
+#endif
+
 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
+#if PRODUCTION
+    with~sitearg~ c $ run (appPort c)
+#else
     hPutStrLn stderr $ (show appEnv) ++ " application launched, listening on port " ++ show (appPort c)
     with~sitearg~ c $ run (appPort c) . debug
 #endif

tests/mini-input.txt

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

tests/postgresql-input.txt

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

tests/runscaffold.sh

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