Merge pull request #89 from gregwebs/org

Org

CodeGen.hs

@@ -1,7 +1,7 @@
 {-# LANGUAGE TemplateHaskell #-}
 -- | A code generation template haskell. Everything is taken as literal text,
 -- with ~var~ variable interpolation.
-module CodeGen (codegen) where
+module CodeGen (codegen, codegenDir) where
 
 import Language.Haskell.TH.Syntax
 import Text.ParserCombinators.Parsec
@@ -11,9 +11,9 @@ import qualified Data.Text.Lazy.Encoding as LT
 
 data Token = VarToken String | LitToken String | EmptyToken
 
-codegen :: FilePath -> Q Exp
+codegenDir :: FilePath -> FilePath -> Q Exp
-codegen fp = do
+codegenDir dir fp = do
-    s' <- qRunIO $ L.readFile $ "scaffold/" ++ fp ++ ".cg"
+    s' <- qRunIO $ L.readFile $ (dir ++ "/" ++ fp ++ ".cg")
     let s = init $ LT.unpack $ LT.decodeUtf8 s'
     case parse (many parseToken) s s of
         Left e -> error $ show e
@@ -22,6 +22,9 @@ codegen fp = do
             concat' <- [|concat|]
             return $ concat' `AppE` ListE tokens''
 
+codegen :: FilePath -> Q Exp
+codegen fp = codegenDir "scaffold" fp
+
 toExp :: Token -> Exp
 toExp (LitToken s) = LitE $ StringL s
 toExp (VarToken s) = VarE $ mkName s

development.md

@@ -2,4 +2,18 @@
 
 ## Test suite
 
-  shelltest test/scaffold.shelltest
+Run this from the project root directory. It will make sure each site type builds. It first does an sdist, which ensures we are testing what will be put on hackage.
+
+  shelltest tests/scaffold.shelltest
+
+## Quicker, repeatable site building
+
+Useful for debugging individual failures.
+
+  tests/runscaffold.sh < sqlite-input.txt
+
+## Getting a list of scaffold files for the cabal file
+
+It is necessary after adding a scaffolding file to add it to the list of files in the cabal file.
+
+  find scaffold -type f

scaffold.hs

@@ -53,10 +53,10 @@ puts s = putStr s >> hFlush stdout
 
 scaffold :: IO ()
 scaffold = do
-    puts $(codegen "welcome")
+    puts $(codegenDir "input" "welcome")
     name <- getLine
 
-    puts $(codegen "project-name")
+    puts $(codegenDir "input" "project-name")
     let validPN c
             | 'A' <= c && c <= 'Z' = True
             | 'a' <= c && c <= 'z' = True
@@ -66,11 +66,11 @@ scaffold = do
     project <- prompt $ all validPN
     let dir = project
 
-    puts $(codegen "site-arg")
+    puts $(codegenDir "input" "site-arg")
     let isUpperAZ c = 'A' <= c && c <= 'Z'
     sitearg <- prompt $ \s -> not (null s) && all validPN s && isUpperAZ (head s) && s /= "Main"
 
-    puts $(codegen "database")
+    puts $(codegenDir "input" "database")
     backendS <- prompt $ flip elem ["s", "p", "m"]
     let pconn1 = $(codegen "pconn1")
     let (backendLower, upper, connstr, importDB) =
@@ -102,38 +102,38 @@ scaffold = do
     mkDir "Model"
 
     case backendS of
-        "s" -> writeFile' ("config/" ++ backendLower ++ ".yml") $(codegen ("sqlite_yml"))
+        "s" -> writeFile' ("config/" ++ backendLower ++ ".yml") $(codegen ("config/sqlite.yml"))
-        "p" -> writeFile' ("config/" ++ backendLower ++ ".yml") $(codegen ("postgresql_yml"))
+        "p" -> writeFile' ("config/" ++ backendLower ++ ".yml") $(codegen ("config/postgresql.yml"))
         "m" -> return ()
         _ -> error $ "Invalid backend: " ++ backendS
 
-    writeFile' ("config/settings.yml") $(codegen "settings_yml")
+    writeFile' ("config/settings.yml") $(codegen "config/settings.yml")
-    writeFile' ("config/" ++ project ++ ".hs") $(codegen "test_hs")
+    writeFile' ("config/" ++ project ++ ".hs") $(codegen "project.hs")
-    writeFile' (project ++ ".cabal") $ if backendS == "m" then $(codegen "mini-cabal") else $(codegen "cabal")
+    writeFile' (project ++ ".cabal") $ if backendS == "m" then $(codegen "mini/cabal") else $(codegen "cabal")
-    writeFile' ".ghci" $(codegen "dotghci")
+    writeFile' ".ghci" $(codegen ".ghci")
     writeFile' "LICENSE" $(codegen "LICENSE")
-    writeFile' (sitearg ++ ".hs") $ if backendS == "m" then $(codegen "mini-sitearg_hs") else $(codegen "sitearg_hs")
+    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' "Controller.hs" $ if backendS == "m" then $(codegen "mini/Controller.hs") else $(codegen "Controller.hs")
-    writeFile' "Handler/Root.hs" $ if backendS == "m" then $(codegen "mini-Root_hs") else $(codegen "Root_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")
+    when (backendS /= "m") $ writeFile' "Model.hs" $(codegen "Model.hs")
-    writeFile' "config/Settings.hs" $ if backendS == "m" then $(codegen "mini-Settings_hs") else $(codegen "Settings_hs")
+    writeFile' "config/Settings.hs" $ if backendS == "m" then $(codegen "mini/config/Settings.hs") else $(codegen "config/Settings.hs")
-    writeFile' "config/StaticFiles.hs" $(codegen "StaticFiles_hs")
+    writeFile' "config/StaticFiles.hs" $(codegen "config/StaticFiles.hs")
     writeFile' "cassius/default-layout.cassius"
-        $(codegen "default-layout_cassius")
+        $(codegen "cassius/default-layout.cassius")
     writeFile' "hamlet/default-layout.hamlet"
-        $(codegen "default-layout_hamlet")
+        $(codegen "hamlet/default-layout.hamlet")
     writeFile' "hamlet/boilerplate-layout.hamlet"
-        $(codegen "boilerplate-layout_hamlet")
+        $(codegen "hamlet/boilerplate-layout.hamlet")
     writeFile' "static/css/html5boilerplate.css"
-        $(codegen "boilerplate_css")
+        $(codegen "static/css/html5boilerplate.css")
-    writeFile' "hamlet/homepage.hamlet" $ if backendS == "m" then $(codegen "mini-homepage_hamlet") else $(codegen "homepage_hamlet")
+    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-routes") else $(codegen "routes")
+    writeFile' "config/routes" $ if backendS == "m" then $(codegen "mini/config/routes") else $(codegen "config/routes")
-    writeFile' "cassius/homepage.cassius" $(codegen "homepage_cassius")
+    writeFile' "cassius/homepage.cassius" $(codegen "cassius/homepage.cassius")
-    writeFile' "julius/homepage.julius" $(codegen "homepage_julius")
+    writeFile' "julius/homepage.julius" $(codegen "julius/homepage.julius")
-    unless (backendS == "m") $ writeFile' "config/models" $(codegen "entities")
+    unless (backendS == "m") $ writeFile' "config/models" $(codegen "config/models")
   
     S.writeFile (dir ++ "/config/favicon.ico")
-        $(runIO (S.readFile "scaffold/favicon_ico.cg") >>= \bs -> do
+        $(runIO (S.readFile "scaffold/config/favicon.ico.cg") >>= \bs -> do
             pack <- [|S.pack|]
             return $ pack `AppE` LitE (StringL $ S.unpack bs))
     

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

@@ -17,4 +17,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

@@ -3,29 +3,25 @@ import qualified Settings as Settings
 import Settings (AppConfig(..))
 import Controller (with~sitearg~)
 import Network.Wai.Handler.Warp (run)
-import System.Console.CmdArgs
+import System.Console.CmdArgs hiding (args)
 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
+    env <- getAppEnv args
-    config <- Settings.loadConfig appEnv
+    config <- Settings.loadConfig env
     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)
+#if PRODUCTION
+    with~sitearg~ c $ run (appPort c)
+#else
+    hPutStrLn stderr $ (show env) ++ " 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 ..

tests/scaffold.shelltest

@@ -1,9 +1,13 @@
-# use shelltest
+# This uses shelltest
-# note that the first cabal install line is its own test
+#
-# cabal install shelltestrunner
+#   cabal install shelltestrunner
-# shelltest test.shelltest
+#   shelltest tests/scaffold.shelltest
+#
+# note that the first 2 lines setup this test but will also be counted as 2 tests.
 
-cabal clean && cabal install
+cabal clean && cabal install && cabal sdist
+
+for f in $(ls -1rt dist/*.tar.gz | tail -1); do tar -xzvf $f && cd `basename $f .tar.gz`; done
 
 rm -rf foobar && runghc scaffold.hs init && cd foobar && cabal install && cabal install -fdevel && cd ..
 <<<

yesod.cabal

@@ -14,7 +14,39 @@ stability:       Stable
 cabal-version:   >= 1.6
 build-type:      Simple
 homepage:        http://www.yesodweb.com/
-extra-source-files: scaffold/*.cg
+
+extra-source-files:
+  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/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/config/StaticFiles.hs.cg
+
 
 flag ghc7