diff --git a/development.md b/development.md new file mode 100644 index 00000000..c9b5b7b8 --- /dev/null +++ b/development.md @@ -0,0 +1,5 @@ +# Scaffolding + +## Test suite + + shelltest test/scaffold.shelltest diff --git a/scaffold.hs b/scaffold.hs index 210c0bd2..079765c3 100644 --- a/scaffold.hs +++ b/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") diff --git a/scaffold/Controller_hs.cg b/scaffold/Controller_hs.cg index 324816ee..f6d8c961 100644 --- a/scaffold/Controller_hs.cg +++ b/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 ()) diff --git a/scaffold/Settings_hs.cg b/scaffold/Settings_hs.cg index d4d35ac0..5641eeed 100644 --- a/scaffold/Settings_hs.cg +++ b/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 diff --git a/scaffold/cabal.cg b/scaffold/cabal.cg index 84d0e91f..b58eaf07 100644 --- a/scaffold/cabal.cg +++ b/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 diff --git a/scaffold/mini-Controller_hs.cg b/scaffold/mini-Controller_hs.cg index 36999c82..c4947ee9 100644 --- a/scaffold/mini-Controller_hs.cg +++ b/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 ()) diff --git a/scaffold/mini-cabal.cg b/scaffold/mini-cabal.cg index 7e69d651..09793f79 100644 --- a/scaffold/mini-cabal.cg +++ b/scaffold/mini-cabal.cg @@ -55,6 +55,8 @@ executable ~project~ , template-haskell , hamlet , transformers + , data-object + , data-object-yaml , wai , warp , blaze-builder diff --git a/scaffold/mini-sitearg_hs.cg b/scaffold/mini-sitearg_hs.cg index 2d94cc5d..aee7f6d1 100644 --- a/scaffold/mini-sitearg_hs.cg +++ b/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 diff --git a/scaffold/pconn1.cg b/scaffold/pconn1.cg index 2fbf5964..ea8ef468 100644 --- a/scaffold/pconn1.cg +++ b/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" diff --git a/scaffold/pconn2.cg b/scaffold/pconn2.cg deleted file mode 100644 index 5dbfefe0..00000000 --- a/scaffold/pconn2.cg +++ /dev/null @@ -1 +0,0 @@ -user=~project~ password=~project~ host=localhost port=5432 dbname=~project~_production diff --git a/scaffold/postgresql_yml.cg b/scaffold/postgresql_yml.cg new file mode 100644 index 00000000..28926dab --- /dev/null +++ b/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 diff --git a/scaffold/settings_yml.cg b/scaffold/settings_yml.cg new file mode 100644 index 00000000..38053042 --- /dev/null +++ b/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 diff --git a/scaffold/sitearg_hs.cg b/scaffold/sitearg_hs.cg index a80a3acb..a39a6f71 100644 --- a/scaffold/sitearg_hs.cg +++ b/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' diff --git a/scaffold/sqlite_yml.cg b/scaffold/sqlite_yml.cg new file mode 100644 index 00000000..ec25b88e --- /dev/null +++ b/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 diff --git a/scaffold/test_hs.cg b/scaffold/test_hs.cg index 35527958..f27521f1 100644 --- a/scaffold/test_hs.cg +++ b/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 diff --git a/tests/runscaffold.sh b/tests/runscaffold.sh new file mode 100755 index 00000000..261dc7eb --- /dev/null +++ b/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 .. diff --git a/tests/sample-input.txt b/tests/sample-input.txt new file mode 100644 index 00000000..6b02a6e9 --- /dev/null +++ b/tests/sample-input.txt @@ -0,0 +1,4 @@ +Michael +foobar +Foobar +s diff --git a/test.shelltest b/tests/scaffold.shelltest similarity index 100% rename from test.shelltest rename to tests/scaffold.shelltest