Merge branch 'master' of github.com:yesodweb/yesod

.gitignore

@@ -1,5 +1,7 @@
 *.o
+*.o_p
 *.hi
 dist
 *.swp
 client_session_key.aes
+cabal-dev/

README.md

@@ -1,5 +1,4 @@
-A next generation web framework using the Haskell programming language, 
-featuring:
+An advanced web framework using the Haskell programming language. Featuring:
 
   * safety & security guaranteed at compile time
   * performance
@@ -12,25 +11,108 @@ featuring:
 
 ## Installation: http://www.yesodweb.com/page/five-minutes
 
+    cabal update && cabal install yesod
+
 ## Create a new project after installing
 
     yesod init
 
 
+## Using cabal-dev
+
+cabal-dev creates a sandboxed environment for an individual cabal package.
+Your application is a cabal package and you should use cabal-dev with your Yesod application.
+Instead of using the `cabal` command, use the `cabal-dev` command.
+
+Use `yesod-devel --dev` when developing your application.
+
 ## Installing the latest development version from github
 
-Yesod is built upon many smaller packages, all of which can be installed 
-with:
+Yesod is broken up into 4 separate code repositories each built upon many smaller packages.
+
+Install conflicts are unfortunately common in Haskell development.
+However, we can prevent most of them by using some extra tools.
+This will require a little up-front reading and learning, but save you from a lot of misery in the long-run.
+See the above explanation of cabal-dev, and below of virthualenv.
+
+Please note that cabal-dev will not work in a virthualenv shell - you can't use both at the same time.
+
+### virthualenv
+
+To just install Yesod from github, we only need cabal-dev. However, cabal-dev may be more hassle than it is worth when hacking on Yesod.
+
+We recommend using [virthualenv](http://hackage.haskell.org/package/virthualenv) when hacking on Yesod.
+This is optional, but prevents your custom build of Yesod from interfering with your currently installed cabal packages.
+virthualenv creates an isolated environment like cabal-dev.
+cabal-dev isolates a single cabal package, but virthualenv isolates multiple packages together.
+
+virthualenv works at the shell level, so every shell must activate the virthualenv.
+
+### cabal-src
+
+Michael just released the cabal-src tool. Whenever you would use `cabal install` for a local package, use `cabal-src-install` instead.
+Our installer script now uses cabal-src-install when it is available.
+
+### Building Yesod
 
 ~~~ { .bash }
+# update your package database if you haven't recently
 cabal update
+# install required libraries
+cabal install Cabal cabal-install cabal-src virthualenv
 
+# clone and install all repos
+# see below about first using virthualenv before running ./scripts/install
 for repo in hamlet persistent wai yesod; do
   git clone http://github.com/yesodweb/$repo
   (
     cd $repo
     git submodule update --init
-    ./script/install
+    ./scripts/install
   )
 done
 ~~~
+
+### Hacking on Yesod
+
+To prevent Yesod from conflicting with your other installs, you should use virthualenv, although it is optional.
+
+#### virthualenv
+
+~~~ { .bash }
+cabal update
+cabal install virthualenv
+cd yesodweb
+virthualenv --name=yesod
+. .virthualenv/bin/activate
+~~~
+
+#### individual cabal packages
+
+~~~ { .bash }
+# install and test all packages
+./scripts/install
+
+# move to the individual package you are working on
+cd shakespeare-text
+
+# build and test the individual package
+cabal configure -ftest --enable-tests
+cabal build
+cabal test
+~~~
+
+#### cabal-dev
+
+cabal-dev works very well if you are working on a single package, but it can be very cumbersome to work on multiple packages at once.
+
+### Use your development version of Yesod in your application
+
+Note that we have told you to install Yesod into a sandboxed virthualenv environment.
+This means it is not available through your user/global cabal database for your application.
+Instead you should use `cabal-dev install` to retrieve these packages.
+cd to your application directory, and the reference the source list.
+
+~~~ { .bash }
+cabal-dev install /path/to/yesodweb/yesod/*(/)
+~~~

input

@@ -0,0 +1 @@
+yesod/input

package-list.sh

@@ -0,0 +1,12 @@
+#!/bin/bash
+
+pkgs=(      ./yesod-core
+            ./yesod-json
+            ./yesod-static
+            ./yesod-persistent
+            ./yesod-newsfeed
+            ./yesod-form
+            ./yesod-auth
+            ./yesod-sitemap
+            ./yesod-default
+            ./yesod                 )

scaffold

@@ -0,0 +1 @@
+yesod/scaffold

scripts

@@ -1 +1 @@
-Subproject commit f56426fada59012329f23c928a2d7f9c3a515d75
+Subproject commit 713588bcf3526aad8a809215fb34c314334a5ffd

sources.txt

@@ -0,0 +1,10 @@
+yesod-core
+yesod-json
+yesod-static
+yesod-persistent
+yesod-newsfeed
+yesod-form
+yesod-auth
+yesod-sitemap
+yesod-default
+yesod

test/en.msg

@@ -0,0 +1 @@
+../yesod-core/test/en.msg

test/fs

@@ -0,0 +1 @@
+../yesod-static/test/fs

test/main.hs

@@ -0,0 +1,9 @@
+import Test.Hspec
+import qualified YesodCoreTest
+import qualified YesodStaticTest
+
+main :: IO ()
+main = hspecX $ descriptions [
+    concat YesodCoreTest.specs
+  , concat YesodStaticTest.specs
+  ]

yesod-auth/Yesod/Auth.hs

@@ -34,7 +34,11 @@ import Data.Text.Encoding (decodeUtf8With)
 import Data.Text.Encoding.Error (lenientDecode)
 import           Data.Text (Text)
 import qualified Data.Text as T
+#if MIN_VERSION_aeson(0, 4, 0)
+import qualified Data.HashMap.Lazy as Map
+#else
 import qualified Data.Map as Map
+#endif
 
 import Language.Haskell.TH.Syntax hiding (lift)
 
@@ -96,6 +100,11 @@ class (Yesod m, SinglePiece (AuthId m), RenderMessage m FormMessage) => YesodAut
                       -> AuthMessage -> Text
     renderAuthMessage _ _ = defaultMessage
 
+    -- | After login and logout, redirect to the referring page, instead of
+    -- 'loginDest' and 'logoutDest'. Default is 'False'.
+    redirectToReferer :: m -> Bool
+    redirectToReferer _ = False
+
 mkYesodSub "Auth"
     [ ClassP ''YesodAuth [VarT $ mkName "master"]
     ]
@@ -134,7 +143,7 @@ getCheckR = do
     creds <- maybeAuthId
     defaultLayoutJson (do
         setTitle "Authentication Status"
-        addHtml $ html' creds) (json' creds)
+        addHtml $ html' creds) (jsonCreds creds)
   where
     html' creds =
         [QQ(shamlet)|
@@ -144,16 +153,21 @@ $maybe _ <- creds
 $nothing
     <p>Not logged in.
 |]
-    json' creds =
+    jsonCreds creds =
         Object $ Map.fromList
             [ (T.pack "logged_in", Bool $ maybe False (const True) creds)
             ]
 
+setUltDestReferer' :: YesodAuth master => GHandler sub master ()
+setUltDestReferer' = do
+    m <- getYesod
+    when (redirectToReferer m) setUltDestReferer
+
 getLoginR :: YesodAuth m => GHandler Auth m RepHtml
-getLoginR = setUltDestReferer >> loginHandler
+getLoginR = setUltDestReferer' >> loginHandler
 
 getLogoutR :: YesodAuth m => GHandler Auth m ()
-getLogoutR = setUltDestReferer >> postLogoutR -- FIXME redirect to post
+getLogoutR = setUltDestReferer' >> postLogoutR -- FIXME redirect to post
 
 postLogoutR :: YesodAuth m => GHandler Auth m ()
 postLogoutR = do

yesod-auth/Yesod/Auth/Email.hs

@@ -203,7 +203,7 @@ getPasswordR = do
         Just _ -> return ()
         Nothing -> do
             setMessageI Msg.BadSetPass
-            redirect RedirectTemporary $ toMaster loginR
+            redirect RedirectTemporary $ toMaster LoginR
     defaultLayout $ do
         setTitleI Msg.SetPassTitle
         addWidget
@@ -238,7 +238,7 @@ postPasswordR = do
     aid <- case maid of
             Nothing -> do
                 setMessageI Msg.BadSetPass
-                redirect RedirectTemporary $ toMaster loginR
+                redirect RedirectTemporary $ toMaster LoginR
             Just aid -> return aid
     salted <- liftIO $ saltPass new
     setPassword aid salted

yesod-auth/Yesod/Auth/Facebook.hs

@@ -3,7 +3,10 @@
 {-# LANGUAGE OverloadedStrings #-}
 module Yesod.Auth.Facebook
     ( authFacebook
+    , facebookLogin
     , facebookUrl
+    , facebookLogout
+    , getFacebookAccessToken
     ) where
 
 #include "qq.h"
@@ -17,20 +20,48 @@ import Data.Maybe (fromMaybe)
 import Yesod.Form
 import Yesod.Handler
 import Yesod.Widget
-import Control.Monad.IO.Class (liftIO)
+import Control.Monad.IO.Class (MonadIO, liftIO)
 import Control.Monad.Trans.Class (lift)
 import Data.Text (Text)
-import Control.Monad (mzero)
+import Control.Monad (liftM, mzero, when)
 import Data.Monoid (mappend)
 import qualified Data.Aeson.Types
 import qualified Yesod.Auth.Message as Msg
 
-facebookUrl :: AuthRoute
-facebookUrl = PluginR "facebook" ["forward"]
+-- | Route for login using this authentication plugin.
+facebookLogin :: AuthRoute
+facebookLogin = PluginR "facebook" ["forward"]
 
+-- | This is just a synonym of 'facebookLogin'.  Deprecated since
+-- @yesod-auth 0.7.8@, please use 'facebookLogin' instead.
+facebookUrl :: AuthRoute
+facebookUrl = facebookLogin
+{-# DEPRECATED facebookUrl "Please use facebookLogin instead." #-}
+
+-- | Route for logout using this authentication plugin.  Per
+-- Facebook's policies
+-- (<https://developers.facebook.com/policy/>), the user needs to
+-- logout from Facebook itself as well.
+facebookLogout :: AuthRoute
+facebookLogout = PluginR "facebook" ["logout"]
+
+-- | Get Facebook's access token from the session.  Returns
+-- @Nothing@ if it's not found (probably because the user is not
+-- logged in via Facebook).  Note that the returned access token
+-- may have expired.
+getFacebookAccessToken :: MonadIO mo => GGHandler sub master mo (Maybe Facebook.AccessToken)
+getFacebookAccessToken =
+    liftM (fmap Facebook.AccessToken) (lookupSession facebookAccessTokenKey)
+
+-- | Key used to store Facebook's access token in the client
+-- session.
+facebookAccessTokenKey :: Text
+facebookAccessTokenKey = "_FB"
+
+-- | Authentication plugin using Facebook.
 authFacebook :: YesodAuth m
-             => Text -- ^ Application ID
-             -> Text -- ^ Application secret
+             => Text   -- ^ Application ID
+             -> Text   -- ^ Application secret
              -> [Text] -- ^ Requested permissions
              -> AuthPlugin m
 authFacebook cid secret perms =
@@ -49,10 +80,24 @@ authFacebook cid secret perms =
         code <- runInputGet $ ireq textField "code"
         at <- liftIO $ Facebook.getAccessToken fb code
         let Facebook.AccessToken at' = at
+        setSession facebookAccessTokenKey at'
         so <- liftIO $ Facebook.getGraphData at "me"
         let c = fromMaybe (error "Invalid response from Facebook")
                 $ parseMaybe (parseCreds at') $ either error id so
         setCreds True c
+    dispatch "GET" ["logout"] = do
+        m <- getYesod
+        tm <- getRouteToMaster
+        mtoken <- getFacebookAccessToken
+        when (redirectToReferer m) setUltDestReferer
+        case mtoken of
+          Nothing -> do
+            -- Well... then just logout from our app.
+            redirect RedirectTemporary (tm LogoutR)
+          Just at -> do
+            render <- getUrlRender
+            let logout = Facebook.getLogoutUrl at (render $ tm LogoutR)
+            redirectText RedirectTemporary logout
     dispatch _ _ = notFound
     login tm = do
         render <- lift getUrlRender
@@ -67,8 +112,8 @@ parseCreds :: Text -> Value -> Data.Aeson.Types.Parser (Creds m)
 parseCreds at' (Object m) = do
     id' <- m .: "id"
     let id'' = "http://graph.facebook.com/" `mappend` id'
-    name <- m .: "name"
-    email <- m .: "email"
+    name <- m .:? "name"
+    email <- m .:? "email"
     return
         $ Creds "facebook" id''
         $ maybe id (\x -> (:) ("verifiedEmail", x)) email

yesod-auth/Yesod/Auth/GoogleEmail.hs

@@ -0,0 +1,99 @@
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
+-- | Use an email address as an identifier via Google's OpenID login system.
+--
+-- This backend will not use the OpenID identifier at all. It only uses OpenID
+-- as a login system. By using this plugin, you are trusting Google to validate
+-- an email address, and requiring users to have a Google account. On the plus
+-- side, you get to use email addresses as the identifier, many users have
+-- existing Google accounts, the login system has been long tested (as opposed
+-- to BrowserID), and it requires no credential managing or setup (as opposed
+-- to Email).
+module Yesod.Auth.GoogleEmail
+    ( authGoogleEmail
+    , forwardUrl
+    ) where
+
+import Yesod.Auth
+import qualified Web.Authenticate.OpenId as OpenId
+import Control.Monad.Attempt
+
+import Yesod.Form
+import Yesod.Handler
+import Yesod.Widget
+import Yesod.Request
+import Text.Blaze (toHtml)
+import Data.Text (Text)
+import qualified Yesod.Auth.Message as Msg
+import qualified Data.Text as T
+
+forwardUrl :: AuthRoute
+forwardUrl = PluginR "googleemail" ["forward"]
+
+authGoogleEmail :: YesodAuth m => AuthPlugin m
+authGoogleEmail =
+    AuthPlugin "googleemail" dispatch login
+  where
+    complete = PluginR "googleemail" ["complete"]
+    name = "openid_identifier"
+    login tm = do
+        [whamlet|
+<form method=get action=@{tm forwardUrl}>
+    <input type=hidden name=openid_identifier value=https://www.google.com/accounts/o8/id>
+    <input type=submit value=_{Msg.LoginTitle}>
+|]
+    dispatch "GET" ["forward"] = do
+        roid <- runInputGet $ iopt textField name
+        case roid of
+            Just oid -> do
+                render <- getUrlRender
+                toMaster <- getRouteToMaster
+                let complete' = render $ toMaster complete
+                res <- runAttemptT $ OpenId.getForwardUrl oid complete' Nothing
+                    [ ("openid.ax.type.email", "http://schema.openid.net/contact/email")
+                    , ("openid.ns.ax", "http://openid.net/srv/ax/1.0")
+                    , ("openid.ns.ax.required", "email")
+                    , ("openid.ax.mode", "fetch_request")
+                    , ("openid.ax.required", "email")
+                    , ("openid.ui.icon", "true")
+                    ]
+                attempt
+                  (\err -> do
+                        setMessage $ toHtml $ show err
+                        redirect RedirectTemporary $ toMaster LoginR
+                        )
+                  (redirectText RedirectTemporary)
+                  res
+            Nothing -> do
+                toMaster <- getRouteToMaster
+                setMessageI Msg.NoOpenID
+                redirect RedirectTemporary $ toMaster LoginR
+    dispatch "GET" ["complete", ""] = dispatch "GET" ["complete"] -- compatibility issues
+    dispatch "GET" ["complete"] = do
+        rr <- getRequest
+        completeHelper $ reqGetParams rr
+    dispatch "POST" ["complete", ""] = dispatch "POST" ["complete"] -- compatibility issues
+    dispatch "POST" ["complete"] = do
+        (posts, _) <- runRequestBody
+        completeHelper posts
+    dispatch _ _ = notFound
+
+completeHelper :: YesodAuth m => [(Text, Text)] -> GHandler Auth m ()
+completeHelper gets' = do
+        res <- runAttemptT $ OpenId.authenticate gets'
+        toMaster <- getRouteToMaster
+        let onFailure err = do
+            setMessage $ toHtml $ show err
+            redirect RedirectTemporary $ toMaster LoginR
+        let onSuccess (OpenId.Identifier ident, _) = do
+                memail <- lookupGetParam "openid.ext1.value.email"
+                case (memail, "https://www.google.com/accounts/o8/id" `T.isPrefixOf` ident) of
+                    (Just email, True) -> setCreds True $ Creds "openid" email []
+                    (_, False) -> do
+                        setMessage "Only Google login is supported"
+                        redirect RedirectTemporary $ toMaster LoginR
+                    (Nothing, _) -> do
+                        setMessage "No email address provided"
+                        redirect RedirectTemporary $ toMaster LoginR
+        attempt onFailure onSuccess res

yesod-auth/Yesod/Auth/HashDB.hs

@@ -98,10 +98,18 @@ class HashDBUser user where
   userPasswordHash :: user -> Maybe Text
   -- | Retrieve salt for password
   userPasswordSalt :: user -> Maybe Text
-  -- | Set hash and password
+
+  -- | Deprecated for the better named setSaltAndPasswordHash 
   setUserHashAndSalt :: Text    -- ^ Salt
                      -> Text    -- ^ Password hash
                      -> user -> user
+  setUserHashAndSalt = setSaltAndPasswordHash
+
+  -- | a callback for setPassword
+  setSaltAndPasswordHash :: Text    -- ^ Salt
+                     -> Text    -- ^ Password hash
+                     -> user -> user
+  setSaltAndPasswordHash = setUserHashAndSalt
 
 -- | Generate random salt. Length of 8 is chosen arbitrarily
 randomSalt :: MonadIO m => m Text
@@ -118,7 +126,7 @@ saltedHash salt =
 --   passwords. It generates random salt and calculates proper hashes.
 setPassword :: (MonadIO m, HashDBUser user) => Text -> user -> m user
 setPassword pwd u = do salt <- randomSalt
-                       return $ setUserHashAndSalt salt (saltedHash salt pwd) u
+                       return $ setSaltAndPasswordHash salt (saltedHash salt pwd) u
 
 
 ----------------------------------------------------------------
@@ -256,6 +264,6 @@ User
 instance HashDBUser (UserGeneric backend) where
   userPasswordHash = Just . userPassword
   userPasswordSalt = Just . userSalt
-  setUserHashAndSalt s h u = u { userSalt     = s
+  setSaltAndPasswordHash s h u = u { userSalt     = s
                                , userPassword = h
                                }

yesod-auth/Yesod/Auth/Message.hs

@@ -10,6 +10,8 @@ import Data.Text (Text)
 data AuthMessage =
       NoOpenID
     | LoginOpenID
+    | LoginGoogle
+    | LoginYahoo
     | Email
     | Password
     | Register
@@ -37,6 +39,8 @@ data AuthMessage =
 defaultMessage :: AuthMessage -> Text
 defaultMessage NoOpenID = "No OpenID identifier found"
 defaultMessage LoginOpenID = "Login via OpenID"
+defaultMessage LoginGoogle = "Login via Google"
+defaultMessage LoginYahoo = "Login via Yahoo"
 defaultMessage Email = "Email"
 defaultMessage Password = "Password"
 defaultMessage Register = "Register"

yesod-auth/Yesod/Auth/OpenId.hs

@@ -3,6 +3,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 module Yesod.Auth.OpenId
     ( authOpenId
+    , authOpenIdExtended
     , forwardUrl
     ) where
 
@@ -26,7 +27,10 @@ forwardUrl :: AuthRoute
 forwardUrl = PluginR "openid" ["forward"]
 
 authOpenId :: YesodAuth m => AuthPlugin m
-authOpenId =
+authOpenId = authOpenIdExtended []
+
+authOpenIdExtended :: YesodAuth m => [(Text, Text)] -> AuthPlugin m
+authOpenIdExtended extensionFields =
     AuthPlugin "openid" dispatch login
   where
     complete = PluginR "openid" ["complete"]
@@ -39,6 +43,12 @@ authOpenId =
     padding-left: 18px;
 |]
         [QQ(whamlet)|
+<form method="get" action="@{tm forwardUrl}">
+    <input type="hidden" name="openid_identifier" value="https://www.google.com/accounts/o8/id">
+    <button .openid-google>_{Msg.LoginGoogle}
+<form method="get" action="@{tm forwardUrl}">
+    <input type="hidden" name="openid_identifier" value="http://me.yahoo.com">
+    <button .openid-yahoo>_{Msg.LoginYahoo}
 <form method="get" action="@{tm forwardUrl}">
     <label for="#{ident}">OpenID: #
     <input id="#{ident}" type="text" name="#{name}" value="http://">
@@ -51,7 +61,7 @@ authOpenId =
                 render <- getUrlRender
                 toMaster <- getRouteToMaster
                 let complete' = render $ toMaster complete
-                res <- runAttemptT $ OpenId.getForwardUrl oid complete' Nothing []
+                res <- runAttemptT $ OpenId.getForwardUrl oid complete' Nothing extensionFields 
                 attempt
                   (\err -> do
                         setMessage $ toHtml $ show err
@@ -81,5 +91,5 @@ completeHelper gets' = do
             setMessage $ toHtml $ show err
             redirect RedirectTemporary $ toMaster LoginR
         let onSuccess (OpenId.Identifier ident, _) =
-                setCreds True $ Creds "openid" ident []
+                setCreds True $ Creds "openid" ident gets'
         attempt onFailure onSuccess res

yesod-auth/facebook.hs

@@ -10,7 +10,6 @@ import Web.Authenticate.Facebook
 import Yesod.Form
 
 data FB = FB Facebook
-type Handler = GHandler FB FB
 
 fb :: FB
 fb = FB Facebook

yesod-auth/openid.hs

@@ -0,0 +1,54 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+import Yesod.Core
+import Yesod.Auth
+import Yesod.Auth.OpenId
+import Data.Text (Text)
+import Text.Hamlet (hamlet)
+import Control.Monad.IO.Class (liftIO)
+import Yesod.Form
+import Network.Wai.Handler.Warp (run)
+
+data BID = BID
+
+mkYesod "BID" [parseRoutes|
+/ RootR GET
+/after AfterLoginR GET
+/auth AuthR Auth getAuth
+|]
+
+getRootR :: Handler RepHtml
+getRootR = getAfterLoginR
+
+getAfterLoginR :: Handler RepHtml
+getAfterLoginR = do
+    mauth <- maybeAuthId
+    defaultLayout $ addHamlet [hamlet|
+<p>Auth: #{show mauth}
+$maybe _ <- mauth
+    <p>
+        <a href=@{AuthR LogoutR}>Logout
+$nothing
+    <p>
+        <a href=@{AuthR LoginR}>Login
+|]
+
+instance Yesod BID where
+    approot _ = "http://localhost:3000"
+
+instance YesodAuth BID where
+    type AuthId BID = Text
+    loginDest _ = AfterLoginR
+    logoutDest _ = AuthR LoginR
+    getAuthId = return . Just . credsIdent
+    authPlugins = [authOpenId]
+
+instance RenderMessage BID FormMessage where
+    renderMessage _ _ = defaultFormMessage
+
+main :: IO ()
+main = toWaiApp BID >>= run 3000
+

yesod-auth/yesod-auth.cabal

@@ -1,5 +1,5 @@
 name:            yesod-auth
-version:         0.7.3
+version:         0.7.8
 license:         BSD3
 license-file:    LICENSE
 author:          Michael Snoyman, Patrick Brisbin
@@ -17,33 +17,34 @@ flag ghc7
 
 library
     if flag(ghc7)
-        build-depends:   base                      >= 4.3      && < 5
+        build-depends:   base                >= 4.3      && < 5
         cpp-options:     -DGHC7
     else
-        build-depends:   base                      >= 4        && < 4.3
-    build-depends:   authenticate            >= 0.10      && < 0.11
+        build-depends:   base                >= 4        && < 4.3
+    build-depends:   authenticate            >= 0.10.4    && < 0.11
                    , bytestring              >= 0.9.1.4   && < 0.10
-                   , yesod-core              >= 0.9       && < 0.10
+                   , yesod-core              >= 0.9.3.4   && < 0.10
                    , wai                     >= 0.4       && < 0.5
                    , template-haskell
-                   , pureMD5                 >= 1.1       && < 2.2
-                   , random                  >= 1.0       && < 1.1
+                   , pureMD5                 >= 2.0       && < 2.2
+                   , random                  >= 1.0.0.2  && < 1.1
                    , control-monad-attempt   >= 0.3.0     && < 0.4
                    , text                    >= 0.7       && < 0.12
-                   , mime-mail               >= 0.3       && < 0.4
-                   , blaze-html              >= 0.4       && < 0.5
+                   , mime-mail               >= 0.3       && < 0.5
+                   , blaze-html              >= 0.4.1.3   && < 0.5
                    , yesod-persistent        >= 0.2       && < 0.3
                    , hamlet                  >= 0.10      && < 0.11
                    , shakespeare-css         >= 0.10      && < 0.11
                    , yesod-json              >= 0.2       && < 0.3
-                   , containers              >= 0.2       && < 0.5
+                   , containers
+                   , unordered-containers
                    , yesod-form              >= 0.3       && < 0.4
-                   , transformers            >= 0.2       && < 0.3
+                   , transformers            >= 0.2.2     && < 0.3
                    , persistent              >= 0.6       && < 0.7
                    , persistent-template     >= 0.6       && < 0.7
                    , SHA                     >= 1.4.1.3   && < 1.6
                    , http-enumerator         >= 0.6       && < 0.8
-                   , aeson-native            >= 0.3.2.11  && < 0.4
+                   , aeson                   >= 0.3
                    , pwstore-fast            >= 2.2       && < 3
 
     exposed-modules: Yesod.Auth
@@ -57,9 +58,10 @@ library
                      Yesod.Auth.HashDB
                      Yesod.Auth.Message
                      Yesod.Auth.Kerberos
+                     Yesod.Auth.GoogleEmail
     ghc-options:     -Wall
     include-dirs: include
 
 source-repository head
   type:     git
-  location: git://github.com/snoyberg/yesod-auth.git
+  location: git://github.com/yesodweb/yesod.git

yesod-core/Yesod/Config.hs

@@ -0,0 +1,113 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Yesod.Config
+    {-# DEPRECATED "This code has been moved to yesod-default. This module will be removed in the next major version bump." #-}
+    ( AppConfig(..)
+    , loadConfig
+    , withYamlEnvironment
+    ) where
+
+import Control.Monad (join)
+import Data.Maybe (fromMaybe)
+import Data.Object
+import Data.Object.Yaml
+
+import Data.Text (Text)
+import qualified Data.Text as T
+
+-- | Dynamic per-environment configuration which can be loaded at
+--   run-time negating the need to recompile between environments.
+data AppConfig e = AppConfig
+    { appEnv  :: e
+    , appPort :: Int
+    , appRoot :: Text
+    } deriving (Show)
+
+-- | Load an @'AppConfig'@ from @config\/settings.yml@.
+--
+--   Some examples:
+--
+--   > -- typical local development
+--   > Development:
+--   >   host: localhost
+--   >   port: 3000
+--   >
+--   >   -- ssl: will default false
+--   >   -- approot: will default to "http://localhost:3000"
+--
+--   > -- typical outward-facing production box
+--   > Production:
+--   >   host: www.example.com
+--   >
+--   >   -- ssl: will default false
+--   >   -- port: will default 80
+--   >   -- approot: will default "http://www.example.com"
+--
+--   > -- maybe you're reverse proxying connections to the running app
+--   > -- on some other port
+--   > Production:
+--   >   port: 8080
+--   >   approot: "http://example.com"
+--   >
+--   > -- approot is specified so that the non-80 port is not appended
+--   > -- automatically.
+--
+loadConfig :: Show e => e -> IO (AppConfig e)
+loadConfig env = withYamlEnvironment "config/settings.yml" env $ \e' -> do
+    e <- maybe (fail "Expected map") return $ fromMapping e'
+    let mssl     = lookupScalar "ssl"     e
+    let mhost    = lookupScalar "host"    e
+    let mport    = lookupScalar "port"    e
+    let mapproot = lookupScalar "approot" e
+
+    -- set some default arguments
+    let ssl = maybe False toBool mssl
+    port <- safeRead "port" $ fromMaybe (if ssl then "443" else "80") mport
+
+    approot <- case (mhost, mapproot) of
+        (_        , Just ar) -> return ar
+        (Just host, _      ) -> return $ T.concat
+            [ if ssl then "https://" else "http://"
+            , host
+            , addPort ssl port
+            ]
+        _                    -> fail "You must supply either a host or approot"
+
+    return $ AppConfig
+        { appEnv  = env
+        , appPort = port
+        , appRoot = approot
+        }
+
+    where
+        toBool :: Text -> Bool
+        toBool = (`elem` ["true", "TRUE", "yes", "YES", "Y", "1"])
+
+        addPort :: Bool -> Int -> Text
+        addPort True  443 = ""
+        addPort False 80  = ""
+        addPort _     p   = T.pack $ ':' : show p
+
+-- | Loads the configuration block in the passed file named by the
+--   passed environment, yeilds to the passed function as a mapping.
+--
+--   Errors in the case of a bad load or if your function returns
+--   @Nothing@.
+withYamlEnvironment :: Show e
+                    => FilePath -- ^ the yaml file
+                    -> e        -- ^ the environment you want to load
+                    -> (TextObject -> IO a) -- ^ what to do with the mapping
+                    -> IO a
+withYamlEnvironment fp env f = do
+    obj <- join $ decodeFile fp
+    envs <- fromMapping obj
+    conf <- maybe (fail $ "Could not find environment: " ++ show env) return
+          $ lookup (T.pack $ show env) envs
+    f conf
+
+-- | Returns 'fail' if read fails
+safeRead :: Monad m => String -> Text -> m Int
+safeRead name t = case reads s of
+    (i, _):_ -> return i
+    []       -> fail $ concat ["Invalid value for ", name, ": ", s]
+  where
+    s = T.unpack t

yesod-core/Yesod/Core.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE TemplateHaskell #-}
+{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
 module Yesod.Core
     ( -- * Type classes
       Yesod (..)
@@ -33,6 +34,7 @@ module Yesod.Core
     , module Yesod.Request
     , module Yesod.Widget
     , module Yesod.Message
+    , module Yesod.Config
     ) where
 
 import Yesod.Internal.Core
@@ -42,6 +44,7 @@ import Yesod.Handler
 import Yesod.Request
 import Yesod.Widget
 import Yesod.Message
+import Yesod.Config
 
 import Language.Haskell.TH.Syntax
 import Data.Text (Text)

yesod-core/Yesod/Dispatch.hs

@@ -4,7 +4,9 @@
 module Yesod.Dispatch
     ( -- * Quasi-quoted routing
       parseRoutes
+    , parseRoutesNoCheck
     , parseRoutesFile
+    , parseRoutesFileNoCheck
     , mkYesod
     , mkYesodSub
       -- ** More fine-grained
@@ -30,11 +32,10 @@ import Yesod.Internal.Dispatch
 import Yesod.Widget (GWidget)
 
 import Web.PathPieces (SinglePiece (..), MultiPiece (..))
-import Yesod.Internal.RouteParsing (THResource, Pieces (..), createRoutes, createRender, Resource (..), parseRoutes, parseRoutesFile)
+import Yesod.Internal.RouteParsing (THResource, Pieces (..), createRoutes, createRender, Resource (..), parseRoutes, parseRoutesNoCheck, parseRoutesFile, parseRoutesFileNoCheck)
 import Language.Haskell.TH.Syntax
 
 import qualified Network.Wai as W
-import Network.Wai.Middleware.Jsonp
 import Network.Wai.Middleware.Gzip
 import Network.Wai.Middleware.Autohead
 
@@ -172,11 +173,11 @@ thResourceFromResource (Resource n _ _) =
     error $ "Invalid attributes for resource: " ++ n
 
 -- | Convert the given argument into a WAI application, executable with any WAI
--- handler. This is the same as 'toWaiAppPlain', except it includes three
--- middlewares: GZIP compression, JSON-P and autohead. This is the
+-- handler. This is the same as 'toWaiAppPlain', except it includes two
+-- middlewares: GZIP compression and autohead. This is the
 -- recommended approach for most users.
 toWaiApp :: (Yesod y, YesodDispatch y y) => y -> IO W.Application
-toWaiApp y = gzip (gzipCompressFiles y) . jsonp . autohead <$> toWaiAppPlain y
+toWaiApp y = gzip (gzipCompressFiles y) . autohead <$> toWaiAppPlain y
 
 -- | Convert the given argument into a WAI application, executable with any WAI
 -- handler. This differs from 'toWaiApp' in that it uses no middlewares.

yesod-core/Yesod/Handler.hs

@@ -8,6 +8,7 @@
 {-# LANGUAGE FunctionalDependencies #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE DeriveDataTypeable #-}
 ---------------------------------------------------------
 --
 -- Module        : Yesod.Handler
@@ -97,6 +98,12 @@ module Yesod.Handler
     , liftIOHandler
       -- * i18n
     , getMessageRender
+      -- * Per-request caching
+    , CacheKey
+    , mkCacheKey
+    , cacheLookup
+    , cacheInsert
+    , cacheDelete
       -- * Internal Yesod
     , runHandler
     , YesodApp (..)
@@ -119,17 +126,13 @@ import Yesod.Internal
 import Data.Time (UTCTime)
 
 import Control.Exception hiding (Handler, catch, finally)
-import qualified Control.Exception as E
 import Control.Applicative
 
-import Control.Monad (liftM, join, MonadPlus)
+import Control.Monad (liftM)
 
 import Control.Monad.IO.Class
 import Control.Monad.Trans.Class
-import Control.Monad.Trans.Writer
 import Control.Monad.Trans.Reader
-import Control.Monad.Trans.State
-import Control.Monad.Trans.Error (throwError, ErrorT (..), Error (..))
 
 import System.IO
 import qualified Network.Wai as W
@@ -143,8 +146,6 @@ import Data.Text.Encoding (encodeUtf8, decodeUtf8With)
 import Data.Text.Encoding.Error (lenientDecode)
 import qualified Data.Text.Lazy as TL
 
-import Control.Monad.IO.Control (MonadControlIO)
-import Control.Monad.Trans.Control (MonadTransControl, liftControl)
 import qualified Data.Map as Map
 import qualified Data.ByteString as S
 import Data.ByteString (ByteString)
@@ -154,7 +155,7 @@ import Network.Wai.Parse (parseHttpAccept)
 import Yesod.Content
 import Data.Maybe (fromMaybe)
 import Web.Cookie (SetCookie (..), renderSetCookie)
-import Control.Arrow (second, (***))
+import Control.Arrow ((***))
 import qualified Network.Wai.Parse as NWP
 import Data.Monoid (mappend, mempty, Endo (..))
 import qualified Data.ByteString.Char8 as S8
@@ -164,6 +165,12 @@ import Data.Text (Text)
 import Yesod.Message (RenderMessage (..))
 
 import Text.Blaze (toHtml, preEscapedText)
+import Yesod.Internal.TestApi (catchIter)
+
+import qualified Yesod.Internal.Cache as Cache
+import Yesod.Internal.Cache (mkCacheKey, CacheKey)
+import Data.Typeable (Typeable)
+import qualified Data.IORef as I
 
 -- | The type-safe URLs associated with a site argument.
 type family Route a
@@ -178,6 +185,7 @@ data HandlerData sub master = HandlerData
     , handlerRoute    :: Maybe (Route sub)
     , handlerRender   :: Route master -> [(Text, Text)] -> Text
     , handlerToMaster :: Route sub -> Route master
+    , handlerState    :: I.IORef GHState
     }
 
 handlerSubData :: (Route sub -> Route master)
@@ -198,6 +206,24 @@ handlerSubDataMaybe tm ts route hd = hd
     , handlerRoute = route
     }
 
+get :: MonadIO monad => GGHandler sub master monad GHState
+get = do
+    hd <- ask
+    liftIO $ I.readIORef $ handlerState hd
+
+put :: MonadIO monad => GHState -> GGHandler sub master monad ()
+put g = do
+    hd <- ask
+    liftIO $ I.writeIORef (handlerState hd) g
+
+modify :: MonadIO monad => (GHState -> GHState) -> GGHandler sub master monad ()
+modify f = do
+    hd <- ask
+    liftIO $ I.atomicModifyIORef (handlerState hd) $ \g -> (f g, ())
+
+tell :: MonadIO monad => Endo [Header] -> GGHandler sub master monad ()
+tell hs = modify $ \g -> g { ghsHeaders = ghsHeaders g `mappend` hs }
+
 -- | Used internally for promoting subsite handler functions to master site
 -- handler functions. Should not be needed by users.
 toMasterHandler :: (Route sub -> Route master)
@@ -205,8 +231,7 @@ toMasterHandler :: (Route sub -> Route master)
                 -> Route sub
                 -> GGHandler sub master mo a
                 -> GGHandler sub' master mo a
-toMasterHandler tm ts route (GHandler h) =
-    GHandler $ withReaderT (handlerSubData tm ts route) h
+toMasterHandler tm ts route = withReaderT (handlerSubData tm ts route)
 
 toMasterHandlerDyn :: Monad mo
                    => (Route sub -> Route master)
@@ -214,9 +239,9 @@ toMasterHandlerDyn :: Monad mo
                    -> Route sub
                    -> GGHandler sub master mo a
                    -> GGHandler sub' master mo a
-toMasterHandlerDyn tm getSub route (GHandler h) = do
+toMasterHandlerDyn tm getSub route h = do
     sub <- getSub
-    GHandler $ withReaderT (handlerSubData tm (const sub) route) h
+    withReaderT (handlerSubData tm (const sub) route) h
 
 class SubsiteGetter g m s | g -> s where
   runSubsiteGetter :: g -> m s
@@ -235,22 +260,14 @@ toMasterHandlerMaybe :: (Route sub -> Route master)
                      -> Maybe (Route sub)
                      -> GGHandler sub master mo a
                      -> GGHandler sub' master mo a
-toMasterHandlerMaybe tm ts route (GHandler h) =
-    GHandler $ withReaderT (handlerSubDataMaybe tm ts route) h
+toMasterHandlerMaybe tm ts route = withReaderT (handlerSubDataMaybe tm ts route)
 
 -- | A generic handler monad, which can have a different subsite and master
 -- site. This monad is a combination of 'ReaderT' for basic arguments, a
 -- 'WriterT' for headers and session, and an 'MEitherT' monad for handling
 -- special responses. It is declared as a newtype to make compiler errors more
 -- readable.
-newtype GGHandler sub master m a =
-    GHandler
-        { unGHandler :: GHInner sub master m a
-        }
-    deriving (Functor, Applicative, Monad, MonadIO, MonadControlIO, MonadPlus)
-
-instance MonadTrans (GGHandler s m) where
-    lift = GHandler . lift . lift . lift . lift
+type GGHandler sub master = ReaderT (HandlerData sub master)
 
 type GHandler sub master = GGHandler sub master (Iteratee ByteString IO)
 
@@ -258,16 +275,10 @@ data GHState = GHState
     { ghsSession :: SessionMap
     , ghsRBC :: Maybe RequestBodyContents
     , ghsIdent :: Int
+    , ghsCache :: Cache.Cache
+    , ghsHeaders :: Endo [Header]
     }
 
-type GHInner s m monad = -- FIXME collapse the stack
-    ReaderT (HandlerData s m) (
-    ErrorT HandlerContents (
-    WriterT (Endo [Header]) (
-    StateT GHState (
-    monad
-    ))))
-
 type SessionMap = Map.Map Text Text
 
 -- | An extension of the basic WAI 'W.Application' datatype to provide extra
@@ -293,25 +304,27 @@ data HandlerContents =
     | HCRedirect RedirectType Text
     | HCCreated Text
     | HCWai W.Response
+    deriving Typeable
 
-instance Error HandlerContents where
-    strMsg = HCError . InternalError . T.pack
+instance Show HandlerContents where
+    show _ = "Cannot show a HandlerContents"
+instance Exception HandlerContents
 
 getRequest :: Monad mo => GGHandler s m mo Request
-getRequest = handlerRequest `liftM` GHandler ask
+getRequest = handlerRequest `liftM` ask
 
-instance Monad monad => Failure ErrorResponse (GGHandler sub master monad) where
-    failure = GHandler . lift . throwError . HCError
+instance MonadIO monad => Failure ErrorResponse (GGHandler sub master monad) where
+    failure = liftIO . throwIO . HCError
 
 runRequestBody :: GHandler s m RequestBodyContents
 runRequestBody = do
-    x <- GHandler $ lift $ lift $ lift get
+    x <- get
     case ghsRBC x of
         Just rbc -> return rbc
         Nothing -> do
             rr <- waiRequest
             rbc <- lift $ rbHelper rr
-            GHandler $ lift $ lift $ lift $ put x { ghsRBC = Just rbc }
+            put x { ghsRBC = Just rbc }
             return rbc
 
 rbHelper :: W.Request -> Iteratee ByteString IO RequestBodyContents
@@ -326,33 +339,33 @@ rbHelper req =
 
 -- | Get the sub application argument.
 getYesodSub :: Monad m => GGHandler sub master m sub
-getYesodSub = handlerSub `liftM` GHandler ask
+getYesodSub = handlerSub `liftM` ask
 
 -- | Get the master site appliation argument.
 getYesod :: Monad m => GGHandler sub master m master
-getYesod = handlerMaster `liftM` GHandler ask
+getYesod = handlerMaster `liftM` ask
 
 -- | Get the URL rendering function.
 getUrlRender :: Monad m => GGHandler sub master m (Route master -> Text)
 getUrlRender = do
-    x <- handlerRender `liftM` GHandler ask
+    x <- handlerRender `liftM` ask
     return $ flip x []
 
 -- | The URL rendering function with query-string parameters.
 getUrlRenderParams
     :: Monad m
     => GGHandler sub master m (Route master -> [(Text, Text)] -> Text)
-getUrlRenderParams = handlerRender `liftM` GHandler ask
+getUrlRenderParams = handlerRender `liftM` ask
 
 -- | Get the route requested by the user. If this is a 404 response- where the
 -- user requested an invalid route- this function will return 'Nothing'.
 getCurrentRoute :: Monad m => GGHandler sub master m (Maybe (Route sub))
-getCurrentRoute = handlerRoute `liftM` GHandler ask
+getCurrentRoute = handlerRoute `liftM` ask
 
 -- | Get the function to promote a route for a subsite to a route for the
 -- master site.
 getRouteToMaster :: Monad m => GGHandler sub master m (Route sub -> Route master)
-getRouteToMaster = handlerToMaster `liftM` GHandler ask
+getRouteToMaster = handlerToMaster `liftM` ask
 
 -- | Function used internally by Yesod in the process of converting a
 -- 'GHandler' into an 'W.Application'. Should not be needed by users.
@@ -370,6 +383,13 @@ runHandler handler mrender sroute tomr ma sa =
             case fromException e of
                 Just x -> x
                 Nothing -> InternalError $ T.pack $ show e
+    istate <- liftIO $ I.newIORef GHState
+        { ghsSession = initSession
+        , ghsRBC = Nothing
+        , ghsIdent = 1
+        , ghsCache = mempty
+        , ghsHeaders = mempty
+        }
     let hd = HandlerData
             { handlerRequest = rr
             , handlerSub = sa
@@ -377,16 +397,14 @@ runHandler handler mrender sroute tomr ma sa =
             , handlerRoute = sroute
             , handlerRender = mrender
             , handlerToMaster = tomr
+            , handlerState = istate
             }
-    let initSession' = GHState initSession Nothing 1
-    ((contents', headers), finalSession) <- catchIter (
-        fmap (second ghsSession)
-      $ flip runStateT initSession'
-      $ runWriterT
-      $ runErrorT
-      $ flip runReaderT hd
-      $ unGHandler handler
-        ) (\e -> return ((Left $ HCError $ toErrorHandler e, mempty), initSession))
+    contents' <- catchIter (fmap Right $ runReaderT handler hd)
+        (\e -> return $ Left $ maybe (HCError $ toErrorHandler e) id
+                      $ fromException e)
+    state <- liftIO $ I.readIORef istate
+    let finalSession = ghsSession state
+    let headers = ghsHeaders state
     let contents = either id (HCContent H.status200 . chooseRep) contents'
     let handleError e = do
             yar <- unYesodApp (eh e) safeEh rr cts finalSession
@@ -420,12 +438,6 @@ runHandler handler mrender sroute tomr ma sa =
                 finalSession
         HCWai r -> return $ YARWai r
 
-catchIter :: Exception e
-          => Iteratee ByteString IO a
-          -> (e -> Iteratee ByteString IO a)
-          -> Iteratee ByteString IO a
-catchIter (Iteratee mstep) f = Iteratee $ mstep `E.catch` (runIteratee . f)
-
 safeEh :: ErrorResponse -> YesodApp
 safeEh er = YesodApp $ \_ _ _ session -> do
     liftIO $ hPutStrLn stderr $ "Error handler errored out: " ++ show er
@@ -437,11 +449,11 @@ safeEh er = YesodApp $ \_ _ _ session -> do
         session
 
 -- | Redirect to the given route.
-redirect :: Monad mo => RedirectType -> Route master -> GGHandler sub master mo a
+redirect :: MonadIO mo => RedirectType -> Route master -> GGHandler sub master mo a
 redirect rt url = redirectParams rt url []
 
 -- | Redirects to the given route with the associated query-string parameters.
-redirectParams :: Monad mo
+redirectParams :: MonadIO mo
                => RedirectType -> Route master -> [(Text, Text)]
                -> GGHandler sub master mo a
 redirectParams rt url params = do
@@ -449,8 +461,8 @@ redirectParams rt url params = do
     redirectString rt $ r url params
 
 -- | Redirect to the given URL.
-redirectString, redirectText :: Monad mo => RedirectType -> Text -> GGHandler sub master mo a
-redirectText rt = GHandler . lift . throwError . HCRedirect rt
+redirectString, redirectText :: MonadIO mo => RedirectType -> Text -> GGHandler sub master mo a
+redirectText rt = liftIO . throwIO . HCRedirect rt
 redirectString = redirectText
 {-# DEPRECATED redirectString "Use redirectText instead" #-}
 
@@ -461,16 +473,16 @@ ultDestKey = "_ULT"
 --
 -- An ultimate destination is stored in the user session and can be loaded
 -- later by 'redirectUltDest'.
-setUltDest :: Monad mo => Route master -> GGHandler sub master mo ()
+setUltDest :: MonadIO mo => Route master -> GGHandler sub master mo ()
 setUltDest dest = do
     render <- getUrlRender
     setUltDestString $ render dest
 
 -- | Same as 'setUltDest', but use the given string.
-setUltDestText :: Monad mo => Text -> GGHandler sub master mo ()
+setUltDestText :: MonadIO mo => Text -> GGHandler sub master mo ()
 setUltDestText = setSession ultDestKey
 
-setUltDestString :: Monad mo => Text -> GGHandler sub master mo ()
+setUltDestString :: MonadIO mo => Text -> GGHandler sub master mo ()
 setUltDestString = setSession ultDestKey
 {-# DEPRECATED setUltDestString "Use setUltDestText instead" #-}
 
@@ -478,21 +490,21 @@ setUltDestString = setSession ultDestKey
 --
 -- If this is a 404 handler, there is no current page, and then this call does
 -- nothing.
-setUltDest' :: Monad mo => GGHandler sub master mo ()
+setUltDest' :: MonadIO mo => GGHandler sub master mo ()
 setUltDest' = do
     route <- getCurrentRoute
     case route of
         Nothing -> return ()
         Just r -> do
             tm <- getRouteToMaster
-            gets' <- reqGetParams `liftM` handlerRequest `liftM` GHandler ask
+            gets' <- reqGetParams `liftM` handlerRequest `liftM` ask
             render <- getUrlRenderParams
             setUltDestString $ render (tm r) gets'
 
 -- | Sets the ultimate destination to the referer request header, if present.
 --
 -- This function will not overwrite an existing ultdest.
-setUltDestReferer :: Monad mo => GGHandler sub master mo ()
+setUltDestReferer :: MonadIO mo => GGHandler sub master mo ()
 setUltDestReferer = do
     mdest <- lookupSession ultDestKey
     maybe
@@ -506,7 +518,7 @@ setUltDestReferer = do
 -- value from the session.
 --
 -- The ultimate destination is set with 'setUltDest'.
-redirectUltDest :: Monad mo
+redirectUltDest :: MonadIO mo
                 => RedirectType
                 -> Route master -- ^ default destination if nothing in session
                 -> GGHandler sub master mo a
@@ -516,7 +528,7 @@ redirectUltDest rt def = do
     maybe (redirect rt def) (redirectText rt) mdest
 
 -- | Remove a previously set ultimate destination. See 'setUltDest'.
-clearUltDest :: Monad mo => GGHandler sub master mo ()
+clearUltDest :: MonadIO mo => GGHandler sub master mo ()
 clearUltDest = deleteSession ultDestKey
 
 msgKey :: Text
@@ -525,13 +537,13 @@ msgKey = "_MSG"
 -- | Sets a message in the user's session.
 --
 -- See 'getMessage'.
-setMessage :: Monad mo => Html -> GGHandler sub master mo ()
+setMessage :: MonadIO mo => Html -> GGHandler sub master mo ()
 setMessage = setSession msgKey . T.concat . TL.toChunks . Text.Blaze.Renderer.Text.renderHtml
 
 -- | Sets a message in the user's session.
 --
 -- See 'getMessage'.
-setMessageI :: (RenderMessage y msg, Monad mo) => msg -> GGHandler sub y mo ()
+setMessageI :: (RenderMessage y msg, MonadIO mo) => msg -> GGHandler sub y mo ()
 setMessageI msg = do
     mr <- getMessageRender
     setMessage $ toHtml $ mr msg
@@ -540,7 +552,7 @@ setMessageI msg = do
 -- variable.
 --
 -- See 'setMessage'.
-getMessage :: Monad mo => GGHandler sub master mo (Maybe Html)
+getMessage :: MonadIO mo => GGHandler sub master mo (Maybe Html)
 getMessage = do
     mmsg <- liftM (fmap preEscapedText) $ lookupSession msgKey
     deleteSession msgKey
@@ -550,52 +562,52 @@ getMessage = do
 --
 -- For some backends, this is more efficient than reading in the file to
 -- memory, since they can optimize file sending via a system call to sendfile.
-sendFile :: Monad mo => ContentType -> FilePath -> GGHandler sub master mo a
-sendFile ct fp = GHandler . lift . throwError $ HCSendFile ct fp Nothing
+sendFile :: MonadIO mo => ContentType -> FilePath -> GGHandler sub master mo a
+sendFile ct fp = liftIO . throwIO $ HCSendFile ct fp Nothing
 
 -- | Same as 'sendFile', but only sends part of a file.
-sendFilePart :: Monad mo
+sendFilePart :: MonadIO mo
              => ContentType
              -> FilePath
              -> Integer -- ^ offset
              -> Integer -- ^ count
              -> GGHandler sub master mo a
 sendFilePart ct fp off count =
-    GHandler . lift . throwError $ HCSendFile ct fp $ Just $ W.FilePart off count
+    liftIO . throwIO $ HCSendFile ct fp $ Just $ W.FilePart off count
 
 -- | Bypass remaining handler code and output the given content with a 200
 -- status code.
-sendResponse :: (Monad mo, HasReps c) => c -> GGHandler sub master mo a
-sendResponse = GHandler . lift . throwError . HCContent H.status200
+sendResponse :: (MonadIO mo, HasReps c) => c -> GGHandler sub master mo a
+sendResponse = liftIO . throwIO . HCContent H.status200
              . chooseRep
 
 -- | Bypass remaining handler code and output the given content with the given
 -- status code.
-sendResponseStatus :: (Monad mo, HasReps c) => H.Status -> c -> GGHandler s m mo a
-sendResponseStatus s = GHandler . lift . throwError . HCContent s
+sendResponseStatus :: (MonadIO mo, HasReps c) => H.Status -> c -> GGHandler s m mo a
+sendResponseStatus s = liftIO . throwIO . HCContent s
                      . chooseRep
 
 -- | Send a 201 "Created" response with the given route as the Location
 -- response header.
-sendResponseCreated :: Monad mo => Route m -> GGHandler s m mo a
+sendResponseCreated :: MonadIO mo => Route m -> GGHandler s m mo a
 sendResponseCreated url = do
     r <- getUrlRender
-    GHandler $ lift $ throwError $ HCCreated $ r url
+    liftIO . throwIO $ HCCreated $ r url
 
 -- | Send a 'W.Response'. Please note: this function is rarely
 -- necessary, and will /disregard/ any changes to response headers and session
 -- that you have already specified. This function short-circuits. It should be
 -- considered only for very specific needs. If you are not sure if you need it,
 -- you don't.
-sendWaiResponse :: Monad mo => W.Response -> GGHandler s m mo b
-sendWaiResponse = GHandler . lift . throwError . HCWai
+sendWaiResponse :: MonadIO mo => W.Response -> GGHandler s m mo b
+sendWaiResponse = liftIO . throwIO . HCWai
 
 -- | Return a 404 not found page. Also denotes no handler available.
 notFound :: Failure ErrorResponse m => m a
 notFound = failure NotFound
 
 -- | Return a 405 method not supported page.
-badMethod :: Monad mo => GGHandler s m mo a
+badMethod :: MonadIO mo => GGHandler s m mo a
 badMethod = do
     w <- waiRequest
     failure $ BadMethod $ W.requestMethod w
@@ -605,7 +617,7 @@ permissionDenied :: Failure ErrorResponse m => Text -> m a
 permissionDenied = failure . PermissionDenied
 
 -- | Return a 403 permission denied page.
-permissionDeniedI :: (RenderMessage y msg, Monad mo) => msg -> GGHandler s y mo a
+permissionDeniedI :: (RenderMessage y msg, MonadIO mo) => msg -> GGHandler s y mo a
 permissionDeniedI msg = do
     mr <- getMessageRender
     permissionDenied $ mr msg
@@ -615,14 +627,14 @@ invalidArgs :: Failure ErrorResponse m => [Text] -> m a
 invalidArgs = failure . InvalidArgs
 
 -- | Return a 400 invalid arguments page.
-invalidArgsI :: (RenderMessage y msg, Monad mo) => [msg] -> GGHandler s y mo a
+invalidArgsI :: (RenderMessage y msg, MonadIO mo) => [msg] -> GGHandler s y mo a
 invalidArgsI msg = do
     mr <- getMessageRender
     invalidArgs $ map mr msg
 
 ------- Headers
 -- | Set the cookie on the client.
-setCookie :: Monad mo
+setCookie :: MonadIO mo
           => Int -- ^ minutes to timeout
           -> H.Ascii -- ^ key
           -> H.Ascii -- ^ value
@@ -630,22 +642,22 @@ setCookie :: Monad mo
 setCookie a b = addHeader . AddCookie a b
 
 -- | Unset the cookie on the client.
-deleteCookie :: Monad mo => H.Ascii -> GGHandler sub master mo ()
+deleteCookie :: MonadIO mo => H.Ascii -> GGHandler sub master mo ()
 deleteCookie = addHeader . DeleteCookie
 
 -- | Set the language in the user session. Will show up in 'languages' on the
 -- next request.
-setLanguage :: Monad mo => Text -> GGHandler sub master mo ()
+setLanguage :: MonadIO mo => Text -> GGHandler sub master mo ()
 setLanguage = setSession langKey
 
 -- | Set an arbitrary response header.
-setHeader :: Monad mo
+setHeader :: MonadIO mo
           => CI H.Ascii -> H.Ascii -> GGHandler sub master mo ()
 setHeader a = addHeader . Header a
 
 -- | Set the Cache-Control header to indicate this response should be cached
 -- for the given number of seconds.
-cacheSeconds :: Monad mo => Int -> GGHandler s m mo ()
+cacheSeconds :: MonadIO mo => Int -> GGHandler s m mo ()
 cacheSeconds i = setHeader "Cache-Control" $ S8.pack $ concat
     [ "max-age="
     , show i
@@ -654,16 +666,16 @@ cacheSeconds i = setHeader "Cache-Control" $ S8.pack $ concat
 
 -- | Set the Expires header to some date in 2037. In other words, this content
 -- is never (realistically) expired.
-neverExpires :: Monad mo => GGHandler s m mo ()
+neverExpires :: MonadIO mo => GGHandler s m mo ()
 neverExpires = setHeader "Expires" "Thu, 31 Dec 2037 23:55:55 GMT"
 
 -- | Set an Expires header in the past, meaning this content should not be
 -- cached.
-alreadyExpired :: Monad mo => GGHandler s m mo ()
+alreadyExpired :: MonadIO mo => GGHandler s m mo ()
 alreadyExpired = setHeader "Expires" "Thu, 01 Jan 1970 05:05:05 GMT"
 
 -- | Set an Expires header to the given date.
-expiresAt :: Monad mo => UTCTime -> GGHandler s m mo ()
+expiresAt :: MonadIO mo => UTCTime -> GGHandler s m mo ()
 expiresAt = setHeader "Expires" . encodeUtf8 . formatRFC1123
 
 -- | Set a variable in the user's session.
@@ -671,22 +683,22 @@ expiresAt = setHeader "Expires" . encodeUtf8 . formatRFC1123
 -- The session is handled by the clientsession package: it sets an encrypted
 -- and hashed cookie on the client. This ensures that all data is secure and
 -- not tampered with.
-setSession :: Monad mo
+setSession :: MonadIO mo
            => Text -- ^ key
            -> Text -- ^ value
            -> GGHandler sub master mo ()
-setSession k = GHandler . lift . lift . lift . modify . modSession . Map.insert k
+setSession k = modify . modSession . Map.insert k
 
 -- | Unsets a session variable. See 'setSession'.
-deleteSession :: Monad mo => Text -> GGHandler sub master mo ()
-deleteSession = GHandler . lift . lift . lift . modify . modSession . Map.delete
+deleteSession :: MonadIO mo => Text -> GGHandler sub master mo ()
+deleteSession = modify . modSession . Map.delete
 
 modSession :: (SessionMap -> SessionMap) -> GHState -> GHState
 modSession f x = x { ghsSession = f $ ghsSession x }
 
 -- | Internal use only, not to be confused with 'setHeader'.
-addHeader :: Monad mo => Header -> GGHandler sub master mo ()
-addHeader = GHandler . lift . lift . tell . Endo . (:)
+addHeader :: MonadIO mo => Header -> GGHandler sub master mo ()
+addHeader = tell . Endo . (:)
 
 getStatus :: ErrorResponse -> H.Status
 getStatus NotFound = H.status404
@@ -708,17 +720,17 @@ data RedirectType = RedirectPermanent
 
 localNoCurrent :: Monad mo => GGHandler s m mo a -> GGHandler s m mo a
 localNoCurrent =
-    GHandler . local (\hd -> hd { handlerRoute = Nothing }) . unGHandler
+    local (\hd -> hd { handlerRoute = Nothing })
 
 -- | Lookup for session data.
-lookupSession :: Monad mo => Text -> GGHandler s m mo (Maybe Text)
-lookupSession n = GHandler $ do
-    m <- liftM ghsSession $ lift $ lift $ lift get
+lookupSession :: MonadIO mo => Text -> GGHandler s m mo (Maybe Text)
+lookupSession n = do
+    m <- liftM ghsSession get
     return $ Map.lookup n m
 
 -- | Get all session variables.
-getSession :: Monad mo => GGHandler s m mo SessionMap
-getSession = liftM ghsSession $ GHandler $ lift $ lift $ lift get
+getSession :: MonadIO mo => GGHandler s m mo SessionMap
+getSession = liftM ghsSession get
 
 handlerToYAR :: (HasReps a, HasReps b)
              => m -- ^ master site foundation
@@ -808,8 +820,8 @@ headerToPair cp _ (DeleteCookie key) =
 headerToPair _ _ (Header key value) = (key, value)
 
 -- | Get a unique identifier.
-newIdent :: Monad mo => GGHandler sub master mo String -- FIXME use Text
-newIdent = GHandler $ lift $ lift $ lift $ do
+newIdent :: MonadIO mo => GGHandler sub master mo String -- FIXME use Text
+newIdent = do
     x <- get
     let i' = ghsIdent x + 1
     put x { ghsIdent = i' }
@@ -818,42 +830,7 @@ newIdent = GHandler $ lift $ lift $ lift $ do
 liftIOHandler :: MonadIO mo
               => GGHandler sub master IO a
               -> GGHandler sub master mo a
-liftIOHandler m = GHandler $
-                   ReaderT $ \r ->
-                     ErrorT $
-                       WriterT $
-                         StateT $ \s ->
-                           liftIO $ runGGHandler m r s
-
-runGGHandler :: GGHandler sub master m a
-            -> HandlerData sub master
-            -> GHState
-            -> m ( ( Either HandlerContents a
-                   , Endo [Header]
-                   )
-                 , GHState
-                 )
-runGGHandler m r s = runStateT
-                      (runWriterT
-                        (runErrorT
-                          (runReaderT
-                            (unGHandler m) r))) s
-
-instance MonadTransControl (GGHandler s m) where
-    liftControl f =
-      GHandler $
-        liftControl $ \runRdr ->
-          liftControl $ \runErr ->
-            liftControl $ \runWrt ->
-              liftControl $ \runSt ->
-                f ( liftM ( GHandler
-                          . join . lift
-                          . join . lift
-                          . join . lift
-                          )
-                  . runSt . runWrt . runErr . runRdr
-                  . unGHandler
-                  )
+liftIOHandler (ReaderT m) = ReaderT $ \r -> liftIO $ m r
 
 -- | Redirect to a POST resource.
 --
@@ -861,7 +838,7 @@ instance MonadTransControl (GGHandler s m) where
 -- POST form, and some Javascript to automatically submit the form. This can be
 -- useful when you need to post a plain link somewhere that needs to cause
 -- changes on the server.
-redirectToPost :: Monad mo => Route master -> GGHandler sub master mo a
+redirectToPost :: MonadIO mo => Route master -> GGHandler sub master mo a
 redirectToPost dest = hamletToRepHtml
 #if GHC7
             [hamlet|
@@ -902,3 +879,16 @@ getMessageRender = do
     m <- getYesod
     l <- reqLangs `liftM` getRequest
     return $ renderMessage m l
+
+cacheLookup :: MonadIO mo => CacheKey a -> GGHandler sub master mo (Maybe a)
+cacheLookup k = do
+    gs <- get
+    return $ Cache.lookup k $ ghsCache gs
+
+cacheInsert :: MonadIO mo => CacheKey a -> a -> GGHandler sub master mo ()
+cacheInsert k v = modify $ \gs ->
+    gs { ghsCache = Cache.insert k v $ ghsCache gs }
+
+cacheDelete :: MonadIO mo => CacheKey a -> GGHandler sub master mo ()
+cacheDelete k = modify $ \gs ->
+    gs { ghsCache = Cache.delete k $ ghsCache gs }

yesod-core/Yesod/Internal.hs

@@ -29,7 +29,6 @@ module Yesod.Internal
     ) where
 
 import Text.Hamlet (HtmlUrl, hamlet, Html)
-import Text.Cassius (CssUrl)
 import Text.Julius (JavascriptUrl)
 import Data.Monoid (Monoid (..), Last)
 import Data.List (nub)
@@ -44,6 +43,7 @@ import qualified Network.HTTP.Types as A
 import Data.CaseInsensitive (CI)
 import Data.String (IsString)
 import qualified Data.Map as Map
+import Data.Text.Lazy.Builder (Builder)
 
 #if GHC7
 #define HAMLET hamlet
@@ -107,12 +107,14 @@ nonceKey = "_NONCE"
 sessionName :: IsString a => a
 sessionName = "_SESSION"
 
+type CssBuilderUrl a = (a -> [(Text, Text)] -> Text) -> Builder
+
 data GWData a = GWData
     !(Body a)
     !(Last Title)
     !(UniqueList (Script a))
     !(UniqueList (Stylesheet a))
-    !(Map.Map (Maybe Text) (CssUrl a)) -- media type
+    !(Map.Map (Maybe Text) (CssBuilderUrl a)) -- media type
     !(Maybe (JavascriptUrl a))
     !(Head a)
 instance Monoid (GWData a) where

yesod-core/Yesod/Internal/Cache.hs

@@ -0,0 +1,38 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE TemplateHaskell #-}
+module Yesod.Internal.Cache
+    ( Cache
+    , CacheKey
+    , mkCacheKey
+    , lookup
+    , insert
+    , delete
+    ) where
+
+import Prelude hiding (lookup)
+import qualified Data.IntMap as Map
+import Language.Haskell.TH.Syntax (Q, Exp, runIO, Exp (LitE), Lit (IntegerL))
+import Language.Haskell.TH (appE)
+import Data.Unique (hashUnique, newUnique)
+import GHC.Exts (Any)
+import Unsafe.Coerce (unsafeCoerce)
+import Data.Monoid (Monoid)
+import Control.Applicative ((<$>))
+
+newtype Cache = Cache (Map.IntMap Any)
+    deriving Monoid
+
+newtype CacheKey a = CacheKey Int
+
+-- | Generate a new 'CacheKey'. Be sure to give a full type signature.
+mkCacheKey :: Q Exp
+mkCacheKey = [|CacheKey|] `appE` (LitE . IntegerL . fromIntegral . hashUnique <$> runIO newUnique)
+
+lookup :: CacheKey a -> Cache -> Maybe a
+lookup (CacheKey i) (Cache m) = unsafeCoerce <$> Map.lookup i m
+
+insert :: CacheKey a -> a -> Cache -> Cache
+insert (CacheKey k) v (Cache m) = Cache (Map.insert k (unsafeCoerce v) m)
+
+delete :: CacheKey a -> Cache -> Cache
+delete (CacheKey k) (Cache m) = Cache (Map.delete k m)

yesod-core/Yesod/Internal/Core.hs

@@ -35,8 +35,6 @@ import Yesod.Handler
 
 import Control.Arrow ((***))
 import Control.Monad (forM)
-import qualified Paths_yesod_core
-import Data.Version (showVersion)
 import Yesod.Widget
 import Yesod.Request
 import qualified Network.Wai as W
@@ -48,11 +46,10 @@ import qualified Web.ClientSession as CS
 import qualified Data.ByteString.Char8 as S8
 import qualified Data.ByteString.Lazy as L
 import Data.Monoid
-import Control.Monad.Trans.RWS
+import Control.Monad.Trans.Writer (runWriterT)
 import Text.Hamlet
-import Text.Cassius
 import Text.Julius
-import Text.Blaze ((!), customAttribute, textTag, toValue)
+import Text.Blaze ((!), customAttribute, textTag, toValue, unsafeLazyByteString)
 import qualified Text.Blaze.Html5 as TBH
 import Data.Text.Lazy.Builder (toLazyText)
 import Data.Text.Lazy.Encoding (encodeUtf8)
@@ -75,6 +72,20 @@ import qualified Data.Text.Lazy.IO
 import qualified Data.Text.Lazy.Builder as TB
 import Language.Haskell.TH.Syntax (Loc (..), Lift (..))
 import Text.Blaze (preEscapedLazyText)
+import Data.Aeson (Value (Array, String))
+import Data.Aeson.Encode (encode)
+import qualified Data.Vector as Vector
+
+-- mega repo can't access this
+#ifndef MEGA
+import qualified Paths_yesod_core
+import Data.Version (showVersion)
+yesodVersion :: String
+yesodVersion = showVersion Paths_yesod_core.version
+#else
+yesodVersion :: String
+yesodVersion = "0.9.3.2"
+#endif
 
 #if GHC7
 #define HAMLET hamlet
@@ -159,9 +170,9 @@ class RenderRoute (Route a) => Yesod a where
 
     -- | Determine if a request is authorized or not.
     --
-    -- Return 'Nothing' is the request is authorized, 'Just' a message if
-    -- unauthorized. If authentication is required, you should use a redirect;
-    -- the Auth helper provides this functionality automatically.
+    -- Return 'Authorized' if the request is authorized,
+    -- 'Unauthorized' a message if unauthorized.
+    -- If authentication is required, return 'AuthenticationRequired'.
     isAuthorized :: Route a
                  -> Bool -- ^ is this a write request?
                  -> GHandler s a AuthResult
@@ -264,6 +275,11 @@ class RenderRoute (Route a) => Yesod a where
     gzipCompressFiles :: a -> Bool
     gzipCompressFiles _ = False
 
+    -- | Location of yepnope.js, if any. If one is provided, then all
+    -- Javascript files will be loaded asynchronously.
+    yepnopeJs :: a -> Maybe (Either Text (Route a))
+    yepnopeJs _ = Nothing
+
 messageLoggerHandler :: (Yesod m, MonadIO mo)
                      => Loc -> LogLevel -> Text -> GGHandler s m mo ()
 messageLoggerHandler loc level msg = do
@@ -327,12 +343,12 @@ defaultYesodRunner _ m toMaster _ murl _ req
             [] -> Nothing
             (x, _):_ -> Just x
 defaultYesodRunner s master toMasterRoute mkey murl handler req = do
-    now <- liftIO getCurrentTime
-    let getExpires m = fromIntegral (m * 60) `addUTCTime` now
-    let exp' = getExpires $ clientSessionDuration master
-    let rh = takeWhile (/= ':') $ show $ W.remoteHost req
+    now <- {-# SCC "getCurrentTime" #-} liftIO getCurrentTime
+    let getExpires m = {-# SCC "getExpires" #-} fromIntegral (m * 60) `addUTCTime` now
+    let exp' = {-# SCC "exp'" #-} getExpires $ clientSessionDuration master
+    let rh = {-# SCC "rh" #-} takeWhile (/= ':') $ show $ W.remoteHost req
     let host = if sessionIpAddress master then S8.pack rh else ""
-    let session' =
+    let session' = {-# SCC "session'" #-}
             case mkey of
                 Nothing -> []
                 Just key -> fromMaybe [] $ do
@@ -340,7 +356,7 @@ defaultYesodRunner s master toMasterRoute mkey murl handler req = do
                     val <- lookup sessionName $ parseCookies raw
                     decodeSession key now host val
     rr <- liftIO $ parseWaiRequest req session' mkey
-    let h = do
+    let h = {-# SCC "h" #-} do
           case murl of
             Nothing -> handler
             Just url -> do
@@ -361,7 +377,8 @@ defaultYesodRunner s master toMasterRoute mkey murl handler req = do
                    $ filter (\(x, _) -> x /= nonceKey) session'
     yar <- handlerToYAR master s toMasterRoute (yesodRender master) errorHandler rr murl sessionMap h
     let mnonce = reqNonce rr
-    iv <- liftIO CS.randomIV
+    -- FIXME should we be caching this IV value and reusing it for efficiency?
+    iv <- {-# SCC "iv" #-} maybe (return $ error "Should not be used") (const $ liftIO CS.randomIV) mkey
     return $ yarToResponse (hr iv mnonce getExpires host exp') yar
   where
     hr iv mnonce getExpires host exp' hs ct sm =
@@ -472,18 +489,22 @@ maybeAuthorized r isWrite = do
     x <- isAuthorized r isWrite
     return $ if x == Authorized then Just r else Nothing
 
+jsToHtml :: Javascript -> Html
+jsToHtml (Javascript b) = preEscapedLazyText $ toLazyText b
+
+jelper :: JavascriptUrl url -> HtmlUrl url
+jelper = fmap jsToHtml
+
 -- | Convert a widget to a 'PageContent'.
 widgetToPageContent :: (Eq (Route master), Yesod master)
                     => GWidget sub master ()
                     -> GHandler sub master (PageContent (Route master))
 widgetToPageContent (GWidget w) = do
-    ((), _, GWData (Body body) (Last mTitle) scripts' stylesheets' style jscript (Head head')) <- runRWST w () 0
+    master <- getYesod
+    ((), GWData (Body body) (Last mTitle) scripts' stylesheets' style jscript (Head head')) <- runWriterT w
     let title = maybe mempty unTitle mTitle
     let scripts = runUniqueList scripts'
     let stylesheets = runUniqueList stylesheets'
-    let jsToHtml (Javascript b) = preEscapedLazyText $ toLazyText b
-        jelper :: JavascriptUrl url -> HtmlUrl url
-        jelper = fmap jsToHtml
 
     render <- getUrlRenderParams
     let renderLoc x =
@@ -492,7 +513,7 @@ widgetToPageContent (GWidget w) = do
                 Just (Left s) -> Just s
                 Just (Right (u, p)) -> Just $ render u p
     css <- forM (Map.toList style) $ \(mmedia, content) -> do
-        let rendered = renderCssUrl render content
+        let rendered = toLazyText $ content render
         x <- addStaticContent "css" "text/css; charset=utf-8"
            $ encodeUtf8 rendered
         return (mmedia,
@@ -536,19 +557,54 @@ $forall s <- css
             <style media=#{media}>#{content}
         $nothing
             <style>#{content}
-$forall s <- scripts
-    ^{mkScriptTag s}
-$maybe j <- jscript
-    $maybe s <- jsLoc
-        <script src="#{s}">
-    $nothing
-        <script>^{jelper j}
+$maybe _ <- yepnopeJs master
+$nothing
+    $forall s <- scripts
+        ^{mkScriptTag s}
+    $maybe j <- jscript
+        $maybe s <- jsLoc
+            <script src="#{s}">
+        $nothing
+            <script>^{jelper j}
 \^{head'}
 |]
-    return $ PageContent title head'' body
+    let (mcomplete, ynscripts) = ynHelper render scripts jscript jsLoc
+    let bodyYN = [HAMLET|
+^{body}
+$maybe eyn <- yepnopeJs master
+    $maybe yn <- left eyn
+        <script src=#{yn}>
+    $maybe yn <- right eyn
+        <script src=@{yn}>
+    $maybe complete <- mcomplete
+        <script>yepnope({load:#{ynscripts},complete:function(){^{complete}}})
+    $nothing
+        <script>yepnope({load:#{ynscripts}})
+|]
+    return $ PageContent title head'' bodyYN
 
-yesodVersion :: String
-yesodVersion = showVersion Paths_yesod_core.version
+ynHelper :: (url -> [x] -> Text)
+         -> [Script (url)]
+         -> Maybe (JavascriptUrl (url))
+         -> Maybe Text
+         -> (Maybe (HtmlUrl (url)), Html)
+ynHelper render scripts jscript jsLoc =
+    (mcomplete, unsafeLazyByteString $ encode $ Array $ Vector.fromList $ map String scripts'')
+  where
+    scripts' = map goScript scripts
+    scripts'' =
+        case jsLoc of
+            Just s -> scripts' ++ [s]
+            Nothing -> scripts'
+    goScript (Script (Local url) _) = render url []
+    goScript (Script (Remote s) _) = s
+    mcomplete =
+        case jsLoc of
+            Just{} -> Nothing
+            Nothing ->
+                case jscript of
+                    Nothing -> Nothing
+                    Just j -> Just $ jelper j
 
 yesodRender :: Yesod y
             => y

yesod-core/Yesod/Internal/Request.hs

@@ -60,9 +60,9 @@ parseWaiRequest' env session' key' gen = Request gets'' cookies' env langs' nonc
                        , lookup langKey cookies'     -- Cookie _LANG
                        , lookup langKey session'     -- Session _LANG
                        ] ++ langs                    -- Accept-Language(s)
-    -- If the session is not secure a nonce should not be
-    -- used (any nonce present in the session is ignored).
-    -- If a secure session has no nonceKey a new one is
+    -- If sessions are disabled nonces should not be used (any
+    -- nonceKey present in the session is ignored). If sessions
+    -- are enabled and a session has no nonceKey a new one is
     -- generated.
     nonce = case (key', lookup nonceKey session') of
                 (Nothing, _) -> Nothing
@@ -75,7 +75,10 @@ parseWaiRequest' env session' key' gen = Request gets'' cookies' env langs' nonc
 randomString :: RandomGen g => Int -> g -> String
 randomString len = take len . map toChar . randomRs (0, 61)
   where
-    toChar i = (['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9']) !! i
+    toChar i
+        | i < 26 = toEnum $ i + fromEnum 'A'
+        | i < 52 = toEnum $ i + fromEnum 'a' - 26
+        | otherwise = toEnum $ i + fromEnum '0' - 52
 
 -- | A tuple containing both the POST parameters and submitted files.
 type RequestBodyContents =

yesod-core/Yesod/Internal/RouteParsing.hs

@@ -331,18 +331,24 @@ pieceFromString ('#':x) = SinglePiece x
 pieceFromString ('*':x) = MultiPiece x
 pieceFromString x = StaticPiece x
 
+-- n^2, should be a way to speed it up
 findOverlaps :: [Resource] -> [(Resource, Resource)]
-findOverlaps = gos . map justPieces
+findOverlaps = go . map justPieces
   where
+    justPieces :: Resource -> ([Piece], Resource)
     justPieces r@(Resource _ ps _) = (ps, r)
-    gos [] = []
-    gos (x:xs) = mapMaybe (go x) xs ++ gos xs
-    go (StaticPiece x:xs, xr) (StaticPiece y:ys, yr)
-        | x == y = go (xs, xr) (ys, yr)
+
+    go [] = []
+    go (x:xs) = mapMaybe (mOverlap x) xs ++ go xs
+
+    mOverlap :: ([Piece], Resource) -> ([Piece], Resource) ->
+                Maybe (Resource, Resource)
+    mOverlap (StaticPiece x:xs, xr) (StaticPiece y:ys, yr)
+        | x == y = mOverlap (xs, xr) (ys, yr)
         | otherwise = Nothing
-    go (MultiPiece _:_, xr) (_, yr) = Just (xr, yr)
-    go (_, xr) (MultiPiece _:_, yr) = Just (xr, yr)
-    go ([], xr) ([], yr) = Just (xr, yr)
-    go ([], _) (_, _) = Nothing
-    go (_, _) ([], _) = Nothing
-    go (_:xs, xr) (_:ys, yr) = go (xs, xr) (ys, yr)
+    mOverlap (MultiPiece _:_, xr) (_, yr) = Just (xr, yr)
+    mOverlap (_, xr) (MultiPiece _:_, yr) = Just (xr, yr)
+    mOverlap ([], xr) ([], yr) = Just (xr, yr)
+    mOverlap ([], _) (_, _) = Nothing
+    mOverlap (_, _) ([], _) = Nothing
+    mOverlap (_:xs, xr) (_:ys, yr) = mOverlap (xs, xr) (ys, yr)

yesod-core/Yesod/Internal/TestApi.hs

@@ -6,6 +6,22 @@
 --
 module Yesod.Internal.TestApi
   ( randomString, parseWaiRequest'
+  , catchIter
   ) where
 
 import Yesod.Internal.Request (randomString, parseWaiRequest')
+import Control.Exception (Exception, catch)
+import Data.Enumerator (Iteratee (..), Step (..))
+import Data.ByteString (ByteString)
+import Prelude hiding (catch)
+
+catchIter :: Exception e
+          => Iteratee ByteString IO a
+          -> (e -> Iteratee ByteString IO a)
+          -> Iteratee ByteString IO a
+catchIter (Iteratee mstep) f = Iteratee $ do
+    step <- mstep `catch` (runIteratee . f)
+    return $ case step of
+        Continue k -> Continue $ \s -> catchIter (k s) f
+        Yield b s -> Yield b s
+        Error e -> Error e

yesod-core/Yesod/Message.hs

@@ -1,259 +1,5 @@
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE TypeSynonymInstances #-}
-{-# LANGUAGE ExistentialQuantification #-}
 module Yesod.Message
-    ( mkMessage
-    , RenderMessage (..)
-    , ToMessage (..)
-    , SomeMessage (..)
+    ( module Text.Shakespeare.I18N
     ) where
 
-import Language.Haskell.TH.Syntax
-import Data.Text (Text, pack, unpack)
-import System.Directory
-import Data.Maybe (catMaybes)
-import Data.List (isSuffixOf, sortBy, foldl')
-import qualified Data.ByteString as S
-import Data.Text.Encoding (decodeUtf8)
-import Data.Char (isSpace, toLower, toUpper)
-import Data.Ord (comparing)
-import Text.Shakespeare.Base (Deref (..), Ident (..), parseHash, derefToExp)
-import Text.ParserCombinators.Parsec (parse, many, eof, many1, noneOf, (<|>))
-import Control.Arrow ((***))
-import Data.Monoid (mempty, mappend)
-import qualified Data.Text as T
-import Data.String (IsString (fromString))
-
-class ToMessage a where
-    toMessage :: a -> Text
-instance ToMessage Text where
-    toMessage = id
-instance ToMessage String where
-    toMessage = Data.Text.pack
-
-class RenderMessage master message where
-    renderMessage :: master
-                  -> [Text] -- ^ languages
-                  -> message
-                  -> Text
-
-instance RenderMessage master Text where
-    renderMessage _ _ = id
-
-type Lang = Text
-
-mkMessage :: String
-          -> FilePath
-          -> Lang
-          -> Q [Dec]
-mkMessage dt folder lang = do
-    files <- qRunIO $ getDirectoryContents folder
-    contents <- qRunIO $ fmap catMaybes $ mapM (loadLang folder) files
-    sdef <-
-        case lookup lang contents of
-            Nothing -> error $ "Did not find main language file: " ++ unpack lang
-            Just def -> toSDefs def
-    mapM_ (checkDef sdef) $ map snd contents
-    let dt' = ConT $ mkName dt
-    let mname = mkName $ dt ++ "Message"
-    c1 <- fmap concat $ mapM (toClauses dt) contents
-    c2 <- mapM (sToClause dt) sdef
-    c3 <- defClause
-    return
-        [ DataD [] mname [] (map (toCon dt) sdef) []
-        , InstanceD
-            []
-            (ConT ''RenderMessage `AppT` dt' `AppT` ConT mname)
-            [ FunD (mkName "renderMessage") $ c1 ++ c2 ++ [c3]
-            ]
-        ]
-
-toClauses :: String -> (Lang, [Def]) -> Q [Clause]
-toClauses dt (lang, defs) =
-    mapM go defs
-  where
-    go def = do
-        a <- newName "lang"
-        (pat, bod) <- mkBody dt (constr def) (map fst $ vars def) (content def)
-        guard <- fmap NormalG [|$(return $ VarE a) == pack $(lift $ unpack lang)|]
-        return $ Clause
-            [WildP, ConP (mkName ":") [VarP a, WildP], pat]
-            (GuardedB [(guard, bod)])
-            []
-
-mkBody :: String -- ^ datatype
-       -> String -- ^ constructor
-       -> [String] -- ^ variable names
-       -> [Content]
-       -> Q (Pat, Exp)
-mkBody dt cs vs ct = do
-    vp <- mapM go vs
-    let pat = RecP (mkName $ "Msg" ++ cs) (map (varName dt *** VarP) vp)
-    let ct' = map (fixVars vp) ct
-    pack' <- [|Data.Text.pack|]
-    tomsg <- [|toMessage|]
-    let ct'' = map (toH pack' tomsg) ct'
-    mapp <- [|mappend|]
-    let app a b = InfixE (Just a) mapp (Just b)
-    e <-
-        case ct'' of
-            [] -> [|mempty|]
-            [x] -> return x
-            (x:xs) -> return $ foldl' app x xs
-    return (pat, e)
-  where
-    toH pack' _ (Raw s) = pack' `AppE` SigE (LitE (StringL s)) (ConT ''String)
-    toH _ tomsg (Var d) = tomsg `AppE` derefToExp [] d
-    go x = do
-        let y = mkName $ '_' : x
-        return (x, y)
-    fixVars vp (Var d) = Var $ fixDeref vp d
-    fixVars _ (Raw s) = Raw s
-    fixDeref vp (DerefIdent (Ident i)) = DerefIdent $ Ident $ fixIdent vp i
-    fixDeref vp (DerefBranch a b) = DerefBranch (fixDeref vp a) (fixDeref vp b)
-    fixDeref _ d = d
-    fixIdent vp i =
-        case lookup i vp of
-            Nothing -> i
-            Just y -> nameBase y
-
-sToClause :: String -> SDef -> Q Clause
-sToClause dt sdef = do
-    (pat, bod) <- mkBody dt (sconstr sdef) (map fst $ svars sdef) (scontent sdef)
-    return $ Clause
-        [WildP, ConP (mkName "[]") [], pat]
-        (NormalB bod)
-        []
-
-defClause :: Q Clause
-defClause = do
-    a <- newName "sub"
-    c <- newName "langs"
-    d <- newName "msg"
-    rm <- [|renderMessage|]
-    return $ Clause
-        [VarP a, ConP (mkName ":") [WildP, VarP c], VarP d]
-        (NormalB $ rm `AppE` VarE a `AppE` VarE c `AppE` VarE d)
-        []
-
-toCon :: String -> SDef -> Con
-toCon dt (SDef c vs _) =
-    RecC (mkName $ "Msg" ++ c) $ map go vs
-  where
-    go (n, t) = (varName dt n, NotStrict, ConT $ mkName t)
-
-varName :: String -> String -> Name
-varName a y =
-    mkName $ concat [lower a, "Message", upper y]
-  where
-    lower (x:xs) = toLower x : xs
-    lower [] = []
-    upper (x:xs) = toUpper x : xs
-    upper [] = []
-
-checkDef :: [SDef] -> [Def] -> Q ()
-checkDef x y =
-    go (sortBy (comparing sconstr) x) (sortBy (comparing constr) y)
-  where
-    go _ [] = return ()
-    go [] (b:_) = error $ "Extra message constructor: " ++ constr b
-    go (a:as) (b:bs)
-        | sconstr a < constr b = go as (b:bs)
-        | sconstr a > constr b = error $ "Extra message constructor: " ++ constr b
-        | otherwise = do
-            go' (svars a) (vars b)
-            go as bs
-    go' ((an, at):as) ((bn, mbt):bs)
-        | an /= bn = error "Mismatched variable names"
-        | otherwise =
-            case mbt of
-                Nothing -> go' as bs
-                Just bt
-                    | at == bt -> go' as bs
-                    | otherwise -> error "Mismatched variable types"
-    go' [] [] = return ()
-    go' _ _ = error "Mistmached variable count"
-
-toSDefs :: [Def] -> Q [SDef]
-toSDefs = mapM toSDef
-
-toSDef :: Def -> Q SDef
-toSDef d = do
-    vars' <- mapM go $ vars d
-    return $ SDef (constr d) vars' (content d)
-  where
-    go (a, Just b) = return (a, b)
-    go (a, Nothing) = error $ "Main language missing type for " ++ show (constr d, a)
-
-data SDef = SDef
-    { sconstr :: String
-    , svars :: [(String, String)]
-    , scontent :: [Content]
-    }
-
-data Def = Def
-    { constr :: String
-    , vars :: [(String, Maybe String)]
-    , content :: [Content]
-    }
-
-loadLang :: FilePath -> FilePath -> IO (Maybe (Lang, [Def]))
-loadLang folder file = do
-    let file' = folder ++ '/' : file
-    e <- doesFileExist file'
-    if e && ".msg" `isSuffixOf` file
-        then do
-            let lang = pack $ reverse $ drop 4 $ reverse file
-            bs <- S.readFile file'
-            let s = unpack $ decodeUtf8 bs
-            defs <- fmap catMaybes $ mapM parseDef $ lines s
-            return $ Just (lang, defs)
-        else return Nothing
-
-parseDef :: String -> IO (Maybe Def)
-parseDef "" = return Nothing
-parseDef ('#':_) = return Nothing
-parseDef s =
-    case end of
-        ':':end' -> do
-            content' <- fmap compress $ parseContent $ dropWhile isSpace end'
-            case words begin of
-                [] -> error $ "Missing constructor: " ++ s
-                (w:ws) -> return $ Just Def
-                            { constr = w
-                            , vars = map parseVar ws
-                            , content = content'
-                            }
-        _ -> error $ "Missing colon: " ++ s
-  where
-    (begin, end) = break (== ':') s
-
-data Content = Var Deref | Raw String
-
-compress :: [Content] -> [Content]
-compress [] = []
-compress (Raw a:Raw b:rest) = compress $ Raw (a ++ b) : rest
-compress (x:y) = x : compress y
-
-parseContent :: String -> IO [Content]
-parseContent s =
-    either (error . show) return $ parse go s s
-  where
-    go = do
-        x <- many go'
-        eof
-        return x
-    go' = (Raw `fmap` many1 (noneOf "#")) <|> (fmap (either Raw Var) parseHash)
-
-parseVar :: String -> (String, Maybe String)
-parseVar s =
-    case break (== '@') s of
-        (x, '@':y) -> (x, Just y)
-        _ -> (s, Nothing)
-
-data SomeMessage master = forall msg. RenderMessage master msg => SomeMessage msg
-
-instance IsString (SomeMessage master) where
-    fromString = SomeMessage . T.pack
+import Text.Shakespeare.I18N

yesod-core/Yesod/Widget.hs

@@ -5,6 +5,7 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE TypeSynonymInstances #-}
 {-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE CPP #-}
 -- | Widgets combine HTML with JS and CSS dependencies with a unique identifier
 -- generator, allowing you to create truly modular HTML components.
 module Yesod.Widget
@@ -56,7 +57,7 @@ module Yesod.Widget
     ) where
 
 import Data.Monoid
-import Control.Monad.Trans.RWS
+import Control.Monad.Trans.Writer
 import qualified Text.Blaze.Html5 as H
 import Text.Hamlet
 import Text.Cassius
@@ -78,22 +79,48 @@ import qualified Data.Map as Map
 import Language.Haskell.TH.Quote (QuasiQuoter)
 import Language.Haskell.TH.Syntax (Q, Exp (InfixE, VarE, LamE), Pat (VarP), newName)
 
+#if MIN_VERSION_monad_control(0, 3, 0)
+import Control.Monad.Trans.Control (MonadTransControl (..), MonadBaseControl (..), defaultLiftBaseWith, defaultRestoreM, ComposeSt)
+#else
 import Control.Monad.IO.Control (MonadControlIO)
+#endif
 import qualified Text.Hamlet as NP
 import Data.Text.Lazy.Builder (fromLazyText)
 import Text.Blaze (toHtml, preEscapedLazyText)
+import Control.Monad.Base (MonadBase (liftBase))
 
 -- | A generic widget, allowing specification of both the subsite and master
 -- site datatypes. This is basically a large 'WriterT' stack keeping track of
 -- dependencies along with a 'StateT' to track unique identifiers.
 newtype GGWidget m monad a = GWidget { unGWidget :: GWInner m monad a }
-    deriving (Functor, Applicative, Monad, MonadIO, MonadControlIO)
+    deriving (Functor, Applicative, Monad, MonadIO
+#if !MIN_VERSION_monad_control(0, 3, 0)
+    , MonadControlIO
+#endif
+    )
+
+instance MonadBase b m => MonadBase b (GGWidget master m) where
+    liftBase = lift . liftBase
+#if MIN_VERSION_monad_control(0, 3, 0)
+instance MonadTransControl (GGWidget master) where
+    newtype StT (GGWidget master) a =
+       StWidget {unStWidget :: StT (GWInner master) a}
+    liftWith f = GWidget $ liftWith $ \run ->
+                  f $ liftM StWidget . run . unGWidget
+    restoreT = GWidget . restoreT . liftM unStWidget
+    {-# INLINE liftWith #-}
+    {-# INLINE restoreT #-}
+instance MonadBaseControl b m => MonadBaseControl b (GGWidget master m) where
+     newtype StM (GGWidget master m) a = StMT {unStMT :: ComposeSt (GGWidget master) m a}
+     liftBaseWith = defaultLiftBaseWith StMT
+     restoreM     = defaultRestoreM   unStMT
+#endif
 
 instance MonadTrans (GGWidget m) where
     lift = GWidget . lift
 
 type GWidget s m = GGWidget m (GHandler s m)
-type GWInner master = RWST () (GWData (Route master)) Int
+type GWInner master = WriterT (GWData (Route master))
 
 instance (Monad monad, a ~ ()) => Monoid (GGWidget master monad a) where
     mempty = return ()
@@ -103,9 +130,7 @@ addSubWidget :: (YesodSubRoute sub master) => sub -> GWidget sub master a -> GWi
 addSubWidget sub (GWidget w) = do
     master <- lift getYesod
     let sr = fromSubRoute sub master
-    s <- GWidget get
-    (a, s', w') <- lift $ toMasterHandlerMaybe sr (const sub) Nothing $ runRWST w () s
-    GWidget $ put s'
+    (a, w') <- lift $ toMasterHandlerMaybe sr (const sub) Nothing $ runWriterT w
     GWidget $ tell w'
     return a
 
@@ -192,7 +217,7 @@ addWidget = id
 
 -- | Add some raw CSS to the style tag. Applies to all media types.
 addCassius :: Monad m => CssUrl (Route master) -> GGWidget master m ()
-addCassius x = GWidget $ tell $ GWData mempty mempty mempty mempty (Map.singleton Nothing x) mempty mempty
+addCassius x = GWidget $ tell $ GWData mempty mempty mempty mempty (Map.singleton Nothing $ \r -> fromLazyText $ renderCss $ x r) mempty mempty
 
 -- | Identical to 'addCassius'.
 addLucius :: Monad m => CssUrl (Route master) -> GGWidget master m ()
@@ -200,7 +225,7 @@ addLucius = addCassius
 
 -- | Add some raw CSS to the style tag, for a specific media type.
 addCassiusMedia :: Monad m => Text -> CssUrl (Route master) -> GGWidget master m ()
-addCassiusMedia m x = GWidget $ tell $ GWData mempty mempty mempty mempty (Map.singleton (Just m) x) mempty mempty
+addCassiusMedia m x = GWidget $ tell $ GWData mempty mempty mempty mempty (Map.singleton (Just m) $ \r -> fromLazyText $ renderCss $ x r) mempty mempty
 
 -- | Identical to 'addCassiusMedia'.
 addLuciusMedia :: Monad m => Text -> CssUrl (Route master) -> GGWidget master m ()
@@ -273,9 +298,9 @@ addCoffeeBody c = do
 -- manipulations. It can be easier to use this sometimes than 'wrapWidget'.
 extractBody :: Monad mo => GGWidget m mo () -> GGWidget m mo (HtmlUrl (Route m))
 extractBody (GWidget w) =
-    GWidget $ mapRWST (liftM go) w
+    GWidget $ mapWriterT (liftM go) w
   where
-    go ((), s, GWData (Body h) b c d e f g) = (h, s, GWData (Body mempty) b c d e f g)
+    go ((), GWData (Body h) b c d e f g) = (h, GWData (Body mempty) b c d e f g)
 
 -- | Content for a web page. By providing this datatype, we can easily create
 -- generic site templates, which would have the type signature:

yesod-core/bench.sh

@@ -0,0 +1,8 @@
+#!/bin/bash -ex
+
+ghc --make bench/pong.hs
+ghc --make bench/pong.hs -prof -osuf o_p -caf-all -auto-all -rtsopts
+./bench/pong +RTS -p &
+sleep 2
+ab -n 1000 -c 5 http://localhost:3000/ 2>&1 | grep 'Time taken'
+curl http://localhost:3000/kill

yesod-core/bench/pong.hs

@@ -0,0 +1,32 @@
+{-# LANGUAGE OverloadedStrings, QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}
+import Yesod.Dispatch
+import Yesod.Content
+import Yesod.Internal.Core
+import Data.ByteString (ByteString)
+import Network.Wai.Handler.Warp (run)
+import Control.Concurrent.MVar
+import Control.Concurrent
+import Network.Wai
+import Control.Monad.IO.Class
+
+data Pong = Pong
+mkYesod "Pong" [$parseRoutes|
+/ PongR GET
+|]
+
+instance Yesod Pong where
+    approot _ = ""
+    encryptKey _ = return Nothing
+
+getPongR = return $ RepPlain $ toContent ("PONG" :: ByteString)
+
+main = do
+    app <- toWaiAppPlain Pong
+    flag <- newEmptyMVar
+    forkIO $ run 3000 $ \req ->
+        if pathInfo req == ["kill"]
+            then do
+                liftIO $ putMVar flag ()
+                error "done"
+            else app req
+    takeMVar flag

yesod-core/helloworld.hs

@@ -5,10 +5,13 @@
 import Yesod.Core
 import Network.Wai.Handler.Warp (run)
 import Data.Text (unpack)
+import Text.Julius (julius)
 
 data Subsite = Subsite String
 
-mkYesodSub "Subsite" [] [$parseRoutes|
+type Strings = [String]
+
+mkYesodSub "Subsite" [] [parseRoutes|
 / SubRootR GET
 /multi/*Strings SubMultiR
 |]
@@ -32,9 +35,15 @@ mkYesod "HelloWorld" [$parseRoutes|
 / RootR GET
 /subsite/#String SubsiteR Subsite getSubsite
 |]
-instance Yesod HelloWorld where approot _ = ""
--- getRootR :: GHandler HelloWorld HelloWorld RepPlain -- FIXME remove type sig
+instance Yesod HelloWorld where
+    approot _ = ""
+    yepnopeJs _ = Just $ Left "http://cdnjs.cloudflare.com/ajax/libs/modernizr/2.0.6/modernizr.min.js"
+
 getRootR = do
     $(logOther "HAHAHA") "Here I am"
-    return $ RepPlain "Hello World"
+    defaultLayout $ do
+        addScriptRemote "https://ajax.googleapis.com/ajax/libs/jquery/1.6.4/jquery.min.js"
+        toWidget [julius|$(function(){$("#mypara").css("color", "red")});|]
+        [whamlet|<p #mypara>Hello World|]
+
 main = toWaiApp (HelloWorld Subsite) >>= run 3000

yesod-core/test.hs

@@ -0,0 +1,4 @@
+import Test.Hspec
+import qualified YesodCoreTest
+
+main = hspecX $ descriptions $ YesodCoreTest.specs

yesod-core/test/YesodCoreTest.hs

@@ -0,0 +1,26 @@
+module YesodCoreTest (specs) where 
+
+import YesodCoreTest.CleanPath
+import YesodCoreTest.Exceptions
+import YesodCoreTest.Widget
+import YesodCoreTest.Media
+import YesodCoreTest.Links
+import YesodCoreTest.NoOverloadedStrings
+import YesodCoreTest.InternalRequest
+import YesodCoreTest.ErrorHandling
+import YesodCoreTest.Cache
+
+import Test.Hspec
+
+specs :: [Specs]
+specs = 
+    [ cleanPathTest
+    , exceptionsTest
+    , widgetTest
+    , mediaTest
+    , linksTest
+    , noOverloadedTest
+    , internalRequestTest
+    , errorHandlingTest
+    , cacheTest
+    ]

yesod-core/test/YesodCoreTest/Cache.hs

@@ -0,0 +1,50 @@
+{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FlexibleInstances #-}
+module YesodCoreTest.Cache (cacheTest, Widget) where
+
+import Test.Hspec
+import Test.Hspec.HUnit()
+
+import Network.Wai
+import Network.Wai.Test
+
+import Yesod.Core
+
+data C = C
+
+key :: CacheKey Int
+key = $(mkCacheKey)
+
+key2 :: CacheKey Int
+key2 = $(mkCacheKey)
+
+mkYesod "C" [parseRoutes|/ RootR GET|]
+
+instance Yesod C where approot _ = ""
+
+getRootR :: Handler ()
+getRootR = do
+    Nothing <- cacheLookup key
+    cacheInsert key 5
+    Just 5 <- cacheLookup key
+    cacheInsert key 7
+    Just 7 <- cacheLookup key
+    Nothing <- cacheLookup key2
+    cacheDelete key
+    Nothing <- cacheLookup key
+    return ()
+
+cacheTest :: [Spec]
+cacheTest =
+  describe "Test.Cache"
+    [ it "works" works
+    ]
+
+runner :: Session () -> IO ()
+runner f = toWaiApp C >>= runSession f
+
+works :: IO ()
+works = runner $ do
+    res <- request defaultRequest { pathInfo = [] }
+    assertStatus 200 res

yesod-core/test/YesodCoreTest/CleanPath.hs

@@ -1,7 +1,7 @@
 {-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE FlexibleInstances #-}
-module Test.CleanPath (cleanPathTest, Widget) where
+module YesodCoreTest.CleanPath (cleanPathTest, Widget) where
 
 import Test.Hspec
 import Test.Hspec.HUnit()

yesod-core/test/YesodCoreTest/ErrorHandling.hs

@@ -0,0 +1,111 @@
+{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-}
+module YesodCoreTest.ErrorHandling
+    ( errorHandlingTest
+    , Widget
+    ) where
+import Yesod.Core
+import Test.Hspec
+import Test.Hspec.HUnit()
+import Network.Wai
+import Network.Wai.Test
+import Text.Hamlet (hamlet)
+import qualified Data.ByteString.Lazy as L
+import qualified Data.ByteString.Char8 as S8
+import Yesod.Internal.TestApi
+import qualified Data.Enumerator as E
+import qualified Data.Enumerator.List as EL
+import Control.Exception (SomeException)
+
+data App = App
+
+mkYesod "App" [parseRoutes|
+/               HomeR GET
+/not_found      NotFoundR POST
+/first_thing    FirstThingR POST
+/after_runRequestBody AfterRunRequestBodyR POST
+|]
+
+instance Yesod App where approot _ = ""
+
+getHomeR :: Handler RepHtml
+getHomeR = defaultLayout $ toWidget [hamlet|
+!!!
+
+<html>
+  <body>
+    <form method=post action=@{NotFoundR}>
+      <input type=submit value="Not found">
+    <form method=post action=@{FirstThingR}>
+      <input type=submit value="Error is thrown first thing in handler">
+    <form method=post action=@{AfterRunRequestBodyR}>
+      <input type=submit value="BUGGY: Error thrown after runRequestBody">
+|]
+
+postNotFoundR, postFirstThingR, postAfterRunRequestBodyR :: Handler RepHtml
+postNotFoundR = do
+   (_, _files) <- runRequestBody
+   _ <- notFound
+   getHomeR
+
+postFirstThingR = do
+   _ <- error "There was an error 3.14159"
+   getHomeR
+
+postAfterRunRequestBodyR = do
+   x <- runRequestBody
+   _ <- error $ show x
+   getHomeR
+
+errorHandlingTest :: [Spec]
+errorHandlingTest = describe "Test.ErrorHandling"
+    [ it "says not found" caseNotFound
+    , it "says 'There was an error' before runRequestBody" caseBefore
+    , it "says 'There was an error' after runRequestBody" caseAfter
+    , it "catchIter handles internal exceptions" caseCatchIter
+    ]
+
+runner :: Session () -> IO ()
+runner f = toWaiApp App >>= runSession f
+
+caseNotFound :: IO ()
+caseNotFound = runner $ do
+    res <- request defaultRequest
+            { pathInfo = ["not_found"]
+            , requestMethod = "POST"
+            }
+    assertStatus 404 res
+    assertBodyContains "Not Found" res
+
+caseBefore :: IO ()
+caseBefore = runner $ do
+    res <- request defaultRequest
+            { pathInfo = ["first_thing"]
+            , requestMethod = "POST"
+            }
+    assertStatus 500 res
+    assertBodyContains "There was an error 3.14159" res
+
+caseAfter :: IO ()
+caseAfter = runner $ do
+    let content = "foo=bar&baz=bin12345"
+    res <- srequest SRequest
+        { simpleRequest = defaultRequest
+            { pathInfo = ["after_runRequestBody"]
+            , requestMethod = "POST"
+            , requestHeaders =
+                [ ("content-type", "application/x-www-form-urlencoded")
+                , ("content-length", S8.pack $ show $ L.length content)
+                ]
+            }
+        , simpleRequestBody = content
+        }
+    assertStatus 500 res
+    assertBodyContains "bin12345" res
+
+caseCatchIter :: IO ()
+caseCatchIter = E.run_ $ E.enumList 8 (replicate 1000 "foo") E.$$ flip catchIter ignorer $ do
+    _ <- EL.consume
+    error "foo"
+  where
+    ignorer :: SomeException -> E.Iteratee a IO ()
+    ignorer _ = return ()

yesod-core/test/YesodCoreTest/Exceptions.hs

@@ -1,17 +1,19 @@
 {-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE FlexibleInstances #-}
-module Test.Exceptions (exceptionsTest, Widget) where
+module YesodCoreTest.Exceptions (exceptionsTest, Widget) where
 
 import Test.Hspec
 import Test.Hspec.HUnit ()
 
 import Yesod.Core hiding (Request)
+import Network.Wai
 import Network.Wai.Test
 
 data Y = Y
 mkYesod "Y" [parseRoutes|
 / RootR GET
+/redirect RedirR GET
 |]
 
 instance Yesod Y where
@@ -22,9 +24,15 @@ instance Yesod Y where
 getRootR :: Handler ()
 getRootR = error "FOOBAR" >> return ()
 
+getRedirR :: Handler ()
+getRedirR = do
+    setHeader "foo" "bar"
+    redirect RedirectPermanent RootR
+
 exceptionsTest :: [Spec]
 exceptionsTest = describe "Test.Exceptions"
     [ it "500" case500
+    , it "redirect keeps headers" caseRedirect
     ]
 
 runner :: Session () -> IO ()
@@ -35,3 +43,9 @@ case500 = runner $ do
     res <- request defaultRequest
     assertStatus 500 res
     assertBody "FOOBAR" res
+
+caseRedirect :: IO ()
+caseRedirect = runner $ do
+    res <- request defaultRequest { pathInfo = ["redirect"] }
+    assertStatus 301 res
+    assertHeader "foo" "bar" res

yesod-core/test/YesodCoreTest/InternalRequest.hs

@@ -1,5 +1,5 @@
 {-# LANGUAGE OverloadedStrings #-}
-module Test.InternalRequest (internalRequestTest) where
+module YesodCoreTest.InternalRequest (internalRequestTest) where
 
 import Data.List (nub)
 import System.Random (StdGen, mkStdGen)
@@ -30,16 +30,16 @@ g = undefined
 
 nonceSpecs :: [Spec]
 nonceSpecs = describe "Yesod.Internal.Request.parseWaiRequest (reqNonce)"
-  [ it "is Nothing for unsecure sessions" noUnsecureNonce
-  , it "ignores pre-existing nonce for unsecure sessions" ignoreUnsecureNonce
-  , it "uses preexisting nonce for secure sessions" useOldNonce
-  , it "generates a new nonce for secure sessions without nonce" generateNonce
+  [ it "is Nothing if sessions are disabled" noDisabledNonce
+  , it "ignores pre-existing nonce if sessions are disabled" ignoreDisabledNonce
+  , it "uses preexisting nonce in session" useOldNonce
+  , it "generates a new nonce for sessions without nonce" generateNonce
   ]
 
-noUnsecureNonce = reqNonce r == Nothing where
+noDisabledNonce = reqNonce r == Nothing where
   r = parseWaiRequest' defaultRequest [] Nothing g
 
-ignoreUnsecureNonce = reqNonce r == Nothing where
+ignoreDisabledNonce = reqNonce r == Nothing where
   r = parseWaiRequest' defaultRequest [("_NONCE", "old")] Nothing g
 
 useOldNonce = reqNonce r == Just "old" where

yesod-core/test/YesodCoreTest/Links.hs

@@ -1,7 +1,7 @@
 {-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE FlexibleInstances #-}
-module Test.Links (linksTest, Widget) where
+module YesodCoreTest.Links (linksTest, Widget) where
 
 import Test.Hspec
 import Test.Hspec.HUnit ()

yesod-core/test/YesodCoreTest/Media.hs

@@ -1,7 +1,7 @@
 {-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE FlexibleInstances #-}
-module Test.Media (mediaTest, Widget) where
+module YesodCoreTest.Media (mediaTest, Widget) where
 
 import Test.Hspec
 import Test.Hspec.HUnit ()

yesod-core/test/YesodCoreTest/NoOverloadedStrings.hs

@@ -1,6 +1,6 @@
 {-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}
 {-# LANGUAGE FlexibleInstances #-}
-module Test.NoOverloadedStrings (noOverloadedTest, Widget) where
+module YesodCoreTest.NoOverloadedStrings (noOverloadedTest, Widget) where
 
 import Test.Hspec
 import Test.Hspec.HUnit ()

yesod-core/test/YesodCoreTest/Widget.hs

@@ -1,7 +1,7 @@
 {-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE FlexibleInstances #-}
-module Test.Widget (widgetTest) where
+module YesodCoreTest.Widget (widgetTest) where
 
 import Test.Hspec
 import Test.Hspec.HUnit ()

yesod-core/test/main.hs

@@ -1,20 +0,0 @@
-import Test.Hspec
-
-import Test.CleanPath
-import Test.Exceptions
-import Test.Widget
-import Test.Media
-import Test.Links
-import Test.NoOverloadedStrings
-import Test.InternalRequest
-
-main :: IO ()
-main = hspecX $ descriptions $
-    [ cleanPathTest
-    , exceptionsTest
-    , widgetTest
-    , mediaTest
-    , linksTest
-    , noOverloadedTest
-    , internalRequestTest
-    ]

yesod-core/test/test.hs

@@ -0,0 +1 @@
+../test.hs

yesod-core/yesod-core.cabal

@@ -1,5 +1,5 @@
 name:            yesod-core
-version:         0.9.3
+version:         0.9.4
 license:         BSD3
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>
@@ -14,6 +14,18 @@ stability:       Stable
 cabal-version:   >= 1.8
 build-type:      Simple
 homepage:        http://www.yesodweb.com/
+extra-source-files:
+  test/en.msg
+  test/YesodCoreTest/NoOverloadedStrings.hs
+  test/YesodCoreTest/Media.hs
+  test/YesodCoreTest/Exceptions.hs
+  test/YesodCoreTest/Widget.hs
+  test/YesodCoreTest/CleanPath.hs
+  test/YesodCoreTest/Links.hs
+  test/YesodCoreTest/InternalRequest.hs
+  test/YesodCoreTest/ErrorHandling.hs
+  test/YesodCoreTest/Cache.hs
+  test.hs
 
 flag test
   description: Build the executable to run unit tests
@@ -23,39 +35,51 @@ flag ghc7
 
 library
     if flag(ghc7)
-        build-depends:   base                      >= 4.3      && < 5
+        build-depends:   base              >= 4.3      && < 5
         cpp-options:     -DGHC7
     else
-        build-depends:   base                      >= 4        && < 4.3
-    build-depends:   time                      >= 1.1.4    && < 1.4
-                   , wai                       >= 0.4      && < 0.5
-                   , wai-extra                 >= 0.4.1    && < 0.5
-                   , bytestring                >= 0.9.1.4  && < 0.10
-                   , text                      >= 0.5      && < 0.12
+        build-depends:   base              >= 4        && < 4.3
+
+    -- Work around a bug in cabal. Without this, wai-test doesn't get built and
+    -- we have a missing dependency during --enable-tests builds.
+    if flag(test)
+        build-depends: wai-test
+
+    build-depends:   time                  >= 1.1.4
+                   , wai                   >= 0.4      && < 0.5
+                   , wai-extra             >= 0.4.1    && < 0.5
+                   , bytestring            >= 0.9.1.4  && < 0.10
+                   , text                  >= 0.7      && < 0.12
                    , template-haskell
-                   , path-pieces               >= 0.0      && < 0.1
-                   , hamlet                    >= 0.10     && < 0.11
-                   , shakespeare               >= 0.10     && < 0.11
-                   , shakespeare-js            >= 0.10     && < 0.11
-                   , shakespeare-css           >= 0.10     && < 0.11
-                   , blaze-builder             >= 0.2.1    && < 0.4
-                   , transformers              >= 0.2      && < 0.3
-                   , clientsession             >= 0.7.2    && < 0.8
-                   , random                    >= 1.0.0.2  && < 1.1
-                   , cereal                    >= 0.2      && < 0.4
-                   , old-locale                >= 1.0.0.2  && < 1.1
-                   , failure                   >= 0.1      && < 0.2
-                   , containers                >= 0.2      && < 0.5
-                   , monad-control             >= 0.2      && < 0.3
-                   , enumerator                >= 0.4.7    && < 0.5
-                   , cookie                    >= 0.3      && < 0.4
-                   , blaze-html                >= 0.4      && < 0.5
-                   , http-types                >= 0.6.5    && < 0.7
-                   , case-insensitive          >= 0.2      && < 0.4
-                   , parsec                    >= 2        && < 3.2
-                   , directory                 >= 1        && < 1.2
+                   , path-pieces           >= 0.0      && < 0.1
+                   , hamlet                >= 0.10     && < 0.11
+                   , shakespeare           >= 0.10     && < 0.11
+                   , shakespeare-js        >= 0.10.4   && < 0.11
+                   , shakespeare-css       >= 0.10.5   && < 0.11
+                   , shakespeare-i18n      >= 0.0      && < 0.1
+                   , blaze-builder         >= 0.2.1.4  && < 0.4
+                   , transformers          >= 0.2.2    && < 0.3
+                   , clientsession         >= 0.7.3.1  && < 0.8
+                   , random                >= 1.0.0.2  && < 1.1
+                   , cereal                >= 0.3      && < 0.4
+                   , old-locale            >= 1.0.0.2  && < 1.1
+                   , failure               >= 0.1      && < 0.2
+                   , containers            >= 0.2      && < 0.5
+                   , monad-control         >= 0.2      && < 0.4
+                   , transformers-base     >= 0.4
+                   , enumerator            >= 0.4.8    && < 0.5
+                   , cookie                >= 0.3      && < 0.4
+                   , blaze-html            >= 0.4.1.3  && < 0.5
+                   , http-types            >= 0.6.5    && < 0.7
+                   , case-insensitive      >= 0.2
+                   , parsec                >= 2        && < 3.2
+                   , directory             >= 1        && < 1.2
+                   , data-object           >= 0.3      && < 0.4
+                   , data-object-yaml      >= 0.3      && < 0.4
                    -- for logger. Probably logger should be a separate package
-                   , strict-concurrency        >= 0.2.4    && < 0.2.5
+                   , strict-concurrency    >= 0.2.4    && < 0.2.5
+                   , vector                >= 0.9      && < 0.10
+                   , aeson                 >= 0.3
 
     exposed-modules: Yesod.Content
                      Yesod.Core
@@ -65,8 +89,10 @@ library
                      Yesod.Request
                      Yesod.Widget
                      Yesod.Message
+                     Yesod.Config
                      Yesod.Internal.TestApi
     other-modules:   Yesod.Internal
+                     Yesod.Internal.Cache
                      Yesod.Internal.Core
                      Yesod.Internal.Session
                      Yesod.Internal.Request
@@ -74,26 +100,24 @@ library
                      Yesod.Internal.RouteParsing
                      Paths_yesod_core
     ghc-options:     -Wall
-    if flag(test)
-        Buildable: False
 
-test-suite runtests
+test-suite tests
     type: exitcode-stdio-1.0
-    main-is: main.hs
+    main-is: test.hs
     hs-source-dirs: test
 
     if flag(ghc7)
         type: exitcode-stdio-1.0
         build-depends:   base                      >= 4.3      && < 5
         cpp-options:     -DGHC7
-        main-is:         main.hs
+        main-is:         test.hs
     else
         type: exitcode-stdio-1.0
         build-depends:   base                      >= 4        && < 4.3
-        main-is:         main.hs
+        main-is:         test.hs
     cpp-options:   -DTEST
-    build-depends: hspec >= 0.8 && < 0.9
-                  ,wai-test
+    build-depends: hspec >= 0.8 && < 0.10
+                  ,wai-test >= 0.1.2 && < 0.2
                   ,wai
                   ,yesod-core
                   ,bytestring
@@ -105,6 +129,7 @@ test-suite runtests
                   , random
                   ,HUnit
                   ,QuickCheck >= 2 && < 3
+                  , enumerator
     ghc-options:     -Wall
 
 source-repository head

yesod-default/LICENSE

@@ -0,0 +1,25 @@
+The following license covers this documentation, and the source code, except
+where otherwise indicated.
+
+Copyright 2010, Michael Snoyman. All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+* Redistributions of source code must retain the above copyright notice, this
+  list of conditions and the following disclaimer.
+
+* Redistributions in binary form must reproduce the above copyright notice,
+  this list of conditions and the following disclaimer in the documentation
+  and/or other materials provided with the distribution.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR
+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO
+EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,
+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
+NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,
+OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
+OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

yesod-default/Yesod/Default/Config.hs

@@ -0,0 +1,226 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Yesod.Default.Config
+    ( DefaultEnv (..)
+    , fromArgs
+    , fromArgsExtra
+    , loadDevelopmentConfig
+
+    -- reexport
+    , AppConfig (..)
+    , ConfigSettings (..)
+    , configSettings
+    , loadConfig
+    , withYamlEnvironment
+    ) where
+
+import Data.Char (toUpper, toLower)
+import System.Console.CmdArgs hiding (args)
+import Data.Text (Text)
+import qualified Data.Text as T
+import Control.Monad (join)
+import Data.Object
+import Data.Object.Yaml
+import Data.Maybe (fromMaybe)
+
+-- | A yesod-provided @'AppEnv'@, allows for Development, Testing, and
+--   Production environments
+data DefaultEnv = Development
+                | Testing
+                | Staging
+                | Production deriving (Read, Show, Enum, Bounded)
+
+-- | Setup commandline arguments for environment and port
+data ArgConfig = ArgConfig
+    { environment :: String
+    , port        :: Int
+    } deriving (Show, Data, Typeable)
+
+-- | A default @'ArgConfig'@ if using the provided @'DefaultEnv'@ type.
+defaultArgConfig :: ArgConfig
+defaultArgConfig =
+    ArgConfig
+        { environment = def
+            &= argPos 0
+            &= typ   "ENVIRONMENT"
+        , port = def
+            &= help "the port to listen on"
+            &= typ  "PORT"
+        }
+
+-- | Load an @'AppConfig'@ using the @'DefaultEnv'@ environments from
+--   commandline arguments.
+fromArgs :: IO (AppConfig DefaultEnv ())
+fromArgs = fromArgsExtra (const $ const $ return ())
+
+-- | Same as 'fromArgs', but allows you to specify how to parse the 'appExtra'
+-- record.
+fromArgsExtra :: (DefaultEnv -> TextObject -> IO extra)
+              -> IO (AppConfig DefaultEnv extra)
+fromArgsExtra = fromArgsWith defaultArgConfig
+
+fromArgsWith :: (Read env, Show env)
+             => ArgConfig
+             -> (env -> TextObject -> IO extra)
+             -> IO (AppConfig env extra)
+fromArgsWith argConfig getExtra = do
+    args   <- cmdArgs argConfig
+
+    env <-
+        case reads $ capitalize $ environment args of
+            (e, _):_ -> return e
+            [] -> error $ "Invalid environment: " ++ environment args
+
+    let cs = (configSettings env)
+                { csLoadExtra = getExtra
+                }
+    config <- loadConfig cs
+
+    return $ if port args /= 0
+                then config { appPort = port args }
+                else config
+
+    where
+        capitalize [] = []
+        capitalize (x:xs) = toUpper x : map toLower xs
+
+-- | Load your development config (when using @'DefaultEnv'@)
+loadDevelopmentConfig :: IO (AppConfig DefaultEnv ())
+loadDevelopmentConfig = loadConfig $ configSettings Development
+
+-- | Dynamic per-environment configuration which can be loaded at
+--   run-time negating the need to recompile between environments.
+data AppConfig environment extra = AppConfig
+    { appEnv   :: environment
+    , appPort  :: Int
+    , appRoot  :: Text
+    , appExtra :: extra
+    } deriving (Show)
+
+data ConfigSettings environment extra = ConfigSettings
+    {
+    -- | An arbitrary value, used below, to indicate the current running
+    -- environment. Usually, you will use 'DefaultEnv' for this type.
+       csEnv :: environment
+    -- | Load any extra data, to be used by the application.
+    , csLoadExtra :: environment -> TextObject -> IO extra
+    -- | Return the path to the YAML config file.
+    , csFile :: environment -> IO FilePath
+    -- | Get the sub-object (if relevant) from the given YAML source which
+    -- contains the specific settings for the current environment.
+    , csGetObject :: environment -> TextObject -> IO TextObject
+    }
+
+-- | Default config settings.
+configSettings :: Show env => env -> ConfigSettings env ()
+configSettings env0 = ConfigSettings
+    { csEnv = env0
+    , csLoadExtra = \_ _ -> return ()
+    , csFile = \_ -> return "config/settings.yml"
+    , csGetObject = \env obj -> do
+        envs <- fromMapping obj
+        let senv = show env
+            tenv = T.pack senv
+        maybe
+            (error $ "Could not find environment: " ++ senv)
+            return
+            (lookup tenv envs)
+    }
+
+-- | Load an @'AppConfig'@.
+--
+--   Some examples:
+--
+--   > -- typical local development
+--   > Development:
+--   >   host: localhost
+--   >   port: 3000
+--   >
+--   >   -- ssl: will default false
+--   >   -- approot: will default to "http://localhost:3000"
+--
+--   > -- typical outward-facing production box
+--   > Production:
+--   >   host: www.example.com
+--   >
+--   >   -- ssl: will default false
+--   >   -- port: will default 80
+--   >   -- approot: will default "http://www.example.com"
+--
+--   > -- maybe you're reverse proxying connections to the running app
+--   > -- on some other port
+--   > Production:
+--   >   port: 8080
+--   >   approot: "http://example.com"
+--   >
+--   > -- approot is specified so that the non-80 port is not appended
+--   > -- automatically.
+--
+loadConfig :: ConfigSettings environment extra
+           -> IO (AppConfig environment extra)
+loadConfig (ConfigSettings env loadExtra getFile getObject) = do
+    fp <- getFile env
+    topObj <- join $ decodeFile fp
+    obj <- getObject env topObj
+
+    m <- maybe (fail "Expected map") return $ fromMapping obj
+    let mssl     = lookupScalar "ssl"     m
+    let mhost    = lookupScalar "host"    m
+    let mport    = lookupScalar "port"    m
+    let mapproot = lookupScalar "approot" m
+
+    extra <- loadExtra env obj
+
+    -- set some default arguments
+    let ssl = maybe False toBool mssl
+    port' <- safeRead "port" $ fromMaybe (if ssl then "443" else "80") mport
+
+    approot <- case (mhost, mapproot) of
+        (_        , Just ar) -> return ar
+        (Just host, _      ) -> return $ T.concat
+            [ if ssl then "https://" else "http://"
+            , host
+            , addPort ssl port'
+            ]
+        _ -> fail "You must supply either a host or approot"
+
+    return $ AppConfig
+        { appEnv   = env
+        , appPort  = port'
+        , appRoot  = approot
+        , appExtra = extra
+        }
+
+    where
+        toBool :: Text -> Bool
+        toBool = (`elem` ["true", "TRUE", "yes", "YES", "Y", "1"])
+
+        addPort :: Bool -> Int -> Text
+        addPort True  443 = ""
+        addPort False 80  = ""
+        addPort _     p   = T.pack $ ':' : show p
+
+-- | Returns 'fail' if read fails
+safeRead :: Monad m => String -> Text -> m Int
+safeRead name' t = case reads s of
+    (i, _):_ -> return i
+    []       -> fail $ concat ["Invalid value for ", name', ": ", s]
+  where
+    s = T.unpack t
+
+-- | Loads the configuration block in the passed file named by the
+--   passed environment, yeilds to the passed function as a mapping.
+--
+--   Errors in the case of a bad load or if your function returns
+--   @Nothing@.
+withYamlEnvironment :: Show e
+                    => FilePath -- ^ the yaml file
+                    -> e        -- ^ the environment you want to load
+                    -> (TextObject -> IO a) -- ^ what to do with the mapping
+                    -> IO a
+withYamlEnvironment fp env f = do
+    obj <- join $ decodeFile fp
+    envs <- fromMapping obj
+    conf <- maybe (fail $ "Could not find environment: " ++ show env) return
+          $ lookup (T.pack $ show env) envs
+    f conf

yesod-default/Yesod/Default/Handlers.hs

@@ -0,0 +1,14 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Yesod.Default.Handlers
+    ( getFaviconR
+    , getRobotsR
+    ) where
+
+import Yesod.Handler (GHandler, sendFile)
+import Yesod.Content (RepPlain(..))
+
+getFaviconR :: GHandler s m ()
+getFaviconR = sendFile "image/x-icon" "config/favicon.ico"
+
+getRobotsR :: GHandler s m RepPlain
+getRobotsR = sendFile "text/plain" "config/robots.txt"

yesod-default/Yesod/Default/Main.hs

@@ -0,0 +1,115 @@
+{-# LANGUAGE CPP                #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+module Yesod.Default.Main
+    ( defaultMain
+    , defaultRunner
+    , defaultDevelApp
+    , defaultDevelAppWith
+    ) where
+
+import Yesod.Core hiding (AppConfig (..))
+import Yesod.Default.Config
+import Yesod.Logger (Logger, makeLogger, logString, logLazyText, flushLogger)
+import Network.Wai (Application)
+import Network.Wai.Handler.Warp (run)
+import Network.Wai.Middleware.Debug (debugHandle)
+import System.Directory (doesDirectoryExist, removeDirectoryRecursive)
+import Network.Wai.Middleware.Gzip (gzip', GzipFiles (GzipCacheFolder), gzipFiles, def)
+import Network.Wai.Middleware.Autohead (autohead)
+import Network.Wai.Middleware.Jsonp (jsonp)
+import Control.Monad (when)
+
+#ifndef WINDOWS
+import qualified System.Posix.Signals as Signal
+import Control.Concurrent (forkIO, killThread)
+import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)
+#endif
+
+-- | Run your app, taking environment and port settings from the
+--   commandline.
+--
+--   Use @'fromArgs'@ when using the provided @'DefaultEnv'@ type, or
+--   @'fromArgsWith'@ when using a custom type
+--
+--   > main :: IO ()
+--   > main = defaultMain fromArgs withMySite
+--
+--   or
+--
+--   > main :: IO ()
+--   > main = defaultMain (fromArgsWith customArgConfig) withMySite
+--
+defaultMain :: (Show env, Read env)
+            => IO (AppConfig env extra)
+            -> (AppConfig env extra -> Logger -> (Application -> IO ()) -> IO ())
+            -> IO ()
+defaultMain load withSite = do
+    config <- load
+    logger <- makeLogger
+    withSite config logger $ run (appPort config)
+
+-- | Run your application continously, listening for SIGINT and exiting
+--   when recieved
+--
+--   > withYourSite :: AppConfig DefaultEnv -> Logger -> (Application -> IO a) -> IO ()
+--   > withYourSite conf logger f = do
+--   >     Settings.withConnectionPool conf $ \p -> do
+--   >         runConnectionPool (runMigration yourMigration) p
+--   >         defaultRunner f $ YourSite conf logger p
+--
+--   TODO: ifdef WINDOWS
+--
+defaultRunner :: (YesodDispatch y y, Yesod y)
+              => (Application -> IO a)
+              -> y -- ^ your foundation type
+              -> IO ()
+defaultRunner f h = do
+    -- clear the .static-cache so we don't have stale content
+    exists <- doesDirectoryExist staticCache
+    when exists $ removeDirectoryRecursive staticCache
+#ifdef WINDOWS
+    toWaiAppPlain h >>= f . middlewares >> return ()
+#else
+    tid <- forkIO $ toWaiAppPlain h >>= f . middlewares >> return ()
+    flag <- newEmptyMVar
+    _ <- Signal.installHandler Signal.sigINT (Signal.CatchOnce $ do
+        putStrLn "Caught an interrupt"
+        killThread tid
+        putMVar flag ()) Nothing
+    takeMVar flag
+#endif
+  where
+    middlewares = gzip' gset . jsonp . autohead
+    gset = def { gzipFiles = GzipCacheFolder staticCache }
+    staticCache = ".static-cache"
+
+-- | Run your development app using the provided @'DefaultEnv'@ type
+--
+--   > withDevelAppPort :: Dynamic
+--   > withDevelAppPort = toDyn $ defaultDevelApp withMySite
+--
+defaultDevelApp :: (AppConfig DefaultEnv () -> Logger -> (Application -> IO ()) -> IO ())
+                -> ((Int, Application) -> IO ())
+                -> IO ()
+defaultDevelApp = defaultDevelAppWith loadDevelopmentConfig
+
+-- | Run your development app using a custom environment type and loader
+--   function
+--
+--   > withDevelAppPort :: Dynamic
+--   > withDevelAppPort = toDyn $ (defaultDevelAppWith customLoadAppConfig) withMySite
+--
+defaultDevelAppWith :: (Show env, Read env)
+                    => IO (AppConfig env extra) -- ^ A means to load your development @'AppConfig'@
+                    -> (AppConfig env extra -> Logger -> (Application -> IO ()) -> IO ()) -- ^ Your @withMySite@ function
+                    -> ((Int, Application) -> IO ()) -> IO ()
+defaultDevelAppWith load withSite f = do
+        conf   <- load
+        logger <- makeLogger
+        let p = appPort conf
+        logString logger $ "Devel application launched, listening on port " ++ show p
+        withSite conf logger $ \app -> f (p, debugHandle (logHandle logger) app)
+        flushLogger logger
+
+        where
+            logHandle logger msg = logLazyText logger msg >> flushLogger logger

yesod-default/Yesod/Default/Util.hs

@@ -0,0 +1,79 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE CPP #-}
+-- | Various utilities used in the scaffolded site.
+module Yesod.Default.Util
+    ( addStaticContentExternal
+    , globFile
+    , widgetFileNoReload
+    , widgetFileReload
+    ) where
+
+import Control.Monad.IO.Class (liftIO)
+import qualified Data.ByteString.Lazy as L
+import Data.Text (Text, pack, unpack)
+import Yesod.Core -- purposely using complete import so that Haddock will see addStaticContent
+import Control.Monad (unless)
+import System.Directory (doesFileExist, createDirectoryIfMissing)
+import Language.Haskell.TH.Syntax
+import Text.Lucius (luciusFile, luciusFileReload)
+import Text.Julius (juliusFile, juliusFileReload)
+import Text.Cassius (cassiusFile, cassiusFileReload)
+import Data.Monoid (mempty)
+
+-- | An implementation of 'addStaticContent' which stores the contents in an
+-- external file. Files are created in the given static folder with names based
+-- on a hash of their content. This allows expiration dates to be set far in
+-- the future without worry of users receiving stale content.
+addStaticContentExternal
+    :: (L.ByteString -> Either a L.ByteString) -- ^ javascript minifier
+    -> (L.ByteString -> String) -- ^ hash function to determine file name
+    -> FilePath -- ^ location of static directory. files will be placed within a "tmp" subfolder
+    -> ([Text] -> Route master) -- ^ route constructor, taking a list of pieces
+    -> Text -- ^ filename extension
+    -> Text -- ^ mime type
+    -> L.ByteString -- ^ file contents
+    -> GHandler sub master (Maybe (Either Text (Route master, [(Text, Text)])))
+addStaticContentExternal minify hash staticDir toRoute ext' _ content = do
+    liftIO $ createDirectoryIfMissing True statictmp
+    exists <- liftIO $ doesFileExist fn'
+    unless exists $ liftIO $ L.writeFile fn' content'
+    return $ Just $ Right (toRoute ["tmp", pack fn], [])
+  where
+    fn, statictmp, fn' :: FilePath
+    -- by basing the hash off of the un-minified content, we avoid a costly
+    -- minification if the file already exists
+    fn = hash content ++ '.' : unpack ext'
+    statictmp = staticDir ++ "/tmp/"
+    fn' = statictmp ++ fn
+
+    content' :: L.ByteString
+    content'
+        | ext' == "js" = either (const content) id $ minify content
+        | otherwise = content
+
+-- | expects a file extension for each type, e.g: hamlet lucius julius
+globFile :: String -> String -> FilePath
+globFile kind x = "templates/" ++ x ++ "." ++ kind
+
+widgetFileNoReload :: FilePath -> Q Exp
+widgetFileNoReload x = do
+    let h = whenExists x "hamlet"  whamletFile
+    let c = whenExists x "cassius" cassiusFile
+    let j = whenExists x "julius"  juliusFile
+    let l = whenExists x "lucius"  luciusFile
+    [|$h >> addCassius $c >> addJulius $j >> addLucius $l|]
+
+widgetFileReload :: FilePath -> Q Exp
+widgetFileReload x = do
+    let h = whenExists x "hamlet"  whamletFile
+    let c = whenExists x "cassius" cassiusFileReload
+    let j = whenExists x "julius"  juliusFileReload
+    let l = whenExists x "lucius"  luciusFileReload
+    [|$h >> addCassius $c >> addJulius $j >> addLucius $l|]
+
+whenExists :: String -> String -> (FilePath -> Q Exp) -> Q Exp
+whenExists x glob f = do
+    let fn = globFile glob x
+    e <- qRunIO $ doesFileExist fn
+    if e then f fn else [|mempty|]

yesod-default/yesod-default.cabal

@@ -0,0 +1,48 @@
+name:            yesod-default
+version:         0.5.0
+license:         BSD3
+license-file:    LICENSE
+author:          Patrick Brisbin
+maintainer:      Patrick Brisbin <pbrisbin@gmail.com>
+synopsis:        Default config and main functions for your yesod application
+category:        Web, Yesod
+stability:       Stable
+cabal-version:   >= 1.6
+build-type:      Simple
+homepage:        http://www.yesodweb.com/
+description:     Convenient wrappers for your the configuration and
+                 execution of your yesod application
+
+library
+    if os(windows)
+        cpp-options: -DWINDOWS
+
+    build-depends:   base                  >= 4     && < 5
+                   , yesod-core            >= 0.9.4 && < 0.10
+                   , cmdargs               >= 0.8
+                   , warp                  >= 0.4   && < 0.5
+                   , wai                   >= 0.4   && < 0.5
+                   , wai-extra             >= 0.4.4 && < 0.5
+                   , bytestring            >= 0.9.1.4
+                   , transformers          >= 0.2.2 && < 0.3
+                   , text                  >= 0.9
+                   , directory             >= 1.0
+                   , shakespeare-css       >= 0.10.5 && < 0.11
+                   , shakespeare-js        >= 0.10.4 && < 0.11
+                   , template-haskell
+                   , data-object           >= 0.3      && < 0.4
+                   , data-object-yaml      >= 0.3      && < 0.4
+
+    if !os(windows)
+         build-depends: unix
+
+    exposed-modules: Yesod.Default.Config
+                   , Yesod.Default.Main
+                   , Yesod.Default.Util
+                   , Yesod.Default.Handlers
+
+    ghc-options:     -Wall
+
+source-repository head
+  type:     git
+  location: git://github.com/yesodweb/yesod.git

yesod-examples/src/ajax.lhs

@@ -5,15 +5,14 @@
 > {-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-}
 > import Yesod
 > import Yesod.Static
-> import Data.Monoid (mempty)
-> import Text.Blaze (string)
+> import Data.Text (Text, unpack)
 
 Like the blog example, we'll define some data first.
 
 > data Page = Page
->   { pageName :: String
->   , pageSlug :: String
->   , pageContent :: String
+>   { pageName :: Text
+>   , pageSlug :: Text
+>   , pageContent :: Text
 >   }
 
 > loadPages :: IO [Page]
@@ -36,7 +35,7 @@ Now the routes; we'll have a homepage, a pattern for the pages, and use a static
 
 > mkYesod "Ajax" [parseRoutes|
 > /                  HomeR   GET
-> /page/#String      PageR   GET
+> /page/#Text        PageR   GET
 > /static            StaticR Static ajaxStatic
 > |]
 
@@ -49,7 +48,7 @@ Now the routes; we'll have a homepage, a pattern for the pages, and use a static
 >   defaultLayout widget = do
 >   Ajax pages _ <- getYesod
 >   content <- widgetToPageContent widget
->   hamletToRepHtml [$hamlet|
+>   hamletToRepHtml [hamlet|
 > \<!DOCTYPE html>
 > 
 > <html>
@@ -80,23 +79,23 @@ Now the routes; we'll have a homepage, a pattern for the pages, and use a static
 
 And now the cool part: a handler that returns either HTML or JSON data, depending on the request headers.
 
-> getPageR :: String -> Handler RepHtmlJson
+> getPageR :: Text -> Handler RepHtmlJson
 > getPageR slug = do
 >   Ajax pages _ <- getYesod
 >   case filter (\e -> pageSlug e == slug) pages of
 >       [] -> notFound
 >       page:_ -> defaultLayoutJson (do
->           setTitle $ string $ pageName page
+>           setTitle $ toHtml $ pageName page
 >           addHamlet $ html page
 >           ) (json page)
 >  where
->   html page = [$hamlet|
+>   html page = [hamlet|
 > <h1>#{pageName page}
 > <article>#{pageContent page}
 > |]
 >   json page = jsonMap
->       [ ("name", jsonScalar $ pageName page)
->       , ("content", jsonScalar $ pageContent page)
+>       [ ("name", jsonScalar $ unpack $ pageName page)
+>       , ("content", jsonScalar $ unpack $ pageContent page)
 >       ]
 
 <p>We first try and find the appropriate Page, returning a 404 if it's not there. We then use the applyLayoutJson function, which is really the heart of this example. It allows you an easy way to create responses that will be either HTML or JSON, and which use the default layout in the HTML responses. It takes four arguments: 1) the title of the HTML page, 2) some value, 3) a function from that value to a Hamlet value, and 4) a function from that value to a Json value.</p>
@@ -110,3 +109,8 @@ And now the cool part: a handler that returns either HTML or JSON data, dependin
 >   pages <- loadPages
 >   s <- static "static/yesod/ajax"
 >   warpDebug 3000 $ Ajax pages s
+
+And just to avoid some warnings...
+
+> _ignored :: Widget
+> _ignored = undefined ajaxPages

yesod-examples/src/blog.lhs

@@ -113,3 +113,8 @@ All that's left now is the main function. Yesod is built on top of WAI, so you c
 > main = do
 >   entries <- loadEntries
 >   warpDebug 3000 $ Blog entries
+
+And this is just to avoid some warnings...
+
+> _ignored :: Widget
+> _ignored = undefined blogEntries

yesod-examples/src/chat.hs

@@ -6,11 +6,9 @@
 module Main where
 
 import Yesod
-import Yesod.Helpers.Static
+import Yesod.Static
 
 import Control.Concurrent.STM
-import Control.Concurrent.STM.TChan
-import Control.Concurrent.STM.TVar
 
 import Control.Arrow ((***))
 import Data.Text (Text, unpack)
@@ -18,8 +16,6 @@ import Data.Text (Text, unpack)
 -- speaker and content
 data Message = Message Text Text
 
-type Handler yesod = GHandler yesod yesod
-
 -- all those TChans are dupes, so writing to any one writes to them all, but reading is separate
 data Chat = Chat
   { chatClients    :: TVar [(Int, TChan Message)]
@@ -29,7 +25,7 @@ data Chat = Chat
 
 staticFiles "static"
 
-mkYesod "Chat" [$parseRoutes|
+mkYesod "Chat" [parseRoutes|
 /          HomeR   GET
 /check     CheckR  GET
 /post      PostR   GET
@@ -40,21 +36,20 @@ instance Yesod Chat where
   approot _ = ""
   defaultLayout widget = do
     content <- widgetToPageContent widget
-    hamletToRepHtml [$hamlet|\
-    \<!DOCTYPE html>
+    hamletToRepHtml [hamlet|
+!!!
 
-    <html>
-        <head>
-            <title>#{pageTitle content}
-            <script src="http://ajax.googleapis.com/ajax/libs/jquery/1.4.2/jquery.min.js">
-            <script src="@{StaticR chat_js}">
-            \^{pageHead content}
-        <body>
-            \^{pageBody content}
-    \
+<html>
+    <head>
+        <title>#{pageTitle content}
+        <script src="http://ajax.googleapis.com/ajax/libs/jquery/1.4.2/jquery.min.js">
+        <script src="@{StaticR chat_js}">
+        ^{pageHead content}
+    <body>
+        ^{pageBody content}
 |]
 
-getHomeR :: Handler Chat RepHtml
+getHomeR :: Handler RepHtml
 getHomeR = do
   Chat clients next _ <- getYesod
   client <- liftIO . atomically $ do
@@ -68,8 +63,8 @@ getHomeR = do
     return c
   defaultLayout $ do
     setTitle "Chat Page"
-    addWidget [$hamlet|\
-\<!DOCTYPE html>
+    toWidget [hamlet|
+!!!
 
 <h1>Chat Example
 <form>
@@ -81,7 +76,7 @@ getHomeR = do
 <script>var clientNumber = #{show client}
 |]
 
-getCheckR :: Handler Chat RepJson
+getCheckR :: Handler RepJson
 getCheckR = do
   liftIO $ putStrLn "Check"
   Chat clients _ _ <- getYesod
@@ -99,9 +94,10 @@ getCheckR = do
   let Message s c = first
   jsonToRepJson $ zipJson ["sender", "content"] [s,c]
 
+zipJson :: [Text] -> [Text] -> Json
 zipJson x y = jsonMap $ map (unpack *** jsonScalar . unpack) $ zip x y
 
-getPostR :: Handler Chat RepJson
+getPostR :: Handler RepJson
 getPostR = do
   liftIO $ putStrLn "Post"
   Chat clients _ _ <- getYesod
@@ -122,4 +118,5 @@ main :: IO ()
 main = do
   clients <- newTVarIO []
   next <- newTVarIO 0
-  warpDebug 3000 $ Chat clients next $ static "static"
+  s <- static "static"
+  warpDebug 3000 $ Chat clients next s

yesod-examples/src/file-echo.lhs

@@ -1,10 +1,8 @@
 > {-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-}
 
 > import Yesod
-> import Data.Monoid (mempty)
 > import qualified Data.ByteString.Char8 as S8
 > import qualified Data.Text as T
-> import Text.Blaze (string)
 
 > data Echo = Echo
 
@@ -14,18 +12,26 @@
 
 > instance Yesod Echo where approot _ = ""
 
+> getHomepage :: Handler RepHtml
 > getHomepage = defaultLayout $ do
->   setTitle $ string "Upload a file"
->   addHamlet [$hamlet|
-> %form!method=post!action=.!enctype=multipart/form-data
+>   setTitle "Upload a file"
+>   addHamlet [hamlet|
+> <form method=post action=. enctype=multipart/form-data>
 >   File name:
->   %input!type=file!name=file
->   %input!type=submit
+>   <input type=file name=file
+>   <input type=submit
 > |]
 
+> postHomepage :: Handler [(ContentType, Content)]
 > postHomepage = do
 >   (_, files) <- runRequestBody
 >   fi <- maybe notFound return $ lookup "file" files
 >   return [(S8.pack $ T.unpack $ fileContentType fi, toContent $ fileContent fi)]
 
+> main :: IO ()
 > main = warpDebug 3000 Echo
+
+To avoid warnings
+
+> _ignored :: Widget
+> _ignored = undefined

yesod-examples/src/form.lhs

@@ -2,7 +2,7 @@
 
 
 > {-# LANGUAGE TypeFamilies, QuasiQuotes, OverloadedStrings, MultiParamTypeClasses, TemplateHaskell #-}
-> import Yesod
+> import Yesod hiding (Form)
 > import Control.Applicative
 > import Data.Text (Text)
 
@@ -10,6 +10,8 @@
 > mkYesod "FormExample" [parseRoutes|
 > / RootR GET
 > |]
+> type Form a = Html -> MForm FormExample FormExample (FormResult a, Widget)
+> type Formlet a = Maybe a -> Form a
 > instance Yesod FormExample where approot _ = ""
 > instance RenderMessage FormExample FormMessage where
 >    renderMessage _ _ = defaultFormMessage
@@ -18,6 +20,7 @@ Next, we'll declare a Person datatype with a name and age. After that, we'll cre
 
 > data Person = Person { name :: Text, age :: Int }
 >     deriving Show
+> personFormlet :: Formlet Person
 > personFormlet p = renderTable $ Person
 >     <$> areq textField "Name" (fmap name p)
 >     <*> areq intField "Age" (fmap age p)
@@ -38,14 +41,15 @@ We use an applicative approach and stay mostly declarative. The "fmap name p" bi
 
 <p>extractBody returns the HTML of a widget and "passes" all of the other declarations (the CSS, Javascript, etc) up to the parent widget. The rest of this is just standard Hamlet code and our main function.</p>
 
->         addHamlet [$hamlet|
+>         addHamlet [hamlet|
 > <p>Last result: #{show res}
 > <form enctype="#{enctype}">
 >     <table>
->         \^{form}
+>         ^{form}
 >         <tr>
 >             <td colspan="2">
 >                 <input type="submit">
 > |]
 > 
+> main :: IO ()
 > main = warpDebug 3000 FormExample

yesod-examples/src/generalized-hamlet.lhs

@@ -1,52 +0,0 @@
-This example shows how generalized hamlet templates allow the creation of
-different types of values. The key component here is the HamletValue typeclass.
-Yesod has instances for:
-
-* Html
-
-* HtmlUrl (= (url -> [(String, String)] -> String) -> Html)
-
-* GWidget s m ()
-
-This example uses all three. You are of course free in your own code to make
-your own instances.
-
-> {-# LANGUAGE QuasiQuotes, TypeFamilies, MultiParamTypeClasses, OverloadedStrings, TemplateHaskell #-}
-> import Yesod
-> import Text.Hamlet (shamlet)
-> data NewHamlet = NewHamlet
-> mkYesod "NewHamlet" [$parseRoutes|/ RootR GET|]
-> instance Yesod NewHamlet where approot _ = ""
-> 
-> myHtml :: Html
-> myHtml = [shamlet|<p>Just don't use any URLs in here!|]
->
-> myInnerWidget :: Widget
-> myInnerWidget = do
->     addHamlet [$hamlet|
->   <div #inner>Inner widget
->   #{myHtml}
-> |]
->     addCassius [$cassius|
->#inner
->     color: red|]
-> 
-> myPlainTemplate :: HtmlUrl NewHamletRoute
-> myPlainTemplate = [hamlet|
-> <p
->     <a href=@{RootR}>Link to home
-> |]
-> 
-> myWidget :: Widget
-> myWidget = [whamlet|
->     <h1>Embed another widget
->     \^{myInnerWidget}
->     <h1>Embed a Hamlet
->     \^{addHamlet myPlainTemplate}
-> |]
-> 
-> getRootR :: GHandler NewHamlet NewHamlet RepHtml
-> getRootR = defaultLayout myWidget
-> 
-> main :: IO ()
-> main = warpDebug 3000 NewHamlet

yesod-examples/src/i18n.lhs

@@ -3,14 +3,14 @@
 > {-# LANGUAGE TypeFamilies #-}
 > {-# LANGUAGE MultiParamTypeClasses #-}
 > {-# LANGUAGE OverloadedStrings #-}
+> {-# LANGUAGE CPP #-}
 
 > import Yesod
-> import Data.Monoid (mempty)
 > import Data.Text (Text)
 
 > data I18N = I18N
 
-> mkYesod "I18N" [$parseRoutes|
+> mkYesod "I18N" [parseRoutes|
 > /            HomepageR GET
 > /set/#Text SetLangR  GET
 > |]
@@ -24,12 +24,12 @@
 >     let hello = chooseHello ls
 >     let choices =
 >             [ ("en", "English") :: (Text, Text)
->             , ("es", "Spanish")
->             , ("he", "Hebrew")
+>             , ("es", "Español")
+>             , ("he", "עִבְרִית")
 >             ]
 >     defaultLayout $ do
 >       setTitle "I18N Homepage"
->       addHamlet [$hamlet|
+>       addHamlet [hamlet|
 > <h1>#{hello}
 > <p>In other languages:
 > <ul>
@@ -40,8 +40,8 @@
 
 > chooseHello :: [Text] -> Text
 > chooseHello [] = "Hello"
-> chooseHello ("he":_) = "Shalom"
-> chooseHello ("es":_) = "Hola"
+> chooseHello ("he":_) = "שלום"
+> chooseHello ("es":_) = "¡Hola!"
 > chooseHello (_:rest) = chooseHello rest
 
 > getSetLangR :: Text -> Handler ()
@@ -51,3 +51,6 @@
 
 > main :: IO ()
 > main = warpDebug 3000 I18N
+
+> _ignored :: Widget
+> _ignored = undefined

yesod-examples/src/pretty-yaml.lhs

@@ -10,14 +10,14 @@
 
 > data PY = PY
 
-> mkYesod "PY" [$parseRoutes|
+> mkYesod "PY" [parseRoutes|
 > / Homepage GET POST
 > |]
 
 > instance Yesod PY where approot _ = ""
 
 > template :: Maybe (HtmlUrl url) -> HtmlUrl url
-> template myaml = [$hamlet|
+> template myaml = [hamlet|
 > !!!
 > 
 > <html>
@@ -46,13 +46,13 @@
 >     hamletToRepHtml $ template $ Just $ objToHamlet so
 
 > objToHamlet :: StringObject -> HtmlUrl url
-> objToHamlet (Scalar s) = [$hamlet|#{s}|]
-> objToHamlet (Sequence list) = [$hamlet|
+> objToHamlet (Scalar s) = [hamlet|#{s}|]
+> objToHamlet (Sequence list) = [hamlet|
 > <ul
 >     $forall o <- list
 >         <li>^{objToHamlet o}
 > |]
-> objToHamlet (Mapping pairs) = [$hamlet|
+> objToHamlet (Mapping pairs) = [hamlet|
 > <dl
 >     $forall pair <- pairs
 >         <dt>#{fst pair}
@@ -61,3 +61,6 @@
 
 > main :: IO ()
 > main = warpDebug 3000 PY
+
+> _ignored :: Widget
+> _ignored = undefined

yesod-examples/src/session.lhs

@@ -17,7 +17,7 @@
 > getRoot :: Handler RepHtml
 > getRoot = do
 >     sess <- getSession
->     hamletToRepHtml [$hamlet|
+>     hamletToRepHtml [hamlet|
 > <form method=post
 >     <input type=text name=key
 >     <input type=text name=val
@@ -32,4 +32,8 @@
 >       liftIO $ print (key, val)
 >       redirect RedirectTemporary Root
 >
+> main :: IO ()
 > main = warpDebug 3000 Session
+
+> _ignored :: Widget
+> _ignored = undefined

yesod-examples/synopsis/hamlet.lhs

@@ -2,8 +2,10 @@
 {-# LANGUAGE QuasiQuotes, OverloadedStrings #-}
 
 import Text.Hamlet
-import qualified Data.ByteString.Lazy as L
 import Data.Text (Text, cons)
+import qualified Data.Text.Lazy.IO as L
+import Text.Blaze.Renderer.Text (renderHtml)
+
 
 data Person = Person
     { name :: String
@@ -16,23 +18,23 @@ data PersonUrls = Homepage | PersonPage Text
 
 renderUrls :: PersonUrls -> [(Text, Text)] -> Text
 renderUrls Homepage _ = "/"
-renderUrls (PersonPage name) _ = '/' `cons` name
+renderUrls (PersonPage name') _ = '/' `cons` name'
 
-footer :: Hamlet url
-footer = [$hamlet|\
+footer :: HtmlUrl url
+footer = [hamlet|
 <div id="footer">Thank you, come again
 |]
 
-template :: Person -> Hamlet PersonUrls
-template person = [$hamlet|
+template :: Person -> HtmlUrl PersonUrls
+template person = [hamlet|
 !!!
 
 <html>
     <head>
         <title>Hamlet Demo
     <body>
-        <h1>Information on #{string (name person)}
-        <p>#{string (name person)} is #{string (age person)} years old.
+        <h1>Information on #{name person}
+        <p>#{name person} is #{age person} years old.
         <h2>
             $if isMarried person
                 \Married
@@ -40,7 +42,7 @@ template person = [$hamlet|
                 \Not married
         <ul>
             $forall child <- children person
-                <li>#{string child}
+                <li>#{child}
         <p>
             <a href="@{page person}">See the page.
         \^{footer}
@@ -55,7 +57,7 @@ main = do
             , isMarried = True
             , children = ["Adam", "Ben", "Chris"]
             }
-    L.putStrLn $ renderHamlet renderUrls $ template person
+    L.putStrLn $ renderHtml $ (template person) renderUrls 
 \end{code}
 
 Outputs (new lines added for readability):

yesod-examples/synopsis/persistent.lhs

@@ -37,3 +37,6 @@ Just (Person {personName = "Michael", personAge = 25})
 Just (Person {personName = "Michael", personAge = 26})
 [(PersonId 1,Person {personName = "Michael", personAge = 26})]
 []</pre></code>
+
+> _ignored :: PersonId
+> _ignored = undefined personName personAge

yesod-examples/yesod-examples.cabal

@@ -1,5 +1,5 @@
 Name:                yesod-examples
-Version:             0.8.0.3
+Version:             0.9.0
 Synopsis:            Example programs using the Yesod Web Framework.
 Description:         These are the same examples and tutorials found on the documentation site.
 Homepage:            http://www.yesodweb.com/
@@ -15,6 +15,8 @@ extra-source-files:  static/yesod/ajax/script.js,
                      static/yesod/ajax/style.css,
                      static/chat.js
 
+flag ghc7
+
 Executable yesod-blog
   Main-is:             src/blog.lhs
   Build-depends:       base >= 4 && < 5,
@@ -23,23 +25,25 @@ Executable yesod-blog
 Executable yesod-ajax
   Main-is:             src/ajax.lhs
   Build-depends:       yesod-static,
-                       blaze-html,
+                       blaze-html  >= 0.4.1.3  && < 0.5,
                        yesod >= 0.9
 
 Executable yesod-file-echo
   Main-is:             src/file-echo.lhs
-  Build-depends:       text,
+  Build-depends:       text              >= 0.9   && < 0.12,
                        yesod >= 0.9
 
 Executable yesod-pretty-yaml
   Main-is:             src/pretty-yaml.lhs
   Build-depends:       data-object-yaml >= 0.3.0 && < 0.4,
                        data-object >= 0.3.1 && < 0.4,
-                       bytestring >= 0.9 && < 0.10,
+                       bytestring                >= 0.9.1.4  && < 0.10,
                        yesod >= 0.9
 
 Executable yesod-i18n
   Main-is:             src/i18n.lhs
+  if flag(ghc7)
+      cpp-options:     -DGHC7
 
 Executable yesod-session
   Main-is:             src/session.lhs
@@ -48,21 +52,19 @@ Executable yesod-session
 --  Main-is:             src/widgets.lhs
 --  Build-depends:       yesod-form
 
-Executable yesod-generalized-hamlet
-  Main-is:             src/generalized-hamlet.lhs
-
 Executable yesod-form
   Main-is:             src/form.lhs
 
 Executable yesod-persistent-synopsis
   Main-is:             synopsis/persistent.lhs
-  Build-depends:       transformers >= 0.2.1 && < 0.3,
-                       persistent-sqlite >= 0.6,
-                       persistent-template
+  Build-depends:       transformers >= 0.2.2 && < 0.3,
+                       persistent-sqlite   >= 0.6 && < 0.7,
+                       persistent-template >= 0.6 && < 0.7
+  extra-libraries:     sqlite3
 
 Executable yesod-hamlet-synopsis
   Main-is:             synopsis/hamlet.lhs
-  Build-depends:       hamlet
+  Build-depends:       hamlet, yesod-core
 
 Executable yesod-chat
   Main-is:             src/chat.hs

yesod-form/Yesod/Form/Fields.hs

@@ -35,6 +35,8 @@ module Yesod.Form.Fields
     , selectField'
     , radioField'
     , Option (..)
+    , OptionList (..)
+    , mkOptionList
     , optionsPersist
     , optionsPairs
     , optionsEnum
@@ -66,7 +68,6 @@ import qualified Data.ByteString as S
 import qualified Data.ByteString.Lazy as L
 import Data.Text (Text, unpack, pack)
 import qualified Data.Text.Read
-import Control.Monad.IO.Class (liftIO)
 import Control.Monad.Trans.Class (lift)
 
 import Control.Applicative ((<$>))
@@ -76,6 +77,7 @@ import Yesod.Request (FileInfo)
 
 import Yesod.Core (toSinglePiece, GGHandler, SinglePiece)
 import Yesod.Persist (selectList, runDB, Filter, SelectOpt, YesodPersistBackend, Key, YesodPersist, PersistEntity, PersistBackend)
+import Control.Arrow ((&&&))
 
 #if __GLASGOW_HASKELL__ >= 700
 #define WHAMLET whamlet
@@ -303,7 +305,7 @@ urlField = Field
 selectField :: (Eq a, RenderMessage master FormMessage) => [(Text, a)] -> Field sub master a
 selectField = selectField' . optionsPairs
 
-selectField' :: (Eq a, RenderMessage master FormMessage) => GGHandler sub master IO [Option a] -> Field sub master a
+selectField' :: (Eq a, RenderMessage master FormMessage) => GGHandler sub master IO (OptionList a) -> Field sub master a
 selectField' = selectFieldHelper
     (\theId name inside -> [WHAMLET|<select ##{theId} name=#{name}>^{inside}|]) -- outside
     (\_theId _name isSel -> [WHAMLET|<option value=none :isSel:selected>_{MsgSelectNone}|]) -- onOpt
@@ -317,7 +319,7 @@ multiSelectField = multiSelectFieldHelper
 radioField :: (Eq a, RenderMessage master FormMessage) => [(Text, a)] -> Field sub master a
 radioField = radioField' . optionsPairs
 
-radioField' :: (Eq a, RenderMessage master FormMessage) => GGHandler sub master IO [Option a] -> Field sub master a
+radioField' :: (Eq a, RenderMessage master FormMessage) => GGHandler sub master IO (OptionList a) -> Field sub master a
 radioField' = selectFieldHelper
     (\theId _name inside -> [WHAMLET|<div ##{theId}>^{inside}|])
     (\theId name isSel -> [WHAMLET|
@@ -380,27 +382,38 @@ multiSelectFieldHelper outside inside opts = Field
     selectParser xs | not $ null (["", "none"] `intersect` xs) = Right Nothing
                     | otherwise = (Right . Just . map snd . catMaybes . map (\y -> lookup y pairs) . nub . map fst . rights . map Data.Text.Read.decimal) xs
 
+data OptionList a = OptionList
+    { olOptions :: [Option a]
+    , olReadExternal :: Text -> Maybe a
+    }
+
+mkOptionList :: [Option a] -> OptionList a
+mkOptionList os = OptionList
+    { olOptions = os
+    , olReadExternal = flip Map.lookup $ Map.fromList $ map (optionExternalValue &&& optionInternalValue) os
+    }
+
 data Option a = Option
     { optionDisplay :: Text
     , optionInternalValue :: a
     , optionExternalValue :: Text
     }
 
-optionsPairs :: [(Text, a)] -> GGHandler sub master IO [Option a]
-optionsPairs = return . zipWith (\external (display, internal) -> Option
+optionsPairs :: [(Text, a)] -> GGHandler sub master IO (OptionList a)
+optionsPairs = return . mkOptionList . zipWith (\external (display, internal) -> Option
     { optionDisplay = display
     , optionInternalValue = internal
     , optionExternalValue = pack $ show external
     }) [1 :: Int ..]
 
-optionsEnum :: (Show a, Enum a, Bounded a) => GGHandler sub master IO [Option a]
+optionsEnum :: (Show a, Enum a, Bounded a) => GGHandler sub master IO (OptionList a)
 optionsEnum = optionsPairs $ map (\x -> (pack $ show x, x)) [minBound..maxBound]
 
 optionsPersist :: ( YesodPersist master, PersistEntity a, PersistBackend (YesodPersistBackend master) (GGHandler sub master IO)
                   , SinglePiece (Key (YesodPersistBackend master) a)
                   )
-               => [Filter a] -> [SelectOpt a] -> (a -> Text) -> GGHandler sub master IO [Option (Key (YesodPersistBackend master) a, a)]
-optionsPersist filts ords toDisplay = do
+               => [Filter a] -> [SelectOpt a] -> (a -> Text) -> GGHandler sub master IO (OptionList (Key (YesodPersistBackend master) a, a))
+optionsPersist filts ords toDisplay = fmap mkOptionList $ do
     pairs <- runDB $ selectList filts ords
     return $ map (\(key, value) -> Option
         { optionDisplay = toDisplay value
@@ -413,13 +426,13 @@ selectFieldHelper
         => (Text -> Text -> GWidget sub master () -> GWidget sub master ())
         -> (Text -> Text -> Bool -> GWidget sub master ())
         -> (Text -> Text -> Text -> Bool -> Text -> GWidget sub master ())
-        -> GGHandler sub master IO [Option a] -> Field sub master a
+        -> GGHandler sub master IO (OptionList a) -> Field sub master a
 selectFieldHelper outside onOpt inside opts' = Field
     { fieldParse = \x -> do
         opts <- opts'
         return $ selectParser opts x
     , fieldView = \theId name val isReq -> do
-        opts <- lift $ liftIOHandler opts'
+        opts <- fmap olOptions $ lift $ liftIOHandler opts'
         outside theId name $ do
             unless isReq $ onOpt theId name $ not $ render opts val `elem` map optionExternalValue opts
             flip mapM_ opts $ \opt -> inside
@@ -436,9 +449,9 @@ selectFieldHelper outside onOpt inside opts' = Field
     selectParser opts (s:_) = case s of
             "" -> Right Nothing
             "none" -> Right Nothing
-            x -> case listToMaybe $ filter ((== x) . optionExternalValue) opts of
+            x -> case olReadExternal opts x of
                     Nothing -> Left $ SomeMessage $ MsgInvalidEntry x
-                    Just y -> Right $ Just $ optionInternalValue y
+                    Just y -> Right $ Just y
 
 fileAFormReq :: (RenderMessage master msg, RenderMessage master FormMessage) => FieldSettings msg -> AForm sub master FileInfo
 fileAFormReq fs = AForm $ \(master, langs) menvs ints -> do
@@ -472,7 +485,6 @@ fileAFormReq fs = AForm $ \(master, langs) menvs ints -> do
 
 fileAFormOpt :: (RenderMessage master msg, RenderMessage master FormMessage) => FieldSettings msg -> AForm sub master (Maybe FileInfo)
 fileAFormOpt fs = AForm $ \(master, langs) menvs ints -> do
-    liftIO $ print menvs
     let (name, ints') =
             case fsName fs of
                 Just x -> (x, ints)

yesod-form/Yesod/Form/Functions.hs

@@ -4,7 +4,7 @@
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE FlexibleContexts #-}
 module Yesod.Form.Functions
-    ( -- * Running in Form monad
+    ( -- * Running in MForm monad
       newFormIdent
     , askParams
     , askFiles
@@ -31,6 +31,7 @@ module Yesod.Form.Functions
     , check
     , checkBool
     , checkM
+    , customErrorMessage
     ) where
 
 import Yesod.Form.Types
@@ -61,7 +62,7 @@ import qualified Data.ByteString.Lazy as L
 #endif
 
 -- | Get a unique identifier.
-newFormIdent :: Form sub master Text
+newFormIdent :: MForm sub master Text
 newFormIdent = do
     i <- get
     let i' = incrInts i
@@ -71,12 +72,12 @@ newFormIdent = do
     incrInts (IntSingle i) = IntSingle $ i + 1
     incrInts (IntCons i is) = (i + 1) `IntCons` is
 
-formToAForm :: Form sub master (FormResult a, FieldView sub master) -> AForm sub master a
+formToAForm :: MForm sub master (FormResult a, FieldView sub master) -> AForm sub master a
 formToAForm form = AForm $ \(master, langs) env ints -> do
     ((a, xml), ints', enc) <- runRWST form (env, master, langs) ints
     return (a, (:) xml, ints', enc)
 
-aFormToForm :: AForm sub master a -> Form sub master (FormResult a, [FieldView sub master] -> [FieldView sub master])
+aFormToForm :: AForm sub master a -> MForm sub master (FormResult a, [FieldView sub master] -> [FieldView sub master])
 aFormToForm (AForm aform) = do
     ints <- get
     (env, master, langs) <- ask
@@ -85,24 +86,24 @@ aFormToForm (AForm aform) = do
     tell enc
     return (a, xml)
 
-askParams :: Form sub master (Maybe Env)
+askParams :: MForm sub master (Maybe Env)
 askParams = do
     (x, _, _) <- ask
     return $ liftM fst x
 
-askFiles :: Form sub master (Maybe FileEnv)
+askFiles :: MForm sub master (Maybe FileEnv)
 askFiles = do
     (x, _, _) <- ask
     return $ liftM snd x
 
 mreq :: (RenderMessage master msg, RenderMessage master FormMessage)
      => Field sub master a -> FieldSettings msg -> Maybe a
-     -> Form sub master (FormResult a, FieldView sub master)
+     -> MForm sub master (FormResult a, FieldView sub master)
 mreq field fs mdef = mhelper field fs mdef (\m l -> FormFailure [renderMessage m l MsgValueRequired]) FormSuccess True
 
 mopt :: RenderMessage master msg
      => Field sub master a -> FieldSettings msg -> Maybe (Maybe a)
-     -> Form sub master (FormResult (Maybe a), FieldView sub master)
+     -> MForm sub master (FormResult (Maybe a), FieldView sub master)
 mopt field fs mdef = mhelper field fs (join mdef) (const $ const $ FormSuccess Nothing) (FormSuccess . Just) False
 
 mhelper :: RenderMessage master msg
@@ -112,7 +113,7 @@ mhelper :: RenderMessage master msg
         -> (master -> [Text] -> FormResult b) -- ^ on missing
         -> (a -> FormResult b) -- ^ on success
         -> Bool -- ^ is it required?
-        -> Form sub master (FormResult b, FieldView sub master)
+        -> MForm sub master (FormResult b, FieldView sub master)
 
 mhelper Field {..} FieldSettings {..} mdef onMissing onFound isReq = do
     mp <- askParams
@@ -156,7 +157,7 @@ aopt :: RenderMessage master msg
      -> AForm sub master (Maybe a)
 aopt a b = formToAForm . mopt a b
 
-runFormGeneric :: MonadIO m => Form sub master a -> master -> [Text] -> Maybe (Env, FileEnv) -> GGHandler sub master m (a, Enctype)
+runFormGeneric :: MonadIO m => MForm sub master a -> master -> [Text] -> Maybe (Env, FileEnv) -> GGHandler sub master m (a, Enctype)
 runFormGeneric form master langs env = liftIOHandler $ evalRWST form (env, master, langs) (IntSingle 1)
 
 -- | This function is used to both initially render a form and to later extract
@@ -169,14 +170,14 @@ runFormGeneric form master langs env = liftIOHandler $ evalRWST form (env, maste
 -- the form submit to a POST page. In such a case, both the GET and POST
 -- handlers should use 'runFormPost'.
 runFormPost :: RenderMessage master FormMessage
-            => (Html -> Form sub master (FormResult a, xml))
+            => (Html -> MForm sub master (FormResult a, xml))
             -> GHandler sub master ((FormResult a, xml), Enctype)
 runFormPost form = do
     env <- postEnv
     postHelper form env
 
 postHelper  :: RenderMessage master FormMessage
-            => (Html -> Form sub master (FormResult a, xml))
+            => (Html -> MForm sub master (FormResult a, xml))
             -> Maybe (Env, FileEnv)
             -> GHandler sub master ((FormResult a, xml), Enctype)
 postHelper form env = do
@@ -203,7 +204,7 @@ postHelper form env = do
 -- general usage, you can stick with @runFormPost@.
 generateFormPost
     :: RenderMessage master FormMessage
-    => (Html -> Form sub master (FormResult a, xml))
+    => (Html -> MForm sub master (FormResult a, xml))
     -> GHandler sub master ((FormResult a, xml), Enctype)
 generateFormPost form = postHelper form Nothing
 
@@ -219,14 +220,14 @@ postEnv = do
   where
     notEmpty = not . L.null . fileContent
 
-runFormPostNoNonce :: (Html -> Form sub master (FormResult a, xml)) -> GHandler sub master ((FormResult a, xml), Enctype)
+runFormPostNoNonce :: (Html -> MForm sub master (FormResult a, xml)) -> GHandler sub master ((FormResult a, xml), Enctype)
 runFormPostNoNonce form = do
     langs <- languages
     m <- getYesod
     env <- postEnv
     runFormGeneric (form mempty) m langs env
 
-runFormGet :: (Html -> Form sub master a) -> GHandler sub master (a, Enctype)
+runFormGet :: (Html -> MForm sub master a) -> GHandler sub master (a, Enctype)
 runFormGet form = do
     gets <- liftM reqGetParams getRequest
     let env =
@@ -235,13 +236,13 @@ runFormGet form = do
                 Just _ -> Just (Map.unionsWith (++) $ map (\(x, y) -> Map.singleton x [y]) gets, Map.empty)
     getHelper form env
 
-generateFormGet :: (Html -> Form sub master a) -> GHandler sub master (a, Enctype)
+generateFormGet :: (Html -> MForm sub master a) -> GHandler sub master (a, Enctype)
 generateFormGet form = getHelper form Nothing
 
 getKey :: Text
 getKey = "_hasdata"
 
-getHelper :: (Html -> Form sub master a) -> Maybe (Env, FileEnv) -> GHandler sub master (a, Enctype)
+getHelper :: (Html -> MForm sub master a) -> Maybe (Env, FileEnv) -> GHandler sub master (a, Enctype)
 getHelper form env = do
     let fragment = [HTML|<input type=hidden name=#{getKey}>|]
     langs <- languages
@@ -251,7 +252,7 @@ getHelper form env = do
 type FormRender sub master a =
        AForm sub master a
     -> Html
-    -> Form sub master (FormResult a, GWidget sub master ())
+    -> MForm sub master (FormResult a, GWidget sub master ())
 
 renderTable, renderDivs :: FormRender sub master a
 renderTable aform fragment = do
@@ -309,3 +310,8 @@ checkM f field = field
             Right Nothing -> return $ Right Nothing
             Right (Just a) -> fmap (either (Left . SomeMessage) (Right . Just)) $ f a
     }
+
+-- | Allows you to overwrite the error message on parse error.
+customErrorMessage :: SomeMessage master -> Field sub master a -> Field sub master a
+customErrorMessage msg field = field { fieldParse = \ts -> fmap (either
+(const $ Left msg) Right) $ fieldParse field ts }

yesod-form/Yesod/Form/MassInput.hs

@@ -35,7 +35,7 @@ import Data.Maybe (listToMaybe)
 #define WHAMLET $whamlet
 #endif
 
-down :: Int -> Form sub master ()
+down :: Int -> MForm sub master ()
 down 0 = return ()
 down i | i < 0 = error "called down with a negative number"
 down i = do
@@ -43,7 +43,7 @@ down i = do
     put $ IntCons 0 is
     down $ i - 1
 
-up :: Int -> Form sub master ()
+up :: Int -> MForm sub master ()
 up 0 = return ()
 up i | i < 0 = error "called down with a negative number"
 up i = do
@@ -98,7 +98,7 @@ inputList label fixXml single mdef = formToAForm $ do
 
 withDelete :: (xml ~ GWidget sub master (), RenderMessage master FormMessage)
            => AForm sub master a
-           -> Form sub master (Either xml (FormResult a, [FieldView sub master]))
+           -> MForm sub master (Either xml (FormResult a, [FieldView sub master]))
 withDelete af = do
     down 1
     deleteName <- newFormIdent

yesod-form/Yesod/Form/Types.hs

@@ -11,6 +11,7 @@ module Yesod.Form.Types
     , Ints (..)
       -- * Form
     , Form
+    , MForm
     , AForm (..)
       -- * Build forms
     , Field (..)
@@ -75,6 +76,8 @@ type FileEnv = Map.Map Text FileInfo
 
 type Lang = Text
 type Form sub master a = RWST (Maybe (Env, FileEnv), master, [Lang]) Enctype Ints (GGHandler sub master IO) a
+{-# DEPRECATED Form "Use MForm instead" #-}
+type MForm sub master a = RWST (Maybe (Env, FileEnv), master, [Lang]) Enctype Ints (GGHandler sub master IO) a
 
 newtype AForm sub master a = AForm
     { unAForm :: (master, [Text]) -> Maybe (Env, FileEnv) -> Ints -> GGHandler sub master IO (FormResult a, [FieldView sub master] -> [FieldView sub master], Ints, Enctype)

yesod-form/yesod-form.cabal

@@ -1,5 +1,5 @@
 name:            yesod-form
-version:         0.3.3
+version:         0.3.4
 license:         BSD3
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>
@@ -13,27 +13,27 @@ homepage:        http://www.yesodweb.com/
 description:     Form handling support for Yesod Web Framework
 
 library
-    build-depends:   base                      >= 4        && < 5
-                   , yesod-core                >= 0.9      && < 0.10
-                   , yesod-persistent          >= 0.2      && < 0.3
-                   , time                      >= 1.1.4    && < 1.3
-                   , hamlet                    >= 0.10     && < 0.11
-                   , shakespeare-css           >= 0.10     && < 0.11
-                   , shakespeare-js            >= 0.10     && < 0.11
-                   , persistent                >= 0.6      && < 0.7
-                   , yesod-persistent          >= 0.2      && < 0.3
+    build-depends:   base                  >= 4        && < 5
+                   , yesod-core            >= 0.9      && < 0.10
+                   , yesod-persistent      >= 0.2      && < 0.3
+                   , time                  >= 1.1.4
+                   , hamlet                >= 0.10     && < 0.11
+                   , shakespeare-css       >= 0.10     && < 0.11
+                   , shakespeare-js        >= 0.10     && < 0.11
+                   , persistent            >= 0.6      && < 0.7
+                   , yesod-persistent      >= 0.2      && < 0.3
                    , template-haskell
-                   , transformers              >= 0.2.2    && < 0.3
-                   , data-default              >= 0.3      && < 0.4
-                   , xss-sanitize              >= 0.3.0.1  && < 0.4
-                   , blaze-builder             >= 0.2.1    && < 0.4
-                   , network                   >= 2.2      && < 2.4
-                   , email-validate            >= 0.2.6    && < 0.3
-                   , blaze-html                >= 0.4      && < 0.5
-                   , bytestring                >= 0.9      && < 0.10
-                   , text                      >= 0.7      && < 1.0
-                   , wai                       >= 0.4      && < 0.5
-                   , containers                >= 0.2      && < 0.5
+                   , transformers          >= 0.2.2    && < 0.3
+                   , data-default          >= 0.3      && < 0.4
+                   , xss-sanitize          >= 0.3.0.1  && < 0.4
+                   , blaze-builder      >= 0.2.1.4      && < 0.4
+                   , network               >= 2.2      && < 2.4
+                   , email-validate        >= 0.2.6    && < 0.3
+                   , blaze-html            >= 0.4.1.3  && < 0.5
+                   , bytestring            >= 0.9.1.4  && < 0.10
+                   , text                  >= 0.9      && < 0.12
+                   , wai                   >= 0.4      && < 0.5
+                   , containers            >= 0.2      && < 0.5
     exposed-modules: Yesod.Form
                      Yesod.Form.Class
                      Yesod.Form.Types

yesod-json/Yesod/Json.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE CPP #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 module Yesod.Json
     ( -- * Convert from a JSON value
@@ -23,7 +24,11 @@ import qualified Data.Aeson.Encode as JE
 import Data.Aeson.Encode (fromValue)
 import Data.Text (pack)
 import Control.Arrow (first)
+#if MIN_VERSION_aeson(0, 4, 0)
+import Data.HashMap.Strict (fromList)
+#else
 import Data.Map (fromList)
+#endif
 import qualified Data.Vector as V
 import Text.Julius (ToJavascript (..))
 import Data.Text.Lazy.Builder (fromLazyText)

yesod-json/yesod-json.cabal

@@ -1,5 +1,5 @@
 name:            yesod-json
-version:         0.2.1
+version:         0.2.2.1
 license:         BSD3
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>
@@ -13,13 +13,14 @@ homepage:        http://www.yesodweb.com/
 description:     Generate content for Yesod using the aeson package.
 
 library
-    build-depends:   base                      >= 4        && < 5
-                   , yesod-core                >= 0.9      && < 0.10
-                   , aeson-native              >= 0.3.2.11 && < 0.4
-                   , text                      >= 0.8      && < 0.12
-                   , shakespeare-js            >= 0.10     && < 0.11
-                   , vector
-                   , containers
+    build-depends:   base                 >= 4        && < 5
+                   , yesod-core           >= 0.9      && < 0.10
+                   , aeson                >= 0.3
+                   , text                 >= 0.8      && < 0.12
+                   , shakespeare-js       >= 0.10     && < 0.11
+                   , vector               >= 0.9
+                   , containers           >= 0.2      && < 0.5
+                   , unordered-containers
     exposed-modules: Yesod.Json
     ghc-options:     -Wall
 

yesod-mega.cabal

@@ -0,0 +1,234 @@
+name:            yesod-mega
+version:         0.9.3
+license:         BSD3
+license-file:    LICENSE
+author:          Michael Snoyman <michael@snoyman.com>
+maintainer:      Michael Snoyman <michael@snoyman.com>
+synopsis:        Creation of type-safe, RESTful web applications.
+description:
+    Builds all yesod* repo code at once
+
+category:        Web, Yesod
+stability:       Stable
+cabal-version:   >= 1.8
+build-type:      Simple
+homepage:        http://www.yesodweb.com/
+
+flag ghc7
+
+flag threaded
+    default: True
+    description: Build with support for multithreaded execution
+
+flag test
+  description: Build for use with running tests
+  default: False
+
+library
+    hs-source-dirs: yesod, yesod-auth, yesod-core, yesod-default, yesod-examples, yesod-form, yesod-json, yesod-newsfeed, yesod-persistent, yesod-sitemap, yesod-static
+
+    exposed-modules:
+                     -- yesod
+                     Yesod
+                     -- yesod-static
+                     Yesod.Static
+                     -- yesod-persistent
+                     Yesod.Persist
+                     -- yesod-json
+                     Yesod.Json
+                     -- yesod-sitemap
+                     Yesod.Sitemap
+
+                     -- yesod-core
+                     Yesod.Content
+                     Yesod.Core
+                     Yesod.Dispatch
+                     Yesod.Handler
+                     Yesod.Logger
+                     Yesod.Request
+                     Yesod.Widget
+                     Yesod.Message
+                     Yesod.Config
+                     Yesod.Internal.TestApi
+
+                     -- yesod-form
+                     Yesod.Form
+                     Yesod.Form.Class
+                     Yesod.Form.Types
+                     Yesod.Form.Functions
+                     Yesod.Form.Input
+                     Yesod.Form.Fields
+                     Yesod.Form.Jquery
+                     Yesod.Form.Nic
+                     Yesod.Form.MassInput
+                     Yesod.Form.I18n.English
+                     Yesod.Form.I18n.Swedish
+
+                     -- yesod-auth
+                     Yesod.Auth
+                     Yesod.Auth.BrowserId
+                     Yesod.Auth.Dummy
+                     Yesod.Auth.Email
+                     Yesod.Auth.Facebook
+                     Yesod.Auth.OpenId
+                     Yesod.Auth.OAuth
+                     Yesod.Auth.Rpxnow
+                     Yesod.Auth.HashDB
+                     Yesod.Auth.Message
+                     Yesod.Auth.Kerberos
+
+                     -- yesod-default
+                     Yesod.Default.Config
+                     Yesod.Default.Main
+                     Yesod.Default.Util
+                     Yesod.Default.Handlers
+
+                     -- yesod-newsfeed
+                     Yesod.AtomFeed
+                     Yesod.RssFeed
+                     Yesod.Feed
+
+    other-modules:
+                     -- yesod-newsfeed
+                     Yesod.FeedTypes
+                     -- yesod-core
+                     Yesod.Internal
+                     Yesod.Internal.Core
+                     Yesod.Internal.Session
+                     Yesod.Internal.Request
+                     Yesod.Internal.Dispatch
+                     Yesod.Internal.RouteParsing
+
+                     -- yesod
+                     Scaffolding.CodeGen
+                     Scaffolding.Scaffolder
+                     Devel
+                     Build
+
+
+    cpp-options:     -DMEGA
+
+    if flag(ghc7)
+        build-depends:   base                  >= 4.3      && < 5
+        cpp-options:     -DGHC7
+    else
+        build-depends:   base                  >= 4        && < 4.3
+
+    include-dirs: yesod-auth/include
+
+    if !os(windows)
+         build-depends: unix
+
+    if flag(test)
+      cpp-options:   -DTEST
+
+    build-depends:
+                   -- yesod
+                     Cabal              >= 1.8          && < 1.13
+                   , shakespeare-text   >= 0.10     && < 0.11
+                   , filepath           >= 1.1          && < 1.3
+                   , process
+                   , attoparsec         >= 0.10
+                   -- yesod-sitemap
+                   -- empty
+
+                   -- yesod-newsfeed
+                   , wai-extra         >= 0.4.4 && < 0.5
+
+                   -- yesod-default
+                   , cmdargs           >= 0.8   && < 0.9
+
+                   -- yesod-auth
+                   , authenticate          >= 0.10.3    && < 0.11
+                   , control-monad-attempt >= 0.3.0     && < 0.4
+                   , mime-mail             >= 0.3       && < 0.4
+                   , SHA                   >= 1.4.1.3   && < 1.6
+                   , http-enumerator       >= 0.6       && < 0.8
+                   , pwstore-fast          >= 2.2       && < 3
+                   , old-time              >= 1.0
+                   , base64-bytestring     >= 0.1.0.1  && < 0.2
+                   , pureMD5               >= 2.1.0.3  && < 2.2
+                   , cereal                >= 0.3      && < 0.4
+                   , wai-app-static        >= 0.3.2.1  && < 0.4
+                   , file-embed            >= 0.0.4.1  && < 0.5
+                   , unix-compat           >= 0.2      && < 0.3
+                   , enumerator            >= 0.4.14   && < 0.5
+                   , transformers          >= 0.2.2    && < 0.3
+                   , data-default          >= 0.3      && < 0.4
+                   , xss-sanitize          >= 0.3.0.1  && < 0.4
+                   , blaze-builder         >= 0.2.1    && < 0.4
+                   , network               >= 2.2      && < 2.4
+                   , email-validate        >= 0.2.6    && < 0.3
+                   , persistent            >= 0.6      && < 0.7
+                   , persistent-template   >= 0.6      && < 0.7
+                   , failure               >= 0.1      && < 0.2
+                   , warp                  >= 0.4      && < 0.5
+                   , wai                   >= 0.4      && < 0.5
+                   , wai-extra             >= 0.4.1    && < 0.5
+                   , time                  >= 1.1.4
+                   , bytestring            >= 0.9.1.4  && < 0.12
+                   , text                  >= 0.9      && < 0.12
+                   , template-haskell
+                   , path-pieces           >= 0.0      && < 0.1
+                   , hamlet                >= 0.10     && < 0.11
+                   , shakespeare           >= 0.10     && < 0.11
+                   , shakespeare-js        >= 0.10     && < 0.11
+                   , shakespeare-css       >= 0.10     && < 0.11
+                   , blaze-builder         >= 0.2.1    && < 0.4
+                   , clientsession         >= 0.7.3.1  && < 0.8
+                   , random                >= 1.0.0.2  && < 1.1
+                   , old-locale            >= 1.0.0.2  && < 1.1
+                   , failure               >= 0.1      && < 0.2
+                   , containers            >= 0.2      && < 0.5
+                   , monad-control         >= 0.2      && < 0.3
+                   , cookie                >= 0.3      && < 0.4
+                   , blaze-html            >= 0.4.1.3  && < 0.5
+                   , http-types            >= 0.6.5    && < 0.7
+                   , case-insensitive      >= 0.2      && < 0.4
+                   , parsec                >= 2.0      && < 3.2
+                   , directory             >= 1.0      && < 1.2
+                   , data-object           >= 0.3      && < 0.4
+                   , data-object-yaml      >= 0.3      && < 0.4
+                   , strict-concurrency    >= 0.2.4    && < 0.2.5
+                   , vector                >= 0.9      && < 0.10
+                   , aeson                 >= 0.3
+
+    ghc-options:     -Wall
+
+test-suite tests
+    type: exitcode-stdio-1.0
+    main-is: main.hs
+    hs-source-dirs: 
+                    test
+                    yesod-core/test
+                    yesod-static/test
+
+    if flag(ghc7)
+        type: exitcode-stdio-1.0
+        build-depends:   base                      >= 4.3      && < 5
+        cpp-options:     -DGHC7
+        main-is:         test.hs
+    else
+        type: exitcode-stdio-1.0
+        build-depends:   base                      >= 4        && < 4.3
+        main-is:         test.hs
+    cpp-options:   -DTEST
+    build-depends: yesod-mega
+                  ,hspec >= 0.8 && < 0.10
+                  ,wai-test >= 0.1.2 && < 0.2
+                  ,wai
+                  ,bytestring
+                  ,hamlet
+                  ,shakespeare-css
+                  ,shakespeare-js
+                  ,text
+                  ,http-types
+                  , random
+                  ,HUnit
+                  ,QuickCheck >= 2 && < 3
+                  , enumerator
+    ghc-options:     -Wall
+
+source-repository head
+  type:     git
+  location: git://github.com/yesodweb/yesod.git

yesod-newsfeed/yesod-newsfeed.cabal

@@ -1,5 +1,5 @@
 name:            yesod-newsfeed
-version:         0.3.1
+version:         0.3.2
 license:         BSD3
 license-file:    LICENSE
 author:          Michael Snoyman, Patrick Brisbin
@@ -13,12 +13,12 @@ homepage:        http://www.yesodweb.com/
 description:     Helper functions and data types for producing News feeds.
 
 library
-    build-depends:   base                      >= 4        && < 5
-                   , yesod-core                >= 0.9      && < 0.10
-                   , time                      >= 1.1.4    && < 1.3
-                   , hamlet                    >= 0.10     && < 0.11
-                   , bytestring                >= 0.9      && < 0.10
-                   , text                      >= 0.9      && < 1.0
+    build-depends:   base                 >= 4        && < 5
+                   , yesod-core           >= 0.9      && < 0.10
+                   , time                 >= 1.1.4
+                   , hamlet               >= 0.10     && < 0.11
+                   , bytestring           >= 0.9.1.4  && < 0.10
+                   , text                 >= 0.9      && < 0.12
     exposed-modules: Yesod.AtomFeed
                    , Yesod.RssFeed
                    , Yesod.Feed

yesod-persistent/yesod-persistent.cabal

@@ -1,5 +1,5 @@
 name:            yesod-persistent
-version:         0.2.1
+version:         0.2.2
 license:         BSD3
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>
@@ -18,7 +18,7 @@ library
                    , persistent                >= 0.6      && < 0.7
                    , persistent-template       >= 0.6      && < 0.7
                    , failure                   >= 0.1      && < 0.2
-                   , transformers              >= 0.2      && < 0.3
+                   , transformers              >= 0.2.2    && < 0.3
     exposed-modules: Yesod.Persist
     ghc-options:     -Wall
 

yesod-sitemap/yesod-sitemap.cabal

@@ -1,5 +1,5 @@
 name:            yesod-sitemap
-version:         0.2.1
+version:         0.2.2
 license:         BSD3
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>
@@ -15,7 +15,7 @@ description:     Generate XML sitemaps.
 library
     build-depends:   base                      >= 4        && < 5
                    , yesod-core                >= 0.9      && < 0.10
-                   , time                      >= 1.1.4    && < 1.3
+                   , time                      >= 1.1.4
                    , hamlet                    >= 0.10     && < 0.11
     exposed-modules: Yesod.Sitemap
     ghc-options:     -Wall

yesod-static/Yesod/Static.hs

@@ -29,9 +29,13 @@ module Yesod.Static
     , embed
       -- * Template Haskell helpers
     , staticFiles
+    , staticFilesList
     , publicFiles
       -- * Hashing
     , base64md5
+#ifdef TEST
+    , getFileListPieces 
+#endif
     ) where
 
 import Prelude hiding (FilePath)
@@ -64,6 +68,9 @@ import qualified Data.ByteString as S
 import Network.HTTP.Types (status301)
 import System.PosixCompat.Files (getFileStatus, modificationTime)
 import System.Posix.Types (EpochTime)
+import qualified Data.Enumerator as E
+import qualified Data.Enumerator.List as EL
+import qualified Data.Enumerator.Binary as EB
 
 import Network.Wai.Application.Static
     ( StaticSettings (..)
@@ -155,6 +162,25 @@ getFileListPieces = flip go id
 staticFiles :: Prelude.FilePath -> Q [Dec]
 staticFiles dir = mkStaticFiles dir
 
+-- | Same as 'staticFiles', but takes an explicit list of files to create
+-- identifiers for. The files are given relative to the static folder. For
+-- example, to get the files \"static/js/jquery.js\" and
+-- \"static/css/normalize.css\", you would use:
+--
+-- > staticFilesList "static" ["js/jquery.js"], ["css/normalize.css"]]
+--
+-- This can be useful when you have a very large number of static files, but
+-- only need to refer to a few of them from Haskell.
+staticFilesList :: Prelude.FilePath -> [Prelude.FilePath] -> Q [Dec]
+staticFilesList dir fs =
+    mkStaticFilesList dir (map split fs) "StaticRoute" True
+  where
+    split :: Prelude.FilePath -> [String]
+    split [] = []
+    split x =
+        let (a, b) = break (== '/') x
+         in a : split (drop 1 b)
+
 -- | like staticFiles, but doesn't append an etag to the query string
 -- This will compile faster, but doesn't achieve as great of caching.
 -- The browser can avoid downloading the file, but it always needs to send a request with the etag value or the last-modified value to the server to see if its copy is up to dat
@@ -212,6 +238,15 @@ mkStaticFiles' :: Prelude.FilePath -- ^ static directory
                -> Q [Dec]
 mkStaticFiles' fp routeConName makeHash = do
     fs <- qRunIO $ getFileListPieces fp
+    mkStaticFilesList fp fs routeConName makeHash
+
+mkStaticFilesList
+    :: Prelude.FilePath -- ^ static directory
+    -> [[String]] -- ^ list of files to create identifiers for
+    -> String   -- ^ route constructor "StaticRoute"
+    -> Bool     -- ^ append checksum query parameter
+    -> Q [Dec]
+mkStaticFilesList fp fs routeConName makeHash = do
     concat `fmap` mapM mkRoute fs
   where
     replace' c
@@ -233,7 +268,6 @@ mkStaticFiles' fp routeConName makeHash = do
         pack' <- [|pack|]
         qs <- if makeHash
                     then do hash <- qRunIO $ base64md5File $ pathFromRawPieces fp f
-        -- FIXME hash <- qRunIO . calcHash $ fp ++ '/' : intercalate "/" f
                             [|[(pack $(lift hash), mempty)]|]
                     else return $ ListE []
         return
@@ -243,22 +277,35 @@ mkStaticFiles' fp routeConName makeHash = do
                 ]
             ]
 
+-- don't use L.readFile here, since it doesn't close handles quickly enough if
+-- there are lots of files in the static folder, it will cause exhausted file
+-- descriptors
 base64md5File :: Prelude.FilePath -> IO String
 base64md5File file = do
-  contents <- L.readFile file
-  return $ base64md5 contents
+    bss <- E.run_ $ EB.enumFile file E.$$ EL.consume
+    return $ base64md5 $ L.fromChunks bss
+    -- FIXME I'd like something streaming instead
+    {-
+    fmap (base64 . finalize) $ E.run_ $
+    EB.enumFile file E.$$ EL.fold go (md5InitialContext, "")
+  where
+    go (context, prev) next = (md5Update context prev, next)
+    finalize (context, end) = md5Finalize context end
+    -}
 
 -- | md5-hashes the given lazy bytestring and returns the hash as
 -- base64url-encoded string.
 --
 -- This function returns the first 8 characters of the hash.
 base64md5 :: L.ByteString -> String
-base64md5 = map tr
-          . take 8
-          . S8.unpack
-          . Data.ByteString.Base64.encode
-          . Data.Serialize.encode
-          . md5
+base64md5 = base64 . md5
+
+base64 :: MD5Digest -> String
+base64 = map tr
+       . take 8
+       . S8.unpack
+       . Data.ByteString.Base64.encode
+       . Data.Serialize.encode
   where
     tr '+' = '-'
     tr '/' = '_'

yesod-static/test/YesodStaticTest.hs

@@ -0,0 +1,16 @@
+module YesodStaticTest (specs) where
+
+import Test.Hspec
+import Test.HUnit ( (@?=) )
+import Test.Hspec.HUnit ( )
+
+import Yesod.Static (getFileListPieces)
+
+specs :: [Specs]
+specs = [
+    describe "get file list" [
+      it "pieces" $ do
+        x <- getFileListPieces "test/fs"
+        x @?= [["foo"], ["bar", "baz"]]
+    ]
+  ]

yesod-static/test/unicode/LICENSE

@@ -0,0 +1,25 @@
+The following license covers this documentation, and the source code, except
+where otherwise indicated.
+
+Copyright 2010, Michael Snoyman. All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+* Redistributions of source code must retain the above copyright notice, this
+  list of conditions and the following disclaimer.
+
+* Redistributions in binary form must reproduce the above copyright notice,
+  this list of conditions and the following disclaimer in the documentation
+  and/or other materials provided with the distribution.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR
+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO
+EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,
+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
+NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,
+OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
+OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

yesod-static/test/unicode/Setup.lhs

@@ -0,0 +1,7 @@
+#!/usr/bin/env runhaskell
+
+> module Main where
+> import Distribution.Simple
+
+> main :: IO ()
+> main = defaultMain