add mongoDB to the scaffolder

Almost working- causes a failing test case

yesod/input/database.cg

@@ -1,9 +1,7 @@
 Yesod uses Persistent for its (you guessed it) persistence layer.
-This tool will build in either SQLite or PostgreSQL support for you. If you
-want to use a different backend, you'll have to make changes manually.
-If you're not sure, stick with SQLite: it has no dependencies.
+This tool will build in either SQLite, PostgreSQL, or MongoDB support for you.
+We recommend starting with SQLite: it has no dependencies.
 
-We also have a new option: a mini project. This is a site with minimal
-dependencies. In particular: no database, no authentication.
+We have another option: a tiny project with minimal dependencies. In particular: no database and no authentication.
 
-So, what'll it be? s for sqlite, p for postgresql, m for mini: 
+So, what'll it be? s for sqlite, p for postgresql, m for MongoDB, t for tiny: 

yesod/scaffold.hs

@@ -6,11 +6,12 @@ import System.Directory
 import qualified Data.ByteString.Char8 as S
 import Language.Haskell.TH.Syntax
 import Data.Time (getCurrentTime, utctDay, toGregorian)
+import Data.Char (toLower)
 import Control.Applicative ((<$>))
 import qualified Data.ByteString.Lazy as L
 import qualified Data.Text.Lazy as LT
 import qualified Data.Text.Lazy.Encoding as LT
-import Control.Monad (when, unless)
+import Control.Monad (unless)
 import System.Environment (getArgs)
 
 import Scaffold.Build (touch)
@@ -63,6 +64,12 @@ main = do
 puts :: String -> IO ()
 puts s = putStr s >> hFlush stdout
 
+data Backend = Sqlite | Postgresql | MongoDB | Tiny
+  deriving (Eq, Read, Show, Enum, Bounded)
+
+backends :: [Backend]
+backends = [minBound .. maxBound]
+
 scaffold :: IO ()
 scaffold = do
     puts $(codegenDir "input" "welcome")
@@ -83,17 +90,30 @@ scaffold = do
     sitearg <- prompt $ \s -> not (null s) && all validPN s && isUpperAZ (head s) && s /= "Main"
 
     puts $(codegenDir "input" "database")
-    backendS <- prompt $ flip elem ["s", "p", "m"]
-    let pconn1 = $(codegen "pconn1")
-    let (backendLower, upper, connstr, importDB) =
-            case backendS of
-                "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
+    
+    backendC <- prompt $ flip elem $ map (return . toLower . head . show) backends
+    let (backend, importDB) =
+            case backendC of
+                "s" -> (Sqlite, "import Database.Persist.Sqlite\n")
+                "p" -> (Postgresql, "import Database.Persist.Postgresql\n")
+                "m" -> (MongoDB, "import Database.Persist.MongoDB\nimport Control.Applicative (Applicative)\n")
+                "t" -> (Tiny, "")
+                _ -> error $ "Invalid backend: " ++ backendC
+        uncapitalize s = toLower (head s) : tail s
+        backendLower = uncapitalize $ show backend 
+        upper = show backend
 
     putStrLn "That's it! I'm creating your files now..."
 
+    let withConnectionPool = case backend of
+          Sqlite     -> $(codegen $ "sqliteConnPool")
+          Postgresql -> $(codegen $ "postgresqlConnPool")
+          MongoDB    -> $(codegen $ "mongoDBConnPool")
+          Tiny       -> ""
+          _ -> error $ "Invalid backend: " ++ backendLower
+
+        packages = if backend == MongoDB then "          , mongoDB\n         , bson\n" else ""
+
     let fst3 (x, _, _) = x
     year <- show . fst3 . toGregorian . utctDay <$> getCurrentTime
 
@@ -116,22 +136,25 @@ scaffold = do
      
     writeFile' ("deploy/Procfile") $(codegen "deploy/Procfile")
 
-    case backendS of
-        "s" -> writeFile' ("config/" ++ backendLower ++ ".yml") $(codegen ("config/sqlite.yml"))
-        "p" -> writeFile' ("config/" ++ backendLower ++ ".yml") $(codegen ("config/postgresql.yml"))
-        "m" -> return ()
-        _ -> error $ "Invalid backend: " ++ backendS
+    case backend of
+      Sqlite     -> writeFile' ("config/" ++ backendLower ++ ".yml") $(codegen ("config/sqlite.yml"))
+      Postgresql -> writeFile' ("config/" ++ backendLower ++ ".yml") $(codegen ("config/postgresql.yml"))
+      MongoDB    -> writeFile' ("config/" ++ backendLower ++ ".yml") $(codegen ("config/mongoDB.yml"))
+      _            -> error $ "Invalid backend: " ++ backendLower
+
+    let isTiny = backend == Tiny
+        ifTiny a b = if isTiny then a else b
 
     writeFile' ("config/settings.yml") $(codegen "config/settings.yml")
     writeFile' ("main.hs") $(codegen "project.hs")
-    writeFile' (project ++ ".cabal") $ if backendS == "m" then $(codegen "mini/cabal") else $(codegen "cabal")
+    writeFile' (project ++ ".cabal") $ ifTiny $(codegen "mini/cabal") $(codegen "cabal")
     writeFile' ".ghci" $(codegen ".ghci")
     writeFile' "LICENSE" $(codegen "LICENSE")
-    writeFile' (sitearg ++ ".hs") $ if backendS == "m" then $(codegen "mini/sitearg.hs") else $(codegen "sitearg.hs")
-    writeFile' "Controller.hs" $ if backendS == "m" then $(codegen "mini/Controller.hs") else $(codegen "Controller.hs")
-    writeFile' "Handler/Root.hs" $ if backendS == "m" then $(codegen "mini/Handler/Root.hs") else $(codegen "Handler/Root.hs")
-    when (backendS /= "m") $ writeFile' "Model.hs" $(codegen "Model.hs")
-    writeFile' "config/Settings.hs" $ if backendS == "m" then $(codegen "mini/config/Settings.hs") else $(codegen "config/Settings.hs")
+    writeFile' (sitearg ++ ".hs") $ ifTiny $(codegen "mini/sitearg.hs") $(codegen "sitearg.hs")
+    writeFile' "Controller.hs" $ ifTiny $(codegen "mini/Controller.hs") $(codegen "Controller.hs")
+    writeFile' "Handler/Root.hs" $ ifTiny $(codegen "mini/Handler/Root.hs") $(codegen "Handler/Root.hs")
+    unless isTiny $ writeFile' "Model.hs" $(codegen "Model.hs")
+    writeFile' "config/Settings.hs" $ ifTiny $(codegen "mini/config/Settings.hs") $(codegen "config/Settings.hs")
     writeFile' "config/StaticFiles.hs" $(codegen "config/StaticFiles.hs")
     writeFile' "cassius/default-layout.cassius"
         $(codegen "cassius/default-layout.cassius")
@@ -141,11 +164,11 @@ scaffold = do
         $(codegen "hamlet/boilerplate-layout.hamlet")
     writeFile' "static/css/html5boilerplate.css"
         $(codegen "static/css/html5boilerplate.css")
-    writeFile' "hamlet/homepage.hamlet" $ if backendS == "m" then $(codegen "mini/hamlet/homepage.hamlet") else $(codegen "hamlet/homepage.hamlet")
-    writeFile' "config/routes" $ if backendS == "m" then $(codegen "mini/config/routes") else $(codegen "config/routes")
+    writeFile' "hamlet/homepage.hamlet" $ ifTiny $(codegen "mini/hamlet/homepage.hamlet") $(codegen "hamlet/homepage.hamlet")
+    writeFile' "config/routes" $ ifTiny $(codegen "mini/config/routes") $(codegen "config/routes")
     writeFile' "cassius/homepage.cassius" $(codegen "cassius/homepage.cassius")
     writeFile' "julius/homepage.julius" $(codegen "julius/homepage.julius")
-    unless (backendS == "m") $ writeFile' "config/models" $(codegen "config/models")
+    unless isTiny $ writeFile' "config/models" $(codegen "config/models")
   
     S.writeFile (dir ++ "/config/favicon.ico")
         $(runIO (S.readFile "scaffold/config/favicon.ico.cg") >>= \bs -> do

yesod/scaffold/cabal.cg

@@ -61,6 +61,7 @@ executable         ~project~
                  , persistent
                  , persistent-template
                  , persistent-~backendLower~ >= 0.6 && < 0.7
+                 ~packages~
                  , template-haskell
                  , hamlet
                  , hjsmin

yesod/scaffold/config/Settings.hs.cg

@@ -121,31 +121,10 @@ staticRoot conf = (appRoot conf) `mappend` "/static"
 -- user.
 
 -- The next functions are for allocating a connection pool and running
--- database actions using a pool, respectively. It is used internally
+-- database actions using a pool, respectively. They are 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
-
+~withConnectionPool~
 
 -- The following three functions are used for calling HTML, CSS and
 -- Javascript templates from your Haskell code. During development,

yesod/scaffold/config/mongoDB.yml.cg

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

yesod/scaffold/config/postgresql.yml.cg

@@ -13,7 +13,7 @@ Test:
   <<: *defaults
 
 Staging:
-  <<: *defaults
+  database: ~project~_staging
 
 Production:
   database: ~project~_production

yesod/scaffold/config/sqlite.yml.cg

@@ -9,6 +9,7 @@ Test:
   <<: *defaults
 
 Staging:
+  database: ~project~_staging.sqlite3
   <<: *defaults
 
 Production:

yesod/scaffold/mongoDBConnPool.cg

@@ -0,0 +1,16 @@
+runConnectionPool :: MonadControlIO m => MongoPersist m a -> ConnectionPool -> Database -> m a
+runConnectionPool = runMongoDBConn safe Master
+
+withConnectionPool :: (MonadControlIO m, Applicative m) => AppConfig -> (ConnectionPool -> Database -> m b) -> m b
+withConnectionPool conf f = do
+    (database,host) <- liftIO $ loadConnParams (appEnv conf)
+    withMongoDBPool (Database $ u database) host (connectionPoolSize conf) f
+  where
+    -- | The database connection parameters.
+  --  loadConnParams :: AppEnvironment -> IO Text
+    loadConnParams env = do
+        allSettings <- (join $ YAML.decodeFile ("config/mongoDB.yml" :: String)) >>= fromMapping
+        settings <- lookupMapping (show env) allSettings
+        database <- lookupScalar "database" settings
+        host <- lookupScalar "host" settings
+        return (database, host)

yesod/scaffold/pconn1.cg

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

yesod/scaffold/postgresqlConnPool.cg

@@ -0,0 +1,26 @@
+runConnectionPool :: MonadControlIO m => SqlPersist m a -> ConnectionPool -> m a
+runConnectionPool = runSqlPool
+
+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
+  where
+    -- | 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
+
+        connPart <- fmap concat $ (flip mapM) ["user", "password", "host", "port"] $ \key -> do
+          value <- lookupScalar key settings
+          return $ append (snoc (pack key) '=') (snoc value ' ')
+        return $ append connPart (append " dbname= " database)
+
+-- 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
+

yesod/scaffold/sitearg.hs.cg

@@ -124,8 +124,8 @@ instance Yesod ~sitearg~ where
 -- How to run database actions.
 instance YesodPersist ~sitearg~ where
     type YesodDB ~sitearg~ = SqlPersist
-    runDB db = liftIOHandler
-             $ fmap connPool getYesod >>= Settings.runConnectionPool db
+    runDB f = liftIOHandler
+            $ fmap connPool getYesod >>= Settings.runConnectionPool f
 
 instance YesodAuth ~sitearg~ where
     type AuthId ~sitearg~ = UserId

yesod/scaffold/sqliteConnPool.cg

@@ -0,0 +1,23 @@
+runConnectionPool :: MonadControlIO m => SqlPersist m a -> ConnectionPool -> m a
+runConnectionPool = runSqlPool
+
+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
+  where
+    -- | 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
+
+        return database
+
+-- 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
+

yesod/tests/scaffold.shelltest

@@ -1,5 +1,15 @@
 # Important! run with tests/run.sh
 
+rm -rf foobar && runghc scaffold.hs init && cd foobar && cabal install && cabal install -fdevel && cd .. && rm -rf foobar
+<<<
+Michael
+foobar
+
+Foobar
+t
+>>> /.*Registering foobar-0.0.0.*/
+>>>= 0
+
 rm -rf foobar && runghc scaffold.hs init && cd foobar && cabal install && cabal install -fdevel && cd ..
 <<<
 Michael

yesod/tests/tiny-input.txt

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

yesod/yesod.cabal

@@ -17,36 +17,40 @@ homepage:        http://www.yesodweb.com/
 
 extra-source-files:
   input/*.cg
-  scaffold/cassius/default-layout.cassius.cg,
-  scaffold/cassius/homepage.cassius.cg,
-  scaffold/Model.hs.cg scaffold/sitearg.hs.cg,
-  scaffold/LICENSE.cg,
-  scaffold/mini/sitearg.hs.cg,
-  scaffold/mini/cabal.cg,
-  scaffold/mini/Controller.hs.cg,
-  scaffold/mini/hamlet/homepage.hamlet.cg,
-  scaffold/mini/Handler/Root.hs.cg,
-  scaffold/mini/config/routes.cg,
-  scaffold/mini/config/Settings.hs.cg,
-  scaffold/static/css/html5boilerplate.css.cg,
-  scaffold/pconn1.cg,
-  scaffold/.ghci.cg,
-  scaffold/cabal.cg,
-  scaffold/deploy/Procfile.cg,
-  scaffold/Controller.hs.cg,
-  scaffold/julius/homepage.julius.cg,
-  scaffold/hamlet/homepage.hamlet.cg,
-  scaffold/hamlet/default-layout.hamlet.cg,
-  scaffold/hamlet/boilerplate-layout.hamlet.cg,
-  scaffold/project.hs.cg,
-  scaffold/Handler/Root.hs.cg,
-  scaffold/config/models.cg,
-  scaffold/config/sqlite.yml.cg,
-  scaffold/config/settings.yml.cg,
-  scaffold/config/favicon.ico.cg,
-  scaffold/config/postgresql.yml.cg,
-  scaffold/config/routes.cg,
-  scaffold/config/Settings.hs.cg,
+  scaffold/cassius/default-layout.cassius.cg
+  scaffold/cassius/homepage.cassius.cg
+  scaffold/Model.hs.cg
+  scaffold/sitearg.hs.cg
+  scaffold/LICENSE.cg
+  scaffold/mongoDBConnPool.cg
+  scaffold/mini/sitearg.hs.cg
+  scaffold/mini/cabal.cg
+  scaffold/mini/Controller.hs.cg
+  scaffold/mini/hamlet/homepage.hamlet.cg
+  scaffold/mini/Handler/Root.hs.cg
+  scaffold/mini/config/routes.cg
+  scaffold/mini/config/Settings.hs.cg
+  scaffold/static/css/html5boilerplate.css.cg
+  scaffold/postgresqlConnPool.cg
+  scaffold/sqliteConnPool.cg
+  scaffold/.ghci.cg
+  scaffold/cabal.cg
+  scaffold/Controller.hs.cg
+  scaffold/julius/homepage.julius.cg
+  scaffold/hamlet/homepage.hamlet.cg
+  scaffold/hamlet/default-layout.hamlet.cg
+  scaffold/hamlet/boilerplate-layout.hamlet.cg
+  scaffold/deploy/Procfile.cg
+  scaffold/project.hs.cg
+  scaffold/Handler/Root.hs.cg
+  scaffold/config/models.cg
+  scaffold/config/sqlite.yml.cg
+  scaffold/config/settings.yml.cg
+  scaffold/config/favicon.ico.cg
+  scaffold/config/postgresql.yml.cg
+  scaffold/config/mongoDB.yml.cg
+  scaffold/config/routes.cg
+  scaffold/config/Settings.hs.cg
   scaffold/config/StaticFiles.hs.cg