diff --git a/yesod/input/database.cg b/yesod/input/database.cg index 198c20ac..e1606bcb 100644 --- a/yesod/input/database.cg +++ b/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: diff --git a/yesod/scaffold.hs b/yesod/scaffold.hs index 7a615f7d..f5fb0857 100644 --- a/yesod/scaffold.hs +++ b/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 diff --git a/yesod/scaffold/cabal.cg b/yesod/scaffold/cabal.cg index 8a0041bd..f2132953 100644 --- a/yesod/scaffold/cabal.cg +++ b/yesod/scaffold/cabal.cg @@ -61,6 +61,7 @@ executable ~project~ , persistent , persistent-template , persistent-~backendLower~ >= 0.6 && < 0.7 + ~packages~ , template-haskell , hamlet , hjsmin diff --git a/yesod/scaffold/config/Settings.hs.cg b/yesod/scaffold/config/Settings.hs.cg index a55b065a..83690457 100644 --- a/yesod/scaffold/config/Settings.hs.cg +++ b/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, diff --git a/yesod/scaffold/config/mongoDB.yml.cg b/yesod/scaffold/config/mongoDB.yml.cg new file mode 100644 index 00000000..60f74187 --- /dev/null +++ b/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 diff --git a/yesod/scaffold/config/postgresql.yml.cg b/yesod/scaffold/config/postgresql.yml.cg index 28926dab..2f60ddab 100644 --- a/yesod/scaffold/config/postgresql.yml.cg +++ b/yesod/scaffold/config/postgresql.yml.cg @@ -13,7 +13,7 @@ Test: <<: *defaults Staging: - <<: *defaults + database: ~project~_staging Production: database: ~project~_production diff --git a/yesod/scaffold/config/sqlite.yml.cg b/yesod/scaffold/config/sqlite.yml.cg index ec25b88e..b9f01df1 100644 --- a/yesod/scaffold/config/sqlite.yml.cg +++ b/yesod/scaffold/config/sqlite.yml.cg @@ -9,6 +9,7 @@ Test: <<: *defaults Staging: + database: ~project~_staging.sqlite3 <<: *defaults Production: diff --git a/yesod/scaffold/mongoDBConnPool.cg b/yesod/scaffold/mongoDBConnPool.cg new file mode 100644 index 00000000..ef6eb757 --- /dev/null +++ b/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) diff --git a/yesod/scaffold/pconn1.cg b/yesod/scaffold/pconn1.cg deleted file mode 100644 index 370aa79d..00000000 --- a/yesod/scaffold/pconn1.cg +++ /dev/null @@ -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) - diff --git a/yesod/scaffold/postgresqlConnPool.cg b/yesod/scaffold/postgresqlConnPool.cg new file mode 100644 index 00000000..9dab35cb --- /dev/null +++ b/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 + diff --git a/yesod/scaffold/sitearg.hs.cg b/yesod/scaffold/sitearg.hs.cg index 5ed94bf5..e53d3667 100644 --- a/yesod/scaffold/sitearg.hs.cg +++ b/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 diff --git a/yesod/scaffold/sqliteConnPool.cg b/yesod/scaffold/sqliteConnPool.cg new file mode 100644 index 00000000..c1b2d434 --- /dev/null +++ b/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 + diff --git a/yesod/tests/scaffold.shelltest b/yesod/tests/scaffold.shelltest index a35a8554..b8a77585 100644 --- a/yesod/tests/scaffold.shelltest +++ b/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 diff --git a/yesod/tests/mini-input.txt b/yesod/tests/tiny-input.txt similarity index 91% rename from yesod/tests/mini-input.txt rename to yesod/tests/tiny-input.txt index 079224e8..fb1fe817 100644 --- a/yesod/tests/mini-input.txt +++ b/yesod/tests/tiny-input.txt @@ -1,4 +1,4 @@ Michael foobar Foobar -m +t diff --git a/yesod/yesod.cabal b/yesod/yesod.cabal index d8845d25..80f2480d 100644 --- a/yesod/yesod.cabal +++ b/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