merge master, switch to optparse-applicative

.gitignore

@@ -6,5 +6,4 @@ dist
 client_session_key.aes
 cabal-dev/
 yesod/foobar/
-yesod-platform/yesod-platform.cabal
 .virthualenv

.travis.yml

@@ -0,0 +1,7 @@
+language: haskell
+
+install:
+    - cabal install mega-sdist hspec cabal-meta cabal-src
+    - cabal-meta install
+
+script: mega-sdist --test

LICENSE

@@ -1,25 +1,20 @@
-The following license covers this documentation, and the source code, except
+Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/
-where otherwise indicated.
 
-Copyright 2010, Michael Snoyman. All rights reserved.
+Permission is hereby granted, free of charge, to any person obtaining
+a copy of this software and associated documentation files (the
+"Software"), to deal in the Software without restriction, including
+without limitation the rights to use, copy, modify, merge, publish,
+distribute, sublicense, and/or sell copies of the Software, and to
+permit persons to whom the Software is furnished to do so, subject to
+the following conditions:
 
-Redistribution and use in source and binary forms, with or without
+The above copyright notice and this permission notice shall be
-modification, are permitted provided that the following conditions are met:
+included in all copies or substantial portions of the Software.
 
-* Redistributions of source code must retain the above copyright notice, this
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
-  list of conditions and the following disclaimer.
+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
-
+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
-* Redistributions in binary form must reproduce the above copyright notice,
+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
-  this list of conditions and the following disclaimer in the documentation
+LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
-  and/or other materials provided with the distribution.
+OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
-
+WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
-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.

README.md

@@ -1,3 +1,5 @@
+# Yesod
+
 An advanced web framework using the Haskell programming language. Featuring:
 
   * safety & security guaranteed at compile time
@@ -9,99 +11,118 @@ An advanced web framework using the Haskell programming language. Featuring:
     * this is built in to the Haskell programming language (like Erlang)
     * handles a greater concurrent load than any other web application server
 
-## Learn more: http://yesodweb.com/
+# Learn more: http://yesodweb.com/
 
-## Installation: http://www.yesodweb.com/page/five-minutes
+## Install the latests stable Yesod: http://www.yesodweb.com/page/quickstart
 
     cabal update && cabal install yesod
 
-## Create a new project after installing
+### Create a new project after installing
 
     yesod init
 
+Your application is a cabal package and you use `cabal` to install its dependencies.
+
+# Installing & isolation
+
+Install conflicts are unfortunately common in Haskell development.
+If you are not using any sandbox tools, you may discover that some of the other haskell installs on your system are broken.
+You can prevent this by using sandbox tools: `cabal-dev` or `virthualenv`, now being renamed to `hsenv`.
+
+Isolating an entire project with a virtual machine is also a great idea, you just need some tools to help that process.
+[Vagrant](http://vagrantup.com) is a great tool for that and there is a [Haskell Platform installer](https://bitbucket.org/puffnfresh/vagrant-haskell-heroku) for it.
 
 ## 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 which will use the sandbox.
-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 broken up into 4 separate code repositories each built upon many smaller packages.
 
-Install conflicts are unfortunately common in Haskell development.
+## Installing the latest development version from github for use with your application
-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.
+    cabal update
+    cabal install cabal-meta cabal-src
 
-### virthualenv
+In your application folder, create a `sources.txt` file with the following contents:
 
-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.
+    https://github.com/yesodweb/yesod
+    https://github.com/yesodweb/shakespeare
+    https://github.com/yesodweb/persistent
+    https://github.com/yesodweb/wai
 
-virthualenv will not work on Windows - Windows users should use only cabal-dev.
+`./` means build your app. The yesod repos will be cloned and placed in a `vendor` repo.
+Now run: `cabal-meta install`. If you use `cabal-dev`, run `cabal-meta --dev install`
+
+This should work almost all of the time. You can read more on [cabal-meta](https://github.com/yesodweb/cabal-meta)
+If you aren't building from an application, remove the `./` and create a new directory for your sources.txt first.
+
+
+
+## virthualenv
+
+We recommend using [virthualenv](http://hackage.haskell.org/package/virthualenv)/[hsenv](https://github.com/Paczesiowa/hsenv) when hacking on Yesod from Linux. This is optional, but prevents your custom build of Yesod from interfering with your currently installed cabal packages.
+
+virthualenv will not work on Windows and maybe not Mac. Use cabal-dev instead
 
 * virthualenv creates an isolated environment like cabal-dev
 * virthualenv works at the shell level, so every shell must activate the virthualenv
 * cabal-dev by default isolates a single cabal package, but virthualenv isolates multiple packages together.
 * cabal-dev can isolate multiple packages together by using the -s sandbox argument
 
-To just install Yesod from github, we only need cabal-dev. For hacking we prefer virthualenv: it is more convenient to just use normal cabal commands rather than `cabal-dev -s`.
 
+## cabal-src
 
-### cabal-src
+The cabal-src tool helps resolve dependency conflicts when installing local packages.
-
+This capability is already built in if you are using cabal-dev or cabal-meta. Otherwise install cabal-src with:
-Michael Snoyman just released the cabal-src tool, which helps resolve dependency conflicts when installing local packages. This capability is already built in if you are using cabal-dev. Otherwise install it with:
 
     cabal install cabal-src
 
-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.
+Whenever you would use `cabal install` to install a local package, use `cabal-src-install` instead.
+Our installer script now uses cabal-src-install when it is available.
 
 
-### Building Yesod
+## Cloning the repos
+
+The above instructions for building the latest should work well.
+But you can clone the repos without the help of cabal-meta:
 
 ~~~ { .bash }
-# update your package database if you haven't recently
+for repo in shakespeare persistent wai yesod; do
-cabal update
-# install required libraries
-cabal install Cabal cabal-install
-
-# use cabal-dev
-cabal install cabal-dev
-
-# or use virthualenv
-cabal install cabal-src virthualenv
-cd yesodweb # the folder where you put the yesod, persistent, hamlet & wai repos
-virthualenv --name=yesod
-. .virthualenv/bin/activate
-
-# clone and install all repos
-# see below about first using virthualenv/cabal-dev 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
-    ./scripts/install
   )
 done
+~~~~
+
+## Building your changes to Yesod
+
+Yesod is composed of 4 "mega-repos", each with multiple cabal packages. `./script/install` will run tests against each package and install each package.
+
+### install package in all repos
+
+~~~ { .bash }
+for repo in shakespeare persistent wai yesod; do
+    pushd $repo
+    ./scripts/install
+    popd
+done
 ~~~
 
-
+### Clean build (sometimes necessary)
-#### installing repo packages
 
 ~~~ { .bash }
-# install and test all packages in a repo
-./scripts/install
-
-# If things seem weird, you may need to do a clean.
 ./scripts/install --clean
+~~~
 
+### Building individual packages
+
+~~~ { .bash }
 # move to the individual package you are working on
 cd shakespeare-text
 
@@ -110,11 +131,3 @@ cabal configure -ftest --enable-tests
 cabal build
 cabal test
 ~~~
-
-
-### Use your development version of Yesod in your application
-
-Note that we have recommended to you to install Yesod into a sandboxed virthualenv environment.
-This is great for development, but when you want to use these development versions in your application that means they are not available through your user/global cabal database for your application.
-You should just continue to use your yesod virthualenv shell for your application.
-You can also use the same`cabal-dev shared sandbox.

scripts

@@ -1 +1 @@
-Subproject commit eba05a0b5fe121883969f8fa9b7f7669592430a4
+Subproject commit e1128e3eacb21cb4a59c00f30abf536c8ba66893

sources.txt

@@ -10,4 +10,3 @@
 ./yesod-default
 ./yesod-test
 ./yesod
-./yesod-test

yesod-auth-oauth/LICENSE

@@ -1,25 +1,20 @@
-The following license covers this documentation, and the source code, except
+Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/
-where otherwise indicated.
 
-Copyright 2010, Michael Snoyman. All rights reserved.
+Permission is hereby granted, free of charge, to any person obtaining
+a copy of this software and associated documentation files (the
+"Software"), to deal in the Software without restriction, including
+without limitation the rights to use, copy, modify, merge, publish,
+distribute, sublicense, and/or sell copies of the Software, and to
+permit persons to whom the Software is furnished to do so, subject to
+the following conditions:
 
-Redistribution and use in source and binary forms, with or without
+The above copyright notice and this permission notice shall be
-modification, are permitted provided that the following conditions are met:
+included in all copies or substantial portions of the Software.
 
-* Redistributions of source code must retain the above copyright notice, this
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
-  list of conditions and the following disclaimer.
+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
-
+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
-* Redistributions in binary form must reproduce the above copyright notice,
+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
-  this list of conditions and the following disclaimer in the documentation
+LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
-  and/or other materials provided with the distribution.
+OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
-
+WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
-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-auth-oauth/yesod-auth-oauth.cabal

@@ -1,5 +1,5 @@
 name:            yesod-auth-oauth
-version:         1.0.0
+version:         1.1.0.0
 license:         BSD3
 license-file:    LICENSE
 author:          Hiromi Ishii
@@ -10,8 +10,7 @@ stability:       Stable
 cabal-version:   >= 1.6.0
 build-type:      Simple
 homepage:        http://www.yesodweb.com/
-extra-source-files: include/qq.h
+description:     Oauth Authentication for Yesod.
-description:     Authentication for Yesod.
 
 flag ghc7
 
@@ -21,13 +20,13 @@ library
         cpp-options:     -DGHC7
     else
         build-depends:   base                >= 4         && < 4.3
-    build-depends:   authenticate-oauth      >= 1.3       && < 1.4
+    build-depends:   authenticate-oauth      >= 1.4       && < 1.5
                    , bytestring              >= 0.9.1.4   && < 0.10
-                   , yesod-core              >= 1.0       && < 1.1
+                   , yesod-core              >= 1.1       && < 1.2
-                   , yesod-auth              >= 1.0       && < 1.1
+                   , yesod-auth              >= 1.1       && < 1.2
                    , text                    >= 0.7       && < 0.12
-                   , yesod-form              >= 1.0       && < 1.1
+                   , yesod-form              >= 1.1       && < 1.2
-                   , transformers            >= 0.2.2     && < 0.3
+                   , transformers            >= 0.2.2     && < 0.4
     exposed-modules: Yesod.Auth.OAuth
     ghc-options:     -Wall
 

yesod-auth/LICENSE

@@ -1,25 +1,20 @@
-The following license covers this documentation, and the source code, except
+Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/
-where otherwise indicated.
 
-Copyright 2010, Michael Snoyman. All rights reserved.
+Permission is hereby granted, free of charge, to any person obtaining
+a copy of this software and associated documentation files (the
+"Software"), to deal in the Software without restriction, including
+without limitation the rights to use, copy, modify, merge, publish,
+distribute, sublicense, and/or sell copies of the Software, and to
+permit persons to whom the Software is furnished to do so, subject to
+the following conditions:
 
-Redistribution and use in source and binary forms, with or without
+The above copyright notice and this permission notice shall be
-modification, are permitted provided that the following conditions are met:
+included in all copies or substantial portions of the Software.
 
-* Redistributions of source code must retain the above copyright notice, this
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
-  list of conditions and the following disclaimer.
+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
-
+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
-* Redistributions in binary form must reproduce the above copyright notice,
+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
-  this list of conditions and the following disclaimer in the documentation
+LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
-  and/or other materials provided with the distribution.
+OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
-
+WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
-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-auth/Yesod/Auth.hs

@@ -149,7 +149,10 @@ setCreds doRedirects creds = do
         Nothing ->
           when doRedirects $ do
             case authRoute y of
-              Nothing -> do rh <- defaultLayout $ toWidget [shamlet| <h1>Invalid login |]
+              Nothing -> do rh <- defaultLayout $ toWidget [shamlet|
+$newline never
+<h1>Invalid login
+|]
                             sendResponse rh
               Just ar -> do setMessageI Msg.InvalidLogin
                             redirect ar
@@ -168,6 +171,7 @@ getCheckR = do
   where
     html' creds =
         [shamlet|
+$newline never
 <h1>Authentication Status
 $maybe _ <- creds
     <p>Logged in.

yesod-auth/Yesod/Auth/BrowserId.hs

@@ -62,6 +62,7 @@ helper maudience = AuthPlugin
     , apLogin = \toMaster -> do
         addScriptRemote browserIdJs
         toWidget [hamlet|
+$newline never
 <p>
     <a href="javascript:navigator.id.getVerifiedEmail(function(a){if(a)document.location='@{toMaster complete}/'+a});">
         <img src="https://browserid.org/i/sign_in_green.png">

yesod-auth/Yesod/Auth/Dummy.hs

@@ -24,6 +24,7 @@ authDummy =
     url = PluginR "dummy" []
     login authToMaster =
         toWidget [hamlet|
+$newline never
 <form method="post" action="@{authToMaster url}">
     Your new identifier is: #
     <input type="text" name="ident">

yesod-auth/Yesod/Auth/Email.hs

@@ -79,6 +79,7 @@ authEmail :: YesodAuthEmail m => AuthPlugin m
 authEmail =
     AuthPlugin "email" dispatch $ \tm ->
         [whamlet|
+$newline never
 <form method="post" action="@{tm loginR}">
     <table>
         <tr>
@@ -112,6 +113,7 @@ getRegisterR = do
     defaultLayout $ do
         setTitleI Msg.RegisterLong
         [whamlet|
+$newline never
 <p>_{Msg.EnterEmail}
 <form method="post" action="@{toMaster registerR}">
     <label for="email">_{Msg.Email}
@@ -141,7 +143,10 @@ postRegisterR = do
     sendVerifyEmail email verKey verUrl
     defaultLayout $ do
         setTitleI Msg.ConfirmationEmailSentTitle
-        [whamlet| <p>_{Msg.ConfirmationEmailSent email} |]
+        [whamlet|
+$newline never
+<p>_{Msg.ConfirmationEmailSent email}
+|]
 
 getVerifyR :: YesodAuthEmail m
            => AuthEmailId m -> Text -> GHandler Auth m RepHtml
@@ -161,7 +166,10 @@ getVerifyR lid key = do
         _ -> return ()
     defaultLayout $ do
         setTitleI Msg.InvalidKey
-        [whamlet| <p>_{Msg.InvalidKey} |]
+        [whamlet|
+$newline never
+<p>_{Msg.InvalidKey}
+|]
 
 postLoginR :: YesodAuthEmail master => GHandler Auth master ()
 postLoginR = do
@@ -200,6 +208,7 @@ getPasswordR = do
     defaultLayout $ do
         setTitleI Msg.SetPassTitle
         [whamlet|
+$newline never
 <h3>_{Msg.SetPass}
 <form method="post" action="@{toMaster setpassR}">
     <table>

yesod-auth/Yesod/Auth/GoogleEmail.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE CPP #-}
 -- | 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
@@ -20,25 +21,35 @@ import qualified Web.Authenticate.OpenId as OpenId
 import Yesod.Handler
 import Yesod.Widget (whamlet)
 import Yesod.Request
+#if MIN_VERSION_blaze_html(0, 5, 0)
+import Text.Blaze.Html (toHtml)
+#else
 import Text.Blaze (toHtml)
+#endif
 import Data.Text (Text)
 import qualified Yesod.Auth.Message as Msg
 import qualified Data.Text as T
 import Control.Exception.Lifted (try, SomeException)
 
+pid :: Text
+pid = "googleemail"
+
 forwardUrl :: AuthRoute
-forwardUrl = PluginR "googleemail" ["forward"]
+forwardUrl = PluginR pid ["forward"]
 
 googleIdent :: Text
 googleIdent = "https://www.google.com/accounts/o8/id"
 
 authGoogleEmail :: YesodAuth m => AuthPlugin m
 authGoogleEmail =
-    AuthPlugin "googleemail" dispatch login
+    AuthPlugin pid dispatch login
   where
-    complete = PluginR "googleemail" ["complete"]
+    complete = PluginR pid ["complete"]
     login tm =
-        [whamlet|<a href=@{tm forwardUrl}>_{Msg.LoginGoogle}|]
+        [whamlet|
+$newline never
+<a href=@{tm forwardUrl}>_{Msg.LoginGoogle}
+|]
     dispatch "GET" ["forward"] = do
         render <- getUrlRender
         toMaster <- getRouteToMaster
@@ -72,15 +83,16 @@ authGoogleEmail =
 completeHelper :: YesodAuth m => [(Text, Text)] -> GHandler Auth m ()
 completeHelper gets' = do
         master <- getYesod
-        eres <- lift $ try $ OpenId.authenticate gets' (authHttpManager master)
+        eres <- lift $ try $ OpenId.authenticateClaimed gets' (authHttpManager master)
         toMaster <- getRouteToMaster
         let onFailure err = do
             setMessage $ toHtml $ show (err :: SomeException)
             redirect $ toMaster LoginR
-        let onSuccess (OpenId.Identifier ident, _) = do
+        let onSuccess oir = do
+                let OpenId.Identifier ident = OpenId.oirOpLocal oir
                 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 []
+                    (Just email, True) -> setCreds True $ Creds pid email []
                     (_, False) -> do
                         setMessage "Only Google login is supported"
                         redirect $ toMaster LoginR

yesod-auth/Yesod/Auth/HashDB.hs

@@ -76,7 +76,7 @@ import Yesod.Handler
 import Yesod.Form
 import Yesod.Auth
 import Yesod.Widget (toWidget)
-import Text.Hamlet (hamlet, shamlet)
+import Text.Hamlet (hamlet)
 
 import Control.Applicative         ((<$>), (<*>))
 import Control.Monad               (replicateM,liftM)
@@ -176,7 +176,7 @@ postLoginR uniq = do
                  (validateUser <$> (uniq =<< mu) <*> mp)
     if isValid 
        then setCreds True $ Creds "hashdb" (fromMaybe "" mu) []
-       else do setMessage [shamlet| Invalid username/password |]
+       else do setMessage "Invalid username/password"
                toMaster <- getRouteToMaster
                redirect $ toMaster LoginR
 
@@ -207,7 +207,7 @@ getAuthIdHashDB authR uniq creds = do
                 -- user exists
                 Just (Entity uid _) -> return $ Just uid
                 Nothing       -> do
-                    setMessage [shamlet| User not found |]
+                    setMessage "User not found"
                     redirect $ authR LoginR
 
 -- | Prompt for username and password, validate that against a database
@@ -221,6 +221,7 @@ authHashDB :: ( YesodAuth m, YesodPersist m
               , PersistUnique b (GHandler Auth m))
            => (Text -> Maybe (Unique user b)) -> AuthPlugin m
 authHashDB uniq = AuthPlugin "hashdb" dispatch $ \tm -> toWidget [hamlet|
+$newline never
     <div id="header">
         <h1>Login
 

yesod-auth/Yesod/Auth/Message.hs

@@ -8,6 +8,10 @@ module Yesod.Auth.Message
     , portugueseMessage
     , swedishMessage
     , germanMessage
+    , frenchMessage
+    , norwegianBokmålMessage
+    , japaneseMessage
+    , finnishMessage
     ) where
 
 import Data.Monoid (mappend)
@@ -183,3 +187,143 @@ germanMessage NowLoggedIn = "Login erfolgreich"
 germanMessage LoginTitle = "Login"
 germanMessage PleaseProvideUsername = "Bitte Nutzername angeben"
 germanMessage PleaseProvidePassword = "Bitte Passwort angeben"
+
+
+
+frenchMessage :: AuthMessage -> Text
+frenchMessage NoOpenID = "Aucun fournisseur OpenID n'a été trouvé"
+frenchMessage LoginOpenID = "Se connecter avec OpenID"
+frenchMessage LoginGoogle = "Se connecter avec Google"
+frenchMessage LoginYahoo = "Se connecter avec Yahoo"
+frenchMessage Email = "Adresse électronique"
+frenchMessage Password = "Mot de passe"
+frenchMessage Register = "S'inscrire"
+frenchMessage RegisterLong = "Créer un compte"
+frenchMessage EnterEmail = "Entrez ci-dessous votre adresse électronique, et un message de confirmation vous sera envoyé"
+frenchMessage ConfirmationEmailSentTitle = "Message de confirmation"
+frenchMessage (ConfirmationEmailSent email) =
+    "Un message de confirmation a été envoyé à " `mappend`
+    email `mappend`
+    "."
+frenchMessage AddressVerified = "Votre adresse électronique a été validée, merci de choisir un nouveau mot de passe."
+frenchMessage InvalidKeyTitle = "Clef de validation incorrecte"
+frenchMessage InvalidKey = "Désolé, mais cette clef de validation est incorrecte"
+frenchMessage InvalidEmailPass = "Le couple mot de passe/adresse électronique n'est pas correct"
+frenchMessage BadSetPass = "Vous devez être connecté pour choisir un mot de passe"
+frenchMessage SetPassTitle = "Changer de mot de passe"
+frenchMessage SetPass = "Choisir un nouveau mot de passe"
+frenchMessage NewPass = "Nouveau mot de passe"
+frenchMessage ConfirmPass = "Confirmation du mot de passe"
+frenchMessage PassMismatch = "Le deux mots de passe sont différents, veuillez les corriger"
+frenchMessage PassUpdated = "Le mot de passe a bien été changé"
+frenchMessage Facebook = "Se connecter avec Facebook"
+frenchMessage LoginViaEmail = "Se connecter à l'aide d'une adresse électronique"
+frenchMessage InvalidLogin = "Nom d'utilisateur incorrect"
+frenchMessage NowLoggedIn = "Vous êtes maintenant connecté"
+frenchMessage LoginTitle = "Se connecter"
+frenchMessage PleaseProvideUsername = "Merci de renseigner votre nom d'utilisateur"
+frenchMessage PleaseProvidePassword = "Merci de spécifier un mot de passe"
+
+norwegianBokmålMessage :: AuthMessage -> Text
+norwegianBokmålMessage NoOpenID = "Ingen OpenID-identifiserer funnet"
+norwegianBokmålMessage LoginOpenID = "Logg inn med OpenID"
+norwegianBokmålMessage LoginGoogle = "Logg inn med Google"
+norwegianBokmålMessage LoginYahoo = "Logg inn med Yahoo"
+norwegianBokmålMessage Email = "E-post"
+norwegianBokmålMessage Password = "Passord"
+norwegianBokmålMessage Register = "Registrer"
+norwegianBokmålMessage RegisterLong = "Registrer en ny konto"
+norwegianBokmålMessage EnterEmail = "Skriv inn e-postadressen din nedenfor og en e-postkonfirmasjon vil bli sendt."
+norwegianBokmålMessage ConfirmationEmailSentTitle = "E-postkonfirmasjon sendt."
+norwegianBokmålMessage (ConfirmationEmailSent email) =
+    "En e-postkonfirmasjon har blitt sendt til " `mappend`
+    email `mappend`
+    "."
+norwegianBokmålMessage AddressVerified = "Adresse verifisert, vennligst sett et nytt passord."
+norwegianBokmålMessage InvalidKeyTitle = "Ugyldig verifiseringsnøkkel"
+norwegianBokmålMessage InvalidKey = "Beklager, men det var en ugyldig verifiseringsnøkkel."
+norwegianBokmålMessage InvalidEmailPass = "Ugyldig e-post/passord-kombinasjon"
+norwegianBokmålMessage BadSetPass = "Du må være logget inn for å sette et passord."
+norwegianBokmålMessage SetPassTitle = "Sett passord"
+norwegianBokmålMessage SetPass = "Sett et nytt passord"
+norwegianBokmålMessage NewPass = "Nytt passord"
+norwegianBokmålMessage ConfirmPass = "Bekreft"
+norwegianBokmålMessage PassMismatch = "Passordene stemte ikke overens, vennligst prøv igjen"
+norwegianBokmålMessage PassUpdated = "Passord oppdatert"
+norwegianBokmålMessage Facebook = "Logg inn med Facebook"
+norwegianBokmålMessage LoginViaEmail = "Logg inn med e-post"
+norwegianBokmålMessage InvalidLogin = "Ugyldig innlogging"
+norwegianBokmålMessage NowLoggedIn = "Du er nå logget inn"
+norwegianBokmålMessage LoginTitle = "Logg inn"
+norwegianBokmålMessage PleaseProvideUsername = "Vennligst fyll inn ditt brukernavn"
+norwegianBokmålMessage PleaseProvidePassword = "Vennligst fyll inn ditt passord"
+
+japaneseMessage :: AuthMessage -> Text
+japaneseMessage NoOpenID = "OpenID識別子がありません"
+japaneseMessage LoginOpenID = "OpenIDでログイン"
+japaneseMessage LoginGoogle = "Googleでログイン"
+japaneseMessage LoginYahoo = "Yahooでログイン"
+japaneseMessage Email = "Eメール"
+japaneseMessage Password = "パスワード"
+japaneseMessage Register = "登録"
+japaneseMessage RegisterLong = "新規アカウント登録"
+japaneseMessage EnterEmail = "メールアドレスを入力してください。確認メールが送られます"
+japaneseMessage ConfirmationEmailSentTitle = "確認メールを送信しました"
+japaneseMessage (ConfirmationEmailSent email) =
+    "確認メールを " `mappend`
+    email `mappend`
+    " に送信しました"
+japaneseMessage AddressVerified = "アドレスは認証されました。新しいパスワードを設定してください"
+japaneseMessage InvalidKeyTitle = "認証キーが無効です"
+japaneseMessage InvalidKey = "申し訳ありません。無効な認証キーです"
+japaneseMessage InvalidEmailPass = "メールアドレスまたはパスワードが無効です"
+japaneseMessage BadSetPass = "パスワードを設定するためには、ログインしてください"
+japaneseMessage SetPassTitle = "パスワードの設定"
+japaneseMessage SetPass = "新しいパスワードを設定する"
+japaneseMessage NewPass = "新しいパスワード"
+japaneseMessage ConfirmPass = "確認"
+japaneseMessage PassMismatch = "パスワードが合いません。もう一度試してください"
+japaneseMessage PassUpdated = "パスワードは更新されました"
+japaneseMessage Facebook = "Facebookでログイン"
+japaneseMessage LoginViaEmail = "Eメールでログイン"
+japaneseMessage InvalidLogin = "無効なログインです"
+japaneseMessage NowLoggedIn = "ログインしました"
+japaneseMessage LoginTitle = "ログイン"
+japaneseMessage PleaseProvideUsername = "ユーザ名を入力してください"
+japaneseMessage PleaseProvidePassword = "パスワードを入力してください"
+
+finnishMessage :: AuthMessage -> Text
+finnishMessage NoOpenID = "OpenID-tunnistetta ei löydy"
+finnishMessage LoginOpenID = "Kirjaudu OpenID-tilillä"
+finnishMessage LoginGoogle = "Kirjaudu Google-tilillä"
+finnishMessage LoginYahoo = "Kirjaudu Yahoo-tilillä"
+finnishMessage Email = "Sähköposti"
+finnishMessage Password = "Salasana"
+finnishMessage Register = "Luo uusi"
+finnishMessage RegisterLong = "Luo uusi tili"
+finnishMessage EnterEmail = "Kirjoita alle sähköpostiosoitteesi, johon vahvistussähköposti lähetetään."
+finnishMessage ConfirmationEmailSentTitle = "Vahvistussähköposti lähetetty."
+finnishMessage (ConfirmationEmailSent email) =
+    "Vahvistussähköposti on lähetty osoitteeseen " `mappend`
+    email `mappend`
+    "."
+finnishMessage AddressVerified = "Sähköpostiosoite vahvistettu. Anna uusi salasana"
+finnishMessage InvalidKeyTitle = "Virheellinen varmistusavain"
+finnishMessage InvalidKey = "Valitettavasti varmistusavain on virheellinen."
+finnishMessage InvalidEmailPass = "Virheellinen sähköposti tai salasana."
+finnishMessage BadSetPass = "Kirjaudu ensin sisään asettaaksesi salasanan"
+finnishMessage SetPassTitle = "Salasanan asettaminen"
+finnishMessage SetPass = "Aseta uusi salasana"
+finnishMessage NewPass = "Uusi salasana"
+finnishMessage ConfirmPass = "Vahvista"
+finnishMessage PassMismatch = "Salasanat eivät täsmää"
+finnishMessage PassUpdated = "Salasana vaihdettu"
+finnishMessage Facebook = "Kirjaudu Facebook-tilillä"
+finnishMessage LoginViaEmail = "Kirjaudu sähköpostitilillä"
+finnishMessage InvalidLogin = "Kirjautuminen epäonnistui"
+finnishMessage NowLoggedIn = "Olet nyt kirjautunut sisään"
+finnishMessage LoginTitle = "Kirjautuminen"
+finnishMessage PleaseProvideUsername = "Käyttäjänimi puuttuu"
+finnishMessage PleaseProvidePassword = "Salasana puuttuu"
+
+

yesod-auth/Yesod/Auth/OpenId.hs

@@ -1,9 +1,13 @@
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE CPP #-}
 module Yesod.Auth.OpenId
     ( authOpenId
-    , authOpenIdExtended
     , forwardUrl
+    , claimedKey
+    , opLocalKey
+    , credsIdentClaimed
+    , IdentifierType (..)
     ) where
 
 import Yesod.Auth
@@ -14,30 +18,42 @@ import Yesod.Handler
 import Yesod.Widget (toWidget, whamlet)
 import Yesod.Request
 import Text.Cassius (cassius)
+#if MIN_VERSION_blaze_html(0, 5, 0)
+import Text.Blaze.Html (toHtml)
+#else
 import Text.Blaze (toHtml)
-import Data.Text (Text)
+#endif
+import Data.Text (Text, isPrefixOf)
 import qualified Yesod.Auth.Message as Msg
 import Control.Exception.Lifted (SomeException, try)
+import Data.Maybe (fromMaybe)
 
 forwardUrl :: AuthRoute
 forwardUrl = PluginR "openid" ["forward"]
 
-authOpenId :: YesodAuth m => AuthPlugin m
+data IdentifierType = Claimed | OPLocal
-authOpenId = authOpenIdExtended []
 
-authOpenIdExtended :: YesodAuth m => [(Text, Text)] -> AuthPlugin m
+authOpenId :: YesodAuth m
-authOpenIdExtended extensionFields =
+           => IdentifierType
+           -> [(Text, Text)] -- ^ extension fields
+           -> AuthPlugin m
+authOpenId idType extensionFields =
     AuthPlugin "openid" dispatch login
   where
     complete = PluginR "openid" ["complete"]
     name = "openid_identifier"
     login tm = do
         ident <- lift newIdent
-        toWidget [cassius|##{ident}
+        -- FIXME this is a hack to get GHC 7.6's type checker to allow the
+        -- code, but it shouldn't be necessary
+        let y :: a -> [(Text, Text)] -> Text
+            y = undefined
+        toWidget (\x -> [cassius|##{ident}
     background: #fff url(http://www.myopenid.com/static/openid-icon-small.gif) no-repeat scroll 0pt 50%;
     padding-left: 18px;
-|]
+|] $ x `asTypeOf` y)
         [whamlet|
+$newline never
 <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}
@@ -70,21 +86,64 @@ authOpenIdExtended extensionFields =
     dispatch "GET" ["complete", ""] = dispatch "GET" ["complete"] -- compatibility issues
     dispatch "GET" ["complete"] = do
         rr <- getRequest
-        completeHelper $ reqGetParams rr
+        completeHelper idType $ reqGetParams rr
     dispatch "POST" ["complete", ""] = dispatch "POST" ["complete"] -- compatibility issues
     dispatch "POST" ["complete"] = do
         (posts, _) <- runRequestBody
-        completeHelper posts
+        completeHelper idType posts
     dispatch _ _ = notFound
 
-completeHelper :: YesodAuth m => [(Text, Text)] -> GHandler Auth m ()
+completeHelper :: YesodAuth m => IdentifierType -> [(Text, Text)] -> GHandler Auth m ()
-completeHelper gets' = do
+completeHelper idType gets' = do
         master <- getYesod
-        eres <- lift $ try $ OpenId.authenticate gets' (authHttpManager master)
+        eres <- lift $ try $ OpenId.authenticateClaimed gets' (authHttpManager master)
         toMaster <- getRouteToMaster
         let onFailure err = do
             setMessage $ toHtml $ show (err :: SomeException)
             redirect $ toMaster LoginR
-        let onSuccess (OpenId.Identifier ident, _) =
+        let onSuccess oir = do
-                setCreds True $ Creds "openid" ident gets'
+                let claimed =
+                        case OpenId.oirClaimed oir of
+                            Nothing -> id
+                            Just (OpenId.Identifier i') -> ((claimedKey, i'):)
+                    oplocal =
+                        case OpenId.oirOpLocal oir of
+                            OpenId.Identifier i' -> ((opLocalKey, i'):)
+                    gets'' = oplocal $ claimed $ filter (\(k, _) -> not $ "__" `isPrefixOf` k) gets'
+                    i = OpenId.identifier $
+                            case idType of
+                                OPLocal -> OpenId.oirOpLocal oir
+                                Claimed -> fromMaybe (OpenId.oirOpLocal oir) $ OpenId.oirClaimed oir
+                setCreds True $ Creds "openid" i gets''
         either onFailure onSuccess eres
+
+-- | The main identifier provided by the OpenID authentication plugin is the
+-- \"OP-local identifier\". There is also sometimes a \"claimed\" identifier
+-- available.
+--
+-- In the 'credsExtra' field of the 'Creds' datatype, you can lookup this key
+-- to find the claimed identifier, if available.
+--
+-- > let finalID = fromMaybe (credsIdent creds)
+-- >             $ lookup claimedKey (credsExtra creds)
+--
+-- Since 1.0.2
+claimedKey :: Text
+claimedKey = "__CLAIMED"
+
+opLocalKey :: Text
+opLocalKey = "__OPLOCAL"
+
+-- | A helper function which will get the claimed identifier, if available, falling back to the OP local identifier.
+--
+-- See 'claimedKey'.
+--
+-- Since 1.0.2
+credsIdentClaimed :: Creds m -> Text
+
+-- Prevent other backends from overloading the __CLAIMED value, which could
+-- possibly open us to security holes.
+credsIdentClaimed c | credsPlugin c /= "openid" = credsIdent c
+
+credsIdentClaimed c = fromMaybe (credsIdent c)
+                    $ lookup claimedKey (credsExtra c)

yesod-auth/Yesod/Auth/Rpxnow.hs

@@ -25,6 +25,7 @@ authRpxnow app apiKey =
     login tm = do
         let url = {- FIXME urlEncode $ -} tm $ PluginR "rpxnow" []
         toWidget [hamlet|
+$newline never
 <iframe src="http://#{app}.rpxnow.com/openid/embed?token_url=@{url}" scrolling="no" frameBorder="no" allowtransparency="true" style="width:400px;height:240px">
 |]
     dispatch _ [] = do

yesod-auth/openid.hs

@@ -38,13 +38,13 @@ $nothing
 |]
 
 instance Yesod BID where
-    approot _ = "http://localhost:3000"
+    approot = ApprootStatic "http://localhost:3000"
 
 instance YesodAuth BID where
     type AuthId BID = Text
     loginDest _ = AfterLoginR
     logoutDest _ = AuthR LoginR
-    getAuthId = return . Just . credsIdent
+    getAuthId = return . Just . credsIdentClaimed
     authPlugins _ = [authOpenId]
     authHttpManager = httpManager
 

yesod-auth/yesod-auth.cabal

@@ -1,5 +1,5 @@
 name:            yesod-auth
-version:         1.0.0
+version:         1.1.1.2
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman, Patrick Brisbin
@@ -12,35 +12,34 @@ build-type:      Simple
 homepage:        http://www.yesodweb.com/
 description:     Authentication for Yesod.
 
-flag ghc7
-
 library
     build-depends:   base                    >= 4         && < 5
-                   , authenticate            >= 1.2       && < 1.3
+                   , authenticate            >= 1.3       && < 1.4
-                   , bytestring              >= 0.9.1.4   && < 0.10
+                   , bytestring              >= 0.9.1.4
-                   , yesod-core              >= 1.0       && < 1.1
+                   , yesod-core              >= 1.1       && < 1.2
-                   , wai                     >= 1.2       && < 1.3
+                   , wai                     >= 1.3       && < 1.4
                    , template-haskell
                    , pureMD5                 >= 2.0       && < 2.2
                    , random                  >= 1.0.0.2  && < 1.1
                    , text                    >= 0.7       && < 0.12
                    , mime-mail               >= 0.3       && < 0.5
-                   , blaze-html              >= 0.4.1.3   && < 0.5
+                   , yesod-persistent        >= 1.1       && < 1.2
-                   , yesod-persistent        >= 1.0       && < 1.1
+                   , hamlet                  >= 1.1       && < 1.2
-                   , hamlet                  >= 1.0       && < 1.1
                    , shakespeare-css         >= 1.0       && < 1.1
-                   , yesod-json              >= 1.0       && < 1.1
+                   , yesod-json              >= 1.1       && < 1.2
                    , containers
                    , unordered-containers
-                   , yesod-form              >= 1.0       && < 1.1
+                   , yesod-form              >= 1.1       && < 1.2
                    , transformers            >= 0.2.2     && < 0.4
-                   , persistent              >= 0.9       && < 0.10
+                   , persistent              >= 1.0       && < 1.1
-                   , persistent-template     >= 0.9       && < 0.10
+                   , persistent-template     >= 1.0       && < 1.1
                    , SHA                     >= 1.4.1.3   && < 1.6
-                   , http-conduit            >= 1.4       && < 1.5
+                   , http-conduit            >= 1.5       && < 1.7
                    , aeson                   >= 0.5
                    , pwstore-fast            >= 2.2       && < 3
-                   , lifted-base             >= 0.1       && < 0.2
+                   , lifted-base             >= 0.1
+                   , blaze-html              >= 0.5       && < 0.6
+                   , blaze-markup            >= 0.5.1     && < 0.6
 
     exposed-modules: Yesod.Auth
                      Yesod.Auth.BrowserId

yesod-core/LICENSE

@@ -1,25 +1,20 @@
-The following license covers this documentation, and the source code, except
+Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/
-where otherwise indicated.
 
-Copyright 2010, Michael Snoyman. All rights reserved.
+Permission is hereby granted, free of charge, to any person obtaining
+a copy of this software and associated documentation files (the
+"Software"), to deal in the Software without restriction, including
+without limitation the rights to use, copy, modify, merge, publish,
+distribute, sublicense, and/or sell copies of the Software, and to
+permit persons to whom the Software is furnished to do so, subject to
+the following conditions:
 
-Redistribution and use in source and binary forms, with or without
+The above copyright notice and this permission notice shall be
-modification, are permitted provided that the following conditions are met:
+included in all copies or substantial portions of the Software.
 
-* Redistributions of source code must retain the above copyright notice, this
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
-  list of conditions and the following disclaimer.
+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
-
+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
-* Redistributions in binary form must reproduce the above copyright notice,
+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
-  this list of conditions and the following disclaimer in the documentation
+LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
-  and/or other materials provided with the distribution.
+OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
-
+WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
-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-core/Yesod/Content.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE TypeSynonymInstances #-}
 {-# LANGUAGE Rank2Types #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE CPP #-}
 module Yesod.Content
     ( -- * Content
       Content (..)
@@ -27,6 +28,8 @@ module Yesod.Content
     , typeOctet
       -- * Utilities
     , simpleContentType
+      -- * Evaluation strategy
+    , DontFullyEvaluate (..)
       -- * Representations
     , ChooseRep
     , HasReps (..)
@@ -59,14 +62,15 @@ import Blaze.ByteString.Builder (Builder, fromByteString, fromLazyByteString)
 import Data.Monoid (mempty)
 
 import Text.Hamlet (Html)
-import Text.Blaze.Renderer.Utf8 (renderHtmlBuilder)
+import Text.Blaze.Html.Renderer.Utf8 (renderHtmlBuilder)
 import Data.String (IsString (fromString))
 import Network.Wai (FilePart)
 import Data.Conduit (Source, ResourceT, Flush)
 
-data Content = ContentBuilder Builder (Maybe Int) -- ^ The content and optional content length.
+data Content = ContentBuilder !Builder !(Maybe Int) -- ^ The content and optional content length.
-             | ContentSource (Source (ResourceT IO) (Flush Builder))
+             | ContentSource !(Source (ResourceT IO) (Flush Builder))
-             | ContentFile FilePath (Maybe FilePart)
+             | ContentFile !FilePath !(Maybe FilePart)
+             | ContentDontEvaluate !Content
 
 -- | Zero-length enumerator.
 emptyContent :: Content
@@ -234,3 +238,15 @@ formatRFC1123 = T.pack . formatTime defaultTimeLocale "%a, %d %b %Y %X %Z"
 -- | Format as per RFC 822.
 formatRFC822 :: UTCTime -> T.Text
 formatRFC822 = T.pack . formatTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S %z"
+
+-- | Prevents a response body from being fully evaluated before sending the
+-- request.
+--
+-- Since 1.1.0
+newtype DontFullyEvaluate a = DontFullyEvaluate a
+
+instance HasReps a => HasReps (DontFullyEvaluate a) where
+    chooseRep (DontFullyEvaluate a) = fmap (fmap (fmap ContentDontEvaluate)) $ chooseRep a
+
+instance ToContent a => ToContent (DontFullyEvaluate a) where
+    toContent (DontFullyEvaluate a) = ContentDontEvaluate $ toContent a

yesod-core/Yesod/Core.hs

@@ -10,6 +10,7 @@ module Yesod.Core
     , breadcrumbs
       -- * Types
     , Approot (..)
+    , FileUpload (..)
       -- * Utitlities
     , maybeAuthorized
     , widgetToPageContent
@@ -20,13 +21,16 @@ module Yesod.Core
     , unauthorizedI
       -- * Logging
     , LogLevel (..)
-    , formatLogMessage
-    , fileLocationToString
     , logDebug
     , logInfo
     , logWarn
     , logError
     , logOther
+    , logDebugS
+    , logInfoS
+    , logWarnS
+    , logErrorS
+    , logOtherS
       -- * Sessions
     , SessionBackend (..)
     , defaultClientSessionBackend
@@ -41,6 +45,7 @@ module Yesod.Core
       -- * Misc
     , yesodVersion
     , yesodRender
+    , runFakeHandler
       -- * Re-exports
     , module Yesod.Content
     , module Yesod.Dispatch
@@ -59,38 +64,7 @@ import Yesod.Request
 import Yesod.Widget
 import Yesod.Message
 
-import Language.Haskell.TH.Syntax
+import Control.Monad.Logger
-import qualified Language.Haskell.TH.Syntax as TH
-import Data.Text (Text)
-
-logTH :: LogLevel -> Q Exp
-logTH level =
-    [|messageLoggerHandler $(qLocation >>= liftLoc) $(TH.lift level)|]
-  where
-    liftLoc :: Loc -> Q Exp
-    liftLoc (Loc a b c d e) = [|Loc $(TH.lift a) $(TH.lift b) $(TH.lift c) $(TH.lift d) $(TH.lift e)|]
-
--- | Generates a function that takes a 'Text' and logs a 'LevelDebug' message. Usage:
---
--- > $(logDebug) "This is a debug log message"
-logDebug :: Q Exp
-logDebug = logTH LevelDebug
-
--- | See 'logDebug'
-logInfo :: Q Exp
-logInfo = logTH LevelInfo
--- | See 'logDebug'
-logWarn :: Q Exp
-logWarn = logTH LevelWarn
--- | See 'logDebug'
-logError :: Q Exp
-logError = logTH LevelError
-
--- | Generates a function that takes a 'Text' and logs a 'LevelOther' message. Usage:
---
--- > $(logOther "My new level") "This is a log message"
-logOther :: Text -> Q Exp
-logOther = logTH . LevelOther
 
 -- | Return an 'Unauthorized' value, with the given i18n message.
 unauthorizedI :: RenderMessage master msg => msg -> GHandler sub master AuthResult

yesod-core/Yesod/Dispatch.hs

@@ -28,7 +28,7 @@ module Yesod.Dispatch
     , WaiSubsite (..)
     ) where
 
-import Data.Functor   ((<$>))
+import Control.Applicative ((<$>), (<*>))
 import Prelude hiding (exp)
 import Yesod.Internal.Core
 import Yesod.Handler hiding (lift)
@@ -53,6 +53,7 @@ import Network.HTTP.Types (status301)
 import Yesod.Routes.TH
 import Yesod.Content (chooseRep)
 import Yesod.Routes.Parse
+import System.Log.FastLogger (Logger)
 
 type Texts = [Text]
 
@@ -60,7 +61,7 @@ type Texts = [Text]
 -- is used for creating sites, /not/ subsites. See 'mkYesodSub' for the latter.
 -- Use 'parseRoutes' to create the 'Resource's.
 mkYesod :: String -- ^ name of the argument datatype
-        -> [Resource String]
+        -> [ResourceTree String]
         -> Q [Dec]
 mkYesod name = fmap (uncurry (++)) . mkYesodGeneral name [] [] False
 
@@ -71,7 +72,7 @@ mkYesod name = fmap (uncurry (++)) . mkYesodGeneral name [] [] False
 -- be embedded in other sites.
 mkYesodSub :: String -- ^ name of the argument datatype
            -> Cxt
-           -> [Resource String]
+           -> [ResourceTree String]
            -> Q [Dec]
 mkYesodSub name clazzes =
     fmap (uncurry (++)) . mkYesodGeneral name' rest clazzes True
@@ -82,28 +83,28 @@ mkYesodSub name clazzes =
 -- your handlers elsewhere. For example, this is the only way to break up a
 -- monolithic file into smaller parts. Use this function, paired with
 -- 'mkYesodDispatch', to do just that.
-mkYesodData :: String -> [Resource String] -> Q [Dec]
+mkYesodData :: String -> [ResourceTree String] -> Q [Dec]
 mkYesodData name res = mkYesodDataGeneral name [] False res
 
-mkYesodSubData :: String -> Cxt -> [Resource String] -> Q [Dec]
+mkYesodSubData :: String -> Cxt -> [ResourceTree String] -> Q [Dec]
 mkYesodSubData name clazzes res = mkYesodDataGeneral name clazzes True res
 
-mkYesodDataGeneral :: String -> Cxt -> Bool -> [Resource String] -> Q [Dec]
+mkYesodDataGeneral :: String -> Cxt -> Bool -> [ResourceTree String] -> Q [Dec]
 mkYesodDataGeneral name clazzes isSub res = do
     let (name':rest) = words name
     (x, _) <- mkYesodGeneral name' rest clazzes isSub res
     let rname = mkName $ "resources" ++ name
     eres <- lift res
-    let y = [ SigD rname $ ListT `AppT` (ConT ''Resource `AppT` ConT ''String)
+    let y = [ SigD rname $ ListT `AppT` (ConT ''ResourceTree `AppT` ConT ''String)
             , FunD rname [Clause [] (NormalB eres) []]
             ]
     return $ x ++ y
 
 -- | See 'mkYesodData'.
-mkYesodDispatch :: String -> [Resource String] -> Q [Dec]
+mkYesodDispatch :: String -> [ResourceTree String] -> Q [Dec]
 mkYesodDispatch name = fmap snd . mkYesodGeneral name [] [] False
 
-mkYesodSubDispatch :: String -> Cxt -> [Resource String] -> Q [Dec]
+mkYesodSubDispatch :: String -> Cxt -> [ResourceTree String] -> Q [Dec]
 mkYesodSubDispatch name clazzes = fmap snd . mkYesodGeneral name' rest clazzes True 
   where (name':rest) = words name
 
@@ -111,7 +112,7 @@ mkYesodGeneral :: String -- ^ foundation type
                -> [String]
                -> Cxt -- ^ classes
                -> Bool -- ^ is subsite?
-               -> [Resource String]
+               -> [ResourceTree String]
                -> Q ([Dec], [Dec])
 mkYesodGeneral name args clazzes isSub resS = do
     let args' = map mkName args
@@ -119,7 +120,13 @@ mkYesodGeneral name args clazzes isSub resS = do
     let res = map (fmap parseType) resS
     renderRouteDec <- mkRenderRouteInstance arg res
 
-    disp <- mkDispatchClause [|yesodRunner|] [|yesodDispatch|] [|fmap chooseRep|] res
+    let logger = mkName "logger"
+    Clause pat body decs <- mkDispatchClause
+        [|yesodRunner $(return $ VarE logger)|]
+        [|yesodDispatch $(return $ VarE logger)|]
+        [|fmap chooseRep|]
+        res
+    let disp = Clause (VarP logger : pat) body decs
     let master = mkName "master"
     let ctx = if isSub
                 then ClassP (mkName "Yesod") [VarT master] : clazzes
@@ -130,7 +137,7 @@ mkYesodGeneral name args clazzes isSub resS = do
     let yesodDispatch' =
             InstanceD ctx ytyp [FunD (mkName "yesodDispatch") [disp]]
 
-    return (renderRouteDec : masterTypSyns, [yesodDispatch'])
+    return (renderRouteDec ++ masterTypSyns, [yesodDispatch'])
   where
     name' = mkName name
     masterTypSyns
@@ -160,23 +167,24 @@ toWaiApp y = gzip (gzipSettings y) . autohead <$> toWaiAppPlain y
 toWaiAppPlain :: ( Yesod master
                  , YesodDispatch master master
                  ) => master -> IO W.Application
-toWaiAppPlain a = toWaiApp' a <$> makeSessionBackend a
+toWaiAppPlain a = toWaiApp' a <$> getLogger a <*> makeSessionBackend a
 
 
 toWaiApp' :: ( Yesod master
              , YesodDispatch master master
              )
           => master
+          -> Logger
           -> Maybe (SessionBackend master)
           -> W.Application
-toWaiApp' y sb env =
+toWaiApp' y logger sb env =
     case cleanPath y $ W.pathInfo env of
         Left pieces -> sendRedirect y pieces env
         Right pieces ->
-            yesodDispatch y y id app404 handler405 method pieces sb env
+            yesodDispatch logger y y id app404 handler405 method pieces sb env
   where
-    app404 = yesodRunner notFound y y Nothing id
+    app404 = yesodRunner logger notFound y y Nothing id
-    handler405 route = yesodRunner badMethod y y (Just route) id
+    handler405 route = yesodRunner logger badMethod y y (Just route) id
     method = decodeUtf8With lenientDecode $ W.requestMethod env
 
 sendRedirect :: Yesod master => master -> [Text] -> W.Application
@@ -202,4 +210,4 @@ instance RenderRoute WaiSubsite where
     renderRoute (WaiSubsiteRoute ps qs) = (ps, qs)
 
 instance YesodDispatch WaiSubsite master where
-    yesodDispatch _master (WaiSubsite app) _tomaster _404 _405 _method _pieces _session = app
+    yesodDispatch _logger _master (WaiSubsite app) _tomaster _404 _405 _method _pieces _session = app

yesod-core/Yesod/Handler.hs

@@ -76,6 +76,7 @@ module Yesod.Handler
     , setSession
     , setSessionBS
     , deleteSession
+    , clearSession
       -- ** Ultimate destination
     , setUltDest
     , setUltDestCurrent
@@ -94,6 +95,7 @@ module Yesod.Handler
     , newIdent
       -- * Lifting
     , MonadLift (..)
+    , handlerToIO
       -- * i18n
     , getMessageRender
       -- * Per-request caching
@@ -137,7 +139,7 @@ import qualified Network.Wai as W
 import qualified Network.HTTP.Types as H
 
 import Text.Hamlet
-import qualified Text.Blaze.Renderer.Text
+import qualified Text.Blaze.Html.Renderer.Text as RenderText
 import qualified Data.Text as T
 import Data.Text.Encoding (encodeUtf8, decodeUtf8With)
 import Data.Text.Encoding.Error (lenientDecode)
@@ -145,22 +147,28 @@ import qualified Data.Text.Lazy as TL
 
 import qualified Data.Map as Map
 import qualified Data.ByteString as S
+import qualified Data.ByteString.Lazy as L
 import Network.Wai.Parse (parseHttpAccept)
 
 import Yesod.Content
-import Data.Maybe (fromMaybe)
+import Data.Maybe (fromMaybe, mapMaybe)
 import Web.Cookie (SetCookie (..), renderSetCookie)
 import Control.Arrow ((***))
 import qualified Network.Wai.Parse as NWP
 import Data.Monoid (mappend, mempty, Endo (..))
 import qualified Data.ByteString.Char8 as S8
+import Data.ByteString (ByteString)
 import Data.CaseInsensitive (CI)
 import qualified Data.CaseInsensitive as CI
-import Blaze.ByteString.Builder (toByteString)
+import Blaze.ByteString.Builder (toByteString, toLazyByteString, fromLazyByteString)
 import Data.Text (Text)
 import Yesod.Message (RenderMessage (..))
 
-import Text.Blaze (toHtml, preEscapedText)
+import Text.Blaze.Html (toHtml, preEscapedToMarkup)
+#define preEscapedText preEscapedToMarkup
+
+import System.Log.FastLogger
+import Control.Monad.Logger
 
 import qualified Yesod.Internal.Cache as Cache
 import Yesod.Internal.Cache (mkCacheKey, CacheKey)
@@ -171,6 +179,8 @@ import Control.Monad.Trans.Control
 import Control.Monad.Trans.Resource
 import Control.Monad.Base
 import Yesod.Routes.Class
+import Data.Word (Word64)
+import Language.Haskell.TH.Syntax (Loc)
 
 class YesodSubRoute s y where
     fromSubRoute :: s -> y -> Route s -> Route y
@@ -183,6 +193,8 @@ data HandlerData sub master = HandlerData
     , handlerRender   :: Route master -> [(Text, Text)] -> Text
     , handlerToMaster :: Route sub -> Route master
     , handlerState    :: I.IORef GHState
+    , handlerUpload   :: Word64 -> FileUpload
+    , handlerLog      :: Loc -> LogSource -> LogLevel -> LogStr -> IO ()
     }
 
 handlerSubData :: (Route sub -> Route master)
@@ -312,22 +324,43 @@ hcError = liftIO . throwIO . HCError
 
 runRequestBody :: GHandler s m RequestBodyContents
 runRequestBody = do
+    hd <- ask
+    let getUpload = handlerUpload hd
+        len = reqBodySize $ handlerRequest hd
+        upload = getUpload len
     x <- get
     case ghsRBC x of
         Just rbc -> return rbc
         Nothing -> do
             rr <- waiRequest
-            rbc <- lift $ rbHelper rr
+            rbc <- lift $ rbHelper upload rr
             put x { ghsRBC = Just rbc }
             return rbc
 
-rbHelper :: W.Request -> ResourceT IO RequestBodyContents
+rbHelper :: FileUpload -> W.Request -> ResourceT IO RequestBodyContents
-rbHelper req =
+rbHelper upload =
-    (map fix1 *** map fix2) <$> (NWP.parseRequestBody NWP.lbsBackEnd req)
+    case upload of
+        FileUploadMemory s -> rbHelper' s mkFileInfoLBS
+        FileUploadDisk s -> rbHelper' s mkFileInfoFile
+        FileUploadSource s -> rbHelper' s mkFileInfoSource
+
+rbHelper' :: NWP.BackEnd x
+          -> (Text -> Text -> x -> FileInfo)
+          -> W.Request
+          -> ResourceT IO ([(Text, Text)], [(Text, FileInfo)])
+rbHelper' backend mkFI req =
+    (map fix1 *** mapMaybe fix2) <$> (NWP.parseRequestBody backend req)
   where
     fix1 = go *** go
-    fix2 (x, NWP.FileInfo a b c) =
+    fix2 (x, NWP.FileInfo a' b c)
-        (go x, FileInfo (go a) (go b) c)
+        | S.null a = Nothing
+        | otherwise = Just (go x, mkFI (go a) (go b) c)
+      where
+        a
+            | S.length a' < 2 = a'
+            | S8.head a' == '"' && S8.last a' == '"' = S.tail $ S.init a'
+            | S8.head a' == '\'' && S8.last a' == '\'' = S.tail $ S.init a'
+            | otherwise = a'
     go = decodeUtf8With lenientDecode
 
 -- | Get the sub application argument.
@@ -359,6 +392,75 @@ getCurrentRoute = handlerRoute `liftM` ask
 getRouteToMaster :: GHandler sub master (Route sub -> Route master)
 getRouteToMaster = handlerToMaster `liftM` ask
 
+
+-- | Returns a function that runs 'GHandler' actions inside @IO@.
+--
+-- Sometimes you want to run an inner 'GHandler' action outside
+-- the control flow of an HTTP request (on the outer 'GHandler'
+-- action).  For example, you may want to spawn a new thread:
+--
+-- @
+-- getFooR :: Handler RepHtml
+-- getFooR = do
+--   runInnerHandler <- handlerToIO
+--   liftIO $ forkIO $ runInnerHandler $ do
+--     /Code here runs inside GHandler but on a new thread./
+--     /This is the inner GHandler./
+--     ...
+--   /Code here runs inside the request's control flow./
+--   /This is the outer GHandler./
+--   ...
+-- @
+--
+-- Another use case for this function is creating a stream of
+-- server-sent events using 'GHandler' actions (see
+-- @yesod-eventsource@).
+--
+-- Most of the environment from the outer 'GHandler' is preserved
+-- on the inner 'GHandler', however:
+--
+--  * The request body is cleared (otherwise it would be very
+--  difficult to prevent huge memory leaks).
+--
+--  * The cache is cleared (see 'CacheKey').
+--
+-- Changes to the response made inside the inner 'GHandler' are
+-- ignored (e.g., session variables, cookies, response headers).
+-- This allows the inner 'GHandler' to outlive the outer
+-- 'GHandler' (e.g., on the @forkIO@ example above, a response
+-- may be sent to the client without killing the new thread).
+handlerToIO :: MonadIO m => GHandler sub master (GHandler sub master a -> m a)
+handlerToIO =
+  GHandler $ \oldHandlerData -> do
+    -- Let go of the request body, cache and response headers.
+    let oldReq    = handlerRequest oldHandlerData
+        oldWaiReq = reqWaiRequest oldReq
+        newWaiReq = oldWaiReq { W.requestBody = mempty }
+        newReq    = oldReq { reqWaiRequest = newWaiReq
+                           , reqBodySize   = 0 }
+        clearedOldHandlerData =
+          oldHandlerData { handlerRequest = err "handlerRequest never here"
+                         , handlerState   = err "handlerState never here" }
+            where
+              err :: String -> a
+              err = error . ("handlerToIO: clearedOldHandlerData/" ++)
+    newState <- liftIO $ do
+      oldState <- I.readIORef (handlerState oldHandlerData)
+      return $ oldState { ghsRBC = Nothing
+                        , ghsIdent = 1
+                        , ghsCache = mempty
+                        , ghsHeaders = mempty }
+
+    -- Return GHandler running function.
+    return $ \(GHandler f) -> liftIO $ do
+      -- The state IORef needs to be created here, otherwise it
+      -- will be shared by different invocations of this function.
+      newStateIORef <- I.newIORef newState
+      runResourceT $ f clearedOldHandlerData
+                         { handlerRequest = newReq
+                         , handlerState   = newStateIORef }
+
+
 -- | Function used internally by Yesod in the process of converting a
 -- 'GHandler' into an 'W.Application'. Should not be needed by users.
 runHandler :: HasReps c
@@ -368,8 +470,10 @@ runHandler :: HasReps c
            -> (Route sub -> Route master)
            -> master
            -> sub
+           -> (Word64 -> FileUpload)
+           -> (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
            -> YesodApp
-runHandler handler mrender sroute tomr master sub =
+runHandler handler mrender sroute tomr master sub upload log' =
   YesodApp $ \eh rr cts initSession -> do
     let toErrorHandler e =
             case fromException e of
@@ -390,6 +494,8 @@ runHandler handler mrender sroute tomr master sub =
             , handlerRender = mrender
             , handlerToMaster = tomr
             , handlerState = istate
+            , handlerUpload = upload
+            , handlerLog = log'
             }
     contents' <- catch (fmap Right $ unGHandler handler hd)
         (\e -> return $ Left $ maybe (HCError $ toErrorHandler e) id
@@ -410,7 +516,10 @@ runHandler handler mrender sroute tomr master sub =
     case contents of
         HCContent status a -> do
             (ct, c) <- liftIO $ a cts
-            return $ YARPlain status (appEndo headers []) ct c finalSession
+            ec' <- liftIO $ evaluateContent c
+            case ec' of
+                Left e -> handleError e
+                Right c' -> return $ YARPlain status (appEndo headers []) ct c' finalSession
         HCError e -> handleError e
         HCRedirect status loc -> do
             let hs = Header "Location" (encodeUtf8 loc) : appEndo headers []
@@ -430,6 +539,15 @@ runHandler handler mrender sroute tomr master sub =
                 finalSession
         HCWai r -> return $ YARWai r
 
+evaluateContent :: Content -> IO (Either ErrorResponse Content)
+evaluateContent (ContentBuilder b mlen) = Control.Exception.handle f $ do
+    let lbs = toLazyByteString b
+    L.length lbs `seq` return (Right $ ContentBuilder (fromLazyByteString lbs) mlen)
+  where
+    f :: SomeException -> IO (Either ErrorResponse Content)
+    f = return . Left . InternalError . T.pack . show
+evaluateContent c = return (Right c)
+
 safeEh :: ErrorResponse -> YesodApp
 safeEh er = YesodApp $ \_ _ _ session -> do
     liftIO $ hPutStrLn stderr $ "Error handler errored out: " ++ show er
@@ -527,7 +645,7 @@ msgKey = "_MSG"
 --
 -- See 'getMessage'.
 setMessage :: Html -> GHandler sub master ()
-setMessage = setSession msgKey . T.concat . TL.toChunks . Text.Blaze.Renderer.Text.renderHtml
+setMessage = setSession msgKey . T.concat . TL.toChunks . RenderText.renderHtml
 
 -- | Sets a message in the user's session.
 --
@@ -639,7 +757,7 @@ getExpires m = do
 --
 -- Note: although the value used for key and path is 'Text', you should only
 -- use ASCII values to be HTTP compliant.
-deleteCookie :: Text -- ^ key 
+deleteCookie :: Text -- ^ key
              -> Text -- ^ path
              -> GHandler sub master ()
 deleteCookie a = addHeader . DeleteCookie (encodeUtf8 a) . encodeUtf8
@@ -700,6 +818,12 @@ setSessionBS k = modify . modSession . Map.insert k
 deleteSession :: Text -> GHandler sub master ()
 deleteSession = modify . modSession . Map.delete
 
+-- | Clear all session variables.
+--
+-- Since: 1.0.1
+clearSession :: GHandler sub master ()
+clearSession = modify $ \x -> x { ghsSession = Map.empty }
+
 modSession :: (SessionMap -> SessionMap) -> GHState -> GHState
 modSession f x = x { ghsSession = f $ ghsSession x }
 
@@ -756,6 +880,8 @@ getSession = liftM ghsSession get
 handlerToYAR :: (HasReps a, HasReps b)
              => master -- ^ master site foundation
              -> sub    -- ^ sub site foundation
+             -> (Word64 -> FileUpload)
+             -> (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
              -> (Route sub -> Route master)
              -> (Route master -> [(Text, Text)] -> Text) -- route renderer
              -> (ErrorResponse -> GHandler sub master a)
@@ -764,28 +890,31 @@ handlerToYAR :: (HasReps a, HasReps b)
              -> SessionMap
              -> GHandler sub master b
              -> ResourceT IO YesodAppResult
-handlerToYAR y s toMasterRoute render errorHandler rr murl sessionMap h =
+handlerToYAR y s upload log' toMasterRoute render errorHandler rr murl sessionMap h =
     unYesodApp ya eh' rr types sessionMap
   where
-    ya = runHandler h render murl toMasterRoute y s
+    ya = runHandler h render murl toMasterRoute y s upload log'
-    eh' er = runHandler (errorHandler' er) render murl toMasterRoute y s
+    eh' er = runHandler (errorHandler' er) render murl toMasterRoute y s upload log'
     types = httpAccept $ reqWaiRequest rr
     errorHandler' = localNoCurrent . errorHandler
 
-yarToResponse :: YesodAppResult -> [(CI H.Ascii, H.Ascii)] -> W.Response
+yarToResponse :: YesodAppResult -> [(CI ByteString, ByteString)] -> W.Response
 yarToResponse (YARWai a) _ = a
 yarToResponse (YARPlain s hs _ c _) extraHeaders =
-    case c of
+    go c
-        ContentBuilder b mlen ->
-            let hs' = maybe finalHeaders finalHeaders' mlen
-             in W.ResponseBuilder s hs' b
-        ContentFile fp p -> W.ResponseFile s finalHeaders fp p
-        ContentSource body -> W.ResponseSource s finalHeaders body
   where
     finalHeaders = extraHeaders ++ map headerToPair hs
     finalHeaders' len = ("Content-Length", S8.pack $ show len)
                       : finalHeaders
 
+    go (ContentBuilder b mlen) =
+        W.ResponseBuilder s hs' b
+      where
+        hs' = maybe finalHeaders finalHeaders' mlen
+    go (ContentFile fp p) = W.ResponseFile s finalHeaders fp p
+    go (ContentSource body) = W.ResponseSource s finalHeaders body
+    go (ContentDontEvaluate c') = go c'
+
 httpAccept :: W.Request -> [ContentType]
 httpAccept = parseHttpAccept
            . fromMaybe mempty
@@ -794,7 +923,7 @@ httpAccept = parseHttpAccept
 
 -- | Convert Header to a key/value pair.
 headerToPair :: Header
-             -> (CI H.Ascii, H.Ascii)
+             -> (CI ByteString, ByteString)
 headerToPair (AddCookie sc) =
     ("Set-Cookie", toByteString $ renderSetCookie $ sc)
 headerToPair (DeleteCookie key path) =
@@ -826,6 +955,7 @@ redirectToPost :: RedirectUrl master url => url -> GHandler sub master a
 redirectToPost url = do
     urlText <- toTextUrl url
     hamletToRepHtml [hamlet|
+$newline never
 $doctype 5
 
 <html>
@@ -916,7 +1046,17 @@ instance MonadUnsafeIO (GHandler sub master) where
 instance MonadThrow (GHandler sub master) where
     monadThrow = liftIO . throwIO
 instance MonadResource (GHandler sub master) where
+#if MIN_VERSION_resourcet(0,4,0)
+    liftResourceT = lift . liftResourceT
+#else
     allocate a = lift . allocate a
     register = lift . register
     release = lift . release
     resourceMask = lift . resourceMask
+#endif
+
+instance MonadLogger (GHandler sub master) where
+    monadLoggerLog a c d = monadLoggerLogSource a "" c d
+    monadLoggerLogSource a b c d = do
+        hd <- ask
+        liftIO $ handlerLog hd a b c (toLogStr d)

yesod-core/Yesod/Internal.hs

@@ -4,6 +4,8 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE DeriveDataTypeable #-}
 -- | Normal users should never need access to these.
+--
+-- Note that no guarantees of API stability are provided on this module. Use at your own risk.
 module Yesod.Internal
     ( -- * Error responses
       ErrorResponse (..)
@@ -24,11 +26,11 @@ module Yesod.Internal
     , runUniqueList
     , toUnique
       -- * Names
-    , sessionName
     , tokenKey
     ) where
 
-import Text.Hamlet (HtmlUrl, hamlet, Html)
+import Text.Hamlet (HtmlUrl, Html)
+import Text.Blaze.Html (toHtml)
 import Text.Julius (JavascriptUrl)
 import Data.Monoid (Monoid (..), Last)
 import Data.List (nub)
@@ -42,8 +44,8 @@ import qualified Network.HTTP.Types as H
 import Data.String (IsString)
 import qualified Data.Map as Map
 import Data.Text.Lazy.Builder (Builder)
-import Network.HTTP.Types (Ascii)
 import Web.Cookie (SetCookie (..))
+import Data.ByteString (ByteString)
 
 -- | Responses to indicate some form of an error occurred. These are different
 -- from 'SpecialResponse' in that they allow for custom error pages.
@@ -60,8 +62,8 @@ instance Exception ErrorResponse
 -- | Headers to be added to a 'Result'.
 data Header =
     AddCookie SetCookie
-    | DeleteCookie Ascii Ascii
+    | DeleteCookie ByteString ByteString
-    | Header Ascii Ascii
+    | Header ByteString ByteString
     deriving (Eq, Show)
 
 langKey :: IsString a => a
@@ -70,10 +72,8 @@ langKey = "_LANG"
 data Location url = Local url | Remote Text
     deriving (Show, Eq)
 locationToHtmlUrl :: Location url -> HtmlUrl url
-locationToHtmlUrl (Local url) = [hamlet|\@{url}
+locationToHtmlUrl (Local url) render = toHtml $ render url []
-|]
+locationToHtmlUrl (Remote s) _ = toHtml s
-locationToHtmlUrl (Remote s) = [hamlet|\#{s}
-|]
 
 newtype UniqueList x = UniqueList ([x] -> [x])
 instance Monoid (UniqueList x) where
@@ -98,19 +98,17 @@ newtype Body url = Body (HtmlUrl url)
 tokenKey :: IsString a => a
 tokenKey = "_TOKEN"
 
-sessionName :: IsString a => a
-sessionName = "_SESSION"
-
 type CssBuilderUrl a = (a -> [(Text, Text)] -> Text) -> Builder
 
 data GWData a = GWData
-    !(Body a)
+    { gwdBody :: !(Body a)
-    !(Last Title)
+    , gwdTitle :: !(Last Title)
-    !(UniqueList (Script a))
+    , gwdScripts :: !(UniqueList (Script a))
-    !(UniqueList (Stylesheet a))
+    , gwdStylesheets :: !(UniqueList (Stylesheet a))
-    !(Map.Map (Maybe Text) (CssBuilderUrl a)) -- media type
+    , gwdCss :: !(Map.Map (Maybe Text) (CssBuilderUrl a)) -- media type
-    !(Maybe (JavascriptUrl a))
+    , gwdJavascript :: !(Maybe (JavascriptUrl a))
-    !(Head a)
+    , gwdHead :: !(Head a)
+    }
 instance Monoid (GWData a) where
     mempty = GWData mempty mempty mempty mempty mempty mempty mempty
     mappend (GWData a1 a2 a3 a4 a5 a6 a7)

yesod-core/Yesod/Internal/Core.hs

@@ -20,11 +20,6 @@ module Yesod.Internal.Core
     , defaultErrorHandler
       -- * Data types
     , AuthResult (..)
-      -- * Logging
-    , LogLevel (..)
-    , formatLogMessage
-    , fileLocationToString
-    , messageLoggerHandler
       -- * Sessions
     , SessionBackend (..)
     , defaultClientSessionBackend
@@ -40,6 +35,8 @@ module Yesod.Internal.Core
     , yesodRender
     , resolveApproot
     , Approot (..)
+    , FileUpload (..)
+    , runFakeHandler
     ) where
 
 import Yesod.Content
@@ -47,6 +44,7 @@ import Yesod.Handler hiding (lift, getExpires)
 
 import Yesod.Routes.Class
 
+import Data.Word (Word64)
 import Control.Arrow ((***))
 import Control.Monad (forM)
 import Yesod.Widget
@@ -58,6 +56,7 @@ import Yesod.Internal.Request
 import qualified Web.ClientSession as CS
 import qualified Data.ByteString.Char8 as S8
 import qualified Data.ByteString.Lazy as L
+import qualified Data.IORef as I
 import Data.Monoid
 import Text.Hamlet
 import Text.Julius
@@ -67,6 +66,7 @@ import Data.Text.Lazy.Builder (toLazyText)
 import Data.Text.Lazy.Encoding (encodeUtf8)
 import Data.Maybe (fromMaybe, isJust)
 import Control.Monad.IO.Class (MonadIO (liftIO))
+import Control.Monad.Trans.Resource (runResourceT)
 import Web.Cookie (parseCookies)
 import qualified Data.Map as Map
 import Data.Time
@@ -80,17 +80,19 @@ import Blaze.ByteString.Builder.Char.Utf8 (fromText)
 import Data.List (foldl')
 import qualified Network.HTTP.Types as H
 import Web.Cookie (SetCookie (..))
-import qualified Data.Text.Lazy as TL
+import Language.Haskell.TH.Syntax (Loc (..))
-import qualified Data.Text.Lazy.IO
+import Text.Blaze (preEscapedToMarkup)
-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
 import Network.Wai.Middleware.Gzip (GzipSettings, def)
+import Network.Wai.Parse (tempFileBackEnd, lbsBackEnd)
 import qualified Paths_yesod_core
 import Data.Version (showVersion)
+import System.Log.FastLogger (Logger, mkLogger, loggerDate, LogStr (..), loggerPutStr)
+import Control.Monad.Logger (LogLevel (LevelInfo, LevelOther), LogSource)
+import System.Log.FastLogger.Date (ZonedDate)
+import System.IO (stdout)
 
 yesodVersion :: String
 yesodVersion = showVersion Paths_yesod_core.version
@@ -100,7 +102,8 @@ yesodVersion = showVersion Paths_yesod_core.version
 class YesodDispatch sub master where
     yesodDispatch
         :: Yesod master
-        => master
+        => Logger
+        -> master
         -> sub
         -> (Route sub -> Route master)
         -> (Maybe (SessionBackend master) -> W.Application) -- ^ 404 handler
@@ -111,7 +114,8 @@ class YesodDispatch sub master where
         -> W.Application
 
     yesodRunner :: Yesod master
-                => GHandler sub master ChooseRep
+                => Logger
+                -> GHandler sub master ChooseRep
                 -> master
                 -> sub
                 -> Maybe (Route sub)
@@ -161,6 +165,7 @@ class RenderRoute a => Yesod a where
         p <- widgetToPageContent w
         mmsg <- getMessage
         hamletToRepHtml [hamlet|
+$newline never
 $doctype 5
 
 <html>
@@ -222,10 +227,13 @@ $doctype 5
     cleanPath :: a -> [Text] -> Either [Text] [Text]
     cleanPath _ s =
         if corrected == s
-            then Right s
+            then Right $ map dropDash s
             else Left corrected
       where
         corrected = filter (not . T.null) s
+        dropDash t
+            | T.all (== '-') t = T.drop 1 t
+            | otherwise = t
 
     -- | Builds an absolute URL by concatenating the application root with the
     -- pieces of a path and a query string, if any.
@@ -235,12 +243,16 @@ $doctype 5
              -> [T.Text] -- ^ path pieces
              -> [(T.Text, T.Text)] -- ^ query string
              -> Builder
-    joinPath _ ar pieces' qs' = fromText ar `mappend` encodePath pieces qs
+    joinPath _ ar pieces' qs' =
+        fromText ar `mappend` encodePath pieces qs
       where
-        pieces = if null pieces' then [""] else pieces'
+        pieces = if null pieces' then [""] else map addDash pieces'
         qs = map (TE.encodeUtf8 *** go) qs'
         go "" = Nothing
         go x = Just $ TE.encodeUtf8 x
+        addDash t
+            | T.all (== '-') t = T.cons '-' t
+            | otherwise = t
 
     -- | This function is used to store some static content to be served as an
     -- external file. The most common case of this is stashing CSS and
@@ -281,21 +293,41 @@ $doctype 5
     cookieDomain _ = Nothing
 
     -- | Maximum allowed length of the request body, in bytes.
-    maximumContentLength :: a -> Maybe (Route a) -> Int
+    --
+    -- Default: 2 megabytes.
+    maximumContentLength :: a -> Maybe (Route a) -> Word64
     maximumContentLength _ _ = 2 * 1024 * 1024 -- 2 megabytes
 
-    -- | Send a message to the log. By default, prints to stdout.
+    -- | Returns a @Logger@ to use for log messages.
+    --
+    -- Default: Sends to stdout and automatically flushes on each write.
+    getLogger :: a -> IO Logger
+    getLogger _ = mkLogger True stdout
+
+    -- | Send a message to the @Logger@ provided by @getLogger@.
+    --
+    -- Note: This method is no longer used. Instead, you should override
+    -- 'messageLoggerSource'.
     messageLogger :: a
+                  -> Logger
                   -> Loc -- ^ position in source code
                   -> LogLevel
-                  -> Text -- ^ message
+                  -> LogStr -- ^ message
                   -> IO ()
-    messageLogger a loc level msg =
+    messageLogger a logger loc = messageLoggerSource a logger loc ""
-        if level < logLevel a
+
-            then return ()
+    -- | Send a message to the @Logger@ provided by @getLogger@.
-            else
+    messageLoggerSource :: a
-                formatLogMessage loc level msg >>=
+                        -> Logger
-                Data.Text.Lazy.IO.putStrLn
+                        -> Loc -- ^ position in source code
+                        -> LogSource
+                        -> LogLevel
+                        -> LogStr -- ^ message
+                        -> IO ()
+    messageLoggerSource a logger loc source level msg =
+        if shouldLog a source level
+            then formatLogMessage (loggerDate logger) loc source level msg >>= loggerPutStr logger
+            else return ()
 
     -- | The logging level in place for this application. Any messages below
     -- this level will simply be ignored.
@@ -323,38 +355,50 @@ $doctype 5
         key <- CS.getKey CS.defaultKeyFile
         return $ Just $ clientSessionBackend key 120
 
+    -- | How to store uploaded files.
+    --
+    -- Default: Whe nthe request body is greater than 50kb, store in a temp
+    -- file. Otherwise, store in memory.
+    fileUpload :: a
+               -> Word64 -- ^ request body size
+               -> FileUpload
+    fileUpload _ size
+        | size > 50000 = FileUploadDisk tempFileBackEnd
+        | otherwise = FileUploadMemory lbsBackEnd
 
-messageLoggerHandler :: Yesod m
+    -- | Should we log the given log source/level combination.
-                     => Loc -> LogLevel -> Text -> GHandler s m ()
+    --
-messageLoggerHandler loc level msg = do
+    -- Default: Logs everything at or above 'logLevel'
-    y <- getYesod
+    shouldLog :: a -> LogSource -> LogLevel -> Bool
-    liftIO $ messageLogger y loc level msg
+    shouldLog a _ level = level >= logLevel a
 
-data LogLevel = LevelDebug | LevelInfo | LevelWarn | LevelError | LevelOther Text
+{-# DEPRECATED messageLogger "Please use messageLoggerSource (since yesod-core 1.1.2)" #-}
-    deriving (Eq, Show, Read, Ord)
 
-instance Lift LogLevel where
+formatLogMessage :: IO ZonedDate
-    lift LevelDebug = [|LevelDebug|]
+                 -> Loc
-    lift LevelInfo = [|LevelInfo|]
+                 -> LogSource
-    lift LevelWarn = [|LevelWarn|]
-    lift LevelError = [|LevelError|]
-    lift (LevelOther x) = [|LevelOther $ T.pack $(lift $ T.unpack x)|]
-
-formatLogMessage :: Loc
                  -> LogLevel
-                 -> Text -- ^ message
+                 -> LogStr -- ^ message
-                 -> IO TL.Text
+                 -> IO [LogStr]
-formatLogMessage loc level msg = do
+formatLogMessage getdate loc src level msg = do
-    now <- getCurrentTime
+    now <- getdate
-    return $ TB.toLazyText $
+    return
-        TB.fromText (T.pack $ show now)
+        [ LB now
-        `mappend` TB.fromText " ["
+        , LB " ["
-        `mappend` TB.fromText (T.pack $ drop 5 $ show level)
+        , LS $
-        `mappend` TB.fromText "] "
+            case level of
-        `mappend` TB.fromText msg
+                LevelOther t -> T.unpack t
-        `mappend` TB.fromText " @("
+                _ -> drop 5 $ show level
-        `mappend` TB.fromText (T.pack $ fileLocationToString loc)
+        , LS $
-        `mappend` TB.fromText ") "
+            if T.null src
+                then ""
+                else "#" ++ T.unpack src
+        , LB "] "
+        , msg
+        , LB " @("
+        , LS $ fileLocationToString loc
+        , LB ")\n"
+        ]
 
 -- taken from file-location package
 -- turn the TH Loc loaction information into a human readable string
@@ -367,31 +411,26 @@ fileLocationToString loc = (loc_package loc) ++ ':' : (loc_module loc) ++
     char = show . snd . loc_start
 
 defaultYesodRunner :: Yesod master
-                   => GHandler sub master ChooseRep
+                   => Logger
+                   -> GHandler sub master ChooseRep
                    -> master
                    -> sub
                    -> Maybe (Route sub)
                    -> (Route sub -> Route master)
                    -> Maybe (SessionBackend master)
                    -> W.Application
-defaultYesodRunner _ master _ murl toMaster _ req
+defaultYesodRunner logger handler master sub murl toMasterRoute msb req
-    | maximumContentLength master (fmap toMaster murl) < len =
+  | maximumContentLength master (fmap toMasterRoute murl) < len =
         return $ W.responseLBS
             (H.Status 413 "Too Large")
             [("Content-Type", "text/plain")]
             "Request body too large to be processed."
-  where
+  | otherwise = do
-    len = fromMaybe 0 $ lookup "content-length" (W.requestHeaders req) >>= readMay
-    readMay s =
-        case reads $ S8.unpack s of
-            [] -> Nothing
-            (x, _):_ -> Just x
-defaultYesodRunner handler master sub murl toMasterRoute msb req = do
     now <- liftIO getCurrentTime
     let dontSaveSession _ _ = return []
     (session, saveSession) <- liftIO $
         maybe (return ([], dontSaveSession)) (\sb -> sbLoadSession sb master req now) msb
-    rr <- liftIO $ parseWaiRequest req session (isJust msb)
+    rr <- liftIO $ parseWaiRequest req session (isJust msb) len
     let h = {-# SCC "h" #-} do
           case murl of
             Nothing -> handler
@@ -411,7 +450,8 @@ defaultYesodRunner handler master sub murl toMasterRoute msb req = do
                 handler
     let sessionMap = Map.fromList . filter ((/=) tokenKey . fst) $ session
     let ra = resolveApproot master req
-    yar <- handlerToYAR master sub toMasterRoute
+    let log' = messageLoggerSource master logger
+    yar <- handlerToYAR master sub (fileUpload master) log' toMasterRoute
         (yesodRender master ra) errorHandler rr murl sessionMap h
     extraHeaders <- case yar of
         (YARPlain _ _ ct _ newSess) -> do
@@ -423,6 +463,12 @@ defaultYesodRunner handler master sub murl toMasterRoute msb req = do
             return $ ("Content-Type", ct) : map headerToPair sessionHeaders
         _ -> return []
     return $ yarToResponse yar extraHeaders
+  where
+    len = fromMaybe 0 $ lookup "content-length" (W.requestHeaders req) >>= readMay
+    readMay s =
+        case reads $ S8.unpack s of
+            [] -> Nothing
+            (x, _):_ -> Just x
 
 data AuthResult = Authorized | AuthenticationRequired | Unauthorized Text
     deriving (Eq, Show, Read)
@@ -469,18 +515,21 @@ defaultErrorHandler NotFound = do
     let path' = TE.decodeUtf8With TEE.lenientDecode $ W.rawPathInfo r
     applyLayout' "Not Found"
         [hamlet|
+$newline never
 <h1>Not Found
 <p>#{path'}
 |]
 defaultErrorHandler (PermissionDenied msg) =
     applyLayout' "Permission Denied"
         [hamlet|
+$newline never
 <h1>Permission denied
 <p>#{msg}
 |]
 defaultErrorHandler (InvalidArgs ia) =
     applyLayout' "Invalid Arguments"
         [hamlet|
+$newline never
 <h1>Invalid Arguments
 <ul>
     $forall msg <- ia
@@ -489,12 +538,14 @@ defaultErrorHandler (InvalidArgs ia) =
 defaultErrorHandler (InternalError e) =
     applyLayout' "Internal Server Error"
         [hamlet|
+$newline never
 <h1>Internal Server Error
 <p>#{e}
 |]
 defaultErrorHandler (BadMethod m) =
     applyLayout' "Bad Method"
         [hamlet|
+$newline never
 <h1>Method Not Supported
 <p>Method "#{S8.unpack m}" not supported
 |]
@@ -512,7 +563,7 @@ maybeAuthorized r isWrite = do
     return $ if x == Authorized then Just r else Nothing
 
 jsToHtml :: Javascript -> Html
-jsToHtml (Javascript b) = preEscapedLazyText $ toLazyText b
+jsToHtml (Javascript b) = preEscapedToMarkup $ toLazyText b
 
 jelper :: JavascriptUrl url -> HtmlUrl url
 jelper = fmap jsToHtml
@@ -540,7 +591,7 @@ widgetToPageContent w = do
            $ encodeUtf8 rendered
         return (mmedia,
             case x of
-                Nothing -> Left $ preEscapedLazyText rendered
+                Nothing -> Left $ preEscapedToMarkup rendered
                 Just y -> Right $ either id (uncurry render) y)
     jsLoc <-
         case jscript of
@@ -554,6 +605,7 @@ widgetToPageContent w = do
     -- the asynchronous loader means your page doesn't have to wait for all the js to load
     let (mcomplete, asyncScripts) = asyncHelper render scripts jscript jsLoc
         regularScriptLoad = [hamlet|
+$newline never
 $forall s <- scripts
     ^{mkScriptTag s}
 $maybe j <- jscript
@@ -564,6 +616,7 @@ $maybe j <- jscript
 |]
 
         headAll = [hamlet|
+$newline never
 \^{head'}
 $forall s <- stylesheets
     ^{mkLinkTag s}
@@ -586,6 +639,7 @@ $case jsLoader master
       ^{regularScriptLoad}
 |]
     let bodyScript = [hamlet|
+$newline never
 ^{body}
 ^{regularScriptLoad}
 |]
@@ -632,6 +686,7 @@ jsonArray = unsafeLazyByteString . encode . Array . Vector.fromList . map String
 loadJsYepnope :: Yesod master => Either Text (Route master) -> [Text] -> Maybe (HtmlUrl (Route master)) -> (HtmlUrl (Route master))
 loadJsYepnope eyn scripts mcomplete =
   [hamlet|
+$newline never
     $maybe yn <- left eyn
         <script src=#{yn}>
     $maybe yn <- right eyn
@@ -699,17 +754,18 @@ clientSessionBackend :: Yesod master
                      -> Int -- ^ Inactive session valitity in minutes
                      -> SessionBackend master
 clientSessionBackend key timeout = SessionBackend
-    { sbLoadSession = loadClientSession key timeout
+    { sbLoadSession = loadClientSession key timeout "_SESSION"
     }
 
 loadClientSession :: Yesod master
                   => CS.Key
-                  -> Int
+                  -> Int -- ^ timeout
+                  -> S8.ByteString -- ^ session name
                   -> master
                   -> W.Request
                   -> UTCTime
                   -> IO (BackendSession, SaveSession)
-loadClientSession key timeout master req now = return (sess, save)
+loadClientSession key timeout sessionName master req now = return (sess, save)
   where
     sess = fromMaybe [] $ do
       raw <- lookup "Cookie" $ W.requestHeaders req
@@ -717,7 +773,7 @@ loadClientSession key timeout master req now = return (sess, save)
       let host = "" -- fixme, properly lock sessions to client address
       decodeClientSession key now host val
     save sess' now' = do
-      -- fixme should we be caching this?
+      -- We should never cache the IV!  Be careful!
       iv <- liftIO CS.randomIV
       return [AddCookie def
           { setCookieName = sessionName
@@ -732,3 +788,82 @@ loadClientSession key timeout master req now = return (sess, save)
           expires = fromIntegral (timeout * 60) `addUTCTime` now'
           sessionVal iv = encodeClientSession key iv expires host sess'
 
+
+-- | Run a 'GHandler' completely outside of Yesod.  This
+-- function comes with many caveats and you shouldn't use it
+-- unless you fully understand what it's doing and how it works.
+--
+-- As of now, there's only one reason to use this function at
+-- all: in order to run unit tests of functions inside 'GHandler'
+-- but that aren't easily testable with a full HTTP request.
+-- Even so, it's better to use @wai-test@ or @yesod-test@ instead
+-- of using this function.
+--
+-- This function will create a fake HTTP request (both @wai@'s
+-- 'W.Request' and @yesod@'s 'Request') and feed it to the
+-- @GHandler@.  The only useful information the @GHandler@ may
+-- get from the request is the session map, which you must supply
+-- as argument to @runFakeHandler@.  All other fields contain
+-- fake information, which means that they can be accessed but
+-- won't have any useful information.  The response of the
+-- @GHandler@ is completely ignored, including changes to the
+-- session, cookies or headers.  We only return you the
+-- @GHandler@'s return value.
+runFakeHandler :: (Yesod master, MonadIO m) =>
+                  SessionMap
+               -> (master -> Logger)
+               -> master
+               -> GHandler master master a
+               -> m (Either ErrorResponse a)
+runFakeHandler fakeSessionMap logger master handler = liftIO $ do
+  ret <- I.newIORef (Left $ InternalError "runFakeHandler: no result")
+  let handler' = do liftIO . I.writeIORef ret . Right =<< handler
+                    return ()
+  let YesodApp yapp =
+        runHandler
+          handler'
+          (yesodRender master "")
+          Nothing
+          id
+          master
+          master
+          (fileUpload master)
+          (messageLoggerSource master $ logger master)
+      errHandler err =
+        YesodApp $ \_ _ _ session -> do
+          liftIO $ I.writeIORef ret (Left err)
+          return $ YARPlain
+                     H.status500
+                     []
+                     typePlain
+                     (toContent ("runFakeHandler: errHandler" :: S8.ByteString))
+                     session
+      fakeWaiRequest =
+        W.Request
+          { W.requestMethod  = "POST"
+          , W.httpVersion    = H.http11
+          , W.rawPathInfo    = "/runFakeHandler/pathInfo"
+          , W.rawQueryString = ""
+          , W.serverName     = "runFakeHandler-serverName"
+          , W.serverPort     = 80
+          , W.requestHeaders = []
+          , W.isSecure       = False
+          , W.remoteHost     = error "runFakeHandler-remoteHost"
+          , W.pathInfo       = ["runFakeHandler", "pathInfo"]
+          , W.queryString    = []
+          , W.requestBody    = mempty
+          , W.vault          = mempty
+          }
+      fakeRequest =
+        Request
+          { reqGetParams  = []
+          , reqCookies    = []
+          , reqWaiRequest = fakeWaiRequest
+          , reqLangs      = []
+          , reqToken      = Just "NaN" -- not a nonce =)
+          , reqBodySize   = 0
+          }
+      fakeContentType = []
+  _ <- runResourceT $ yapp errHandler fakeRequest fakeContentType fakeSessionMap
+  I.readIORef ret
+{-# WARNING runFakeHandler "Usually you should *not* use runFakeHandler unless you really understand how it works and why you need it." #-}

yesod-core/Yesod/Internal/Request.hs

@@ -4,7 +4,15 @@ module Yesod.Internal.Request
     ( parseWaiRequest
     , Request (..)
     , RequestBodyContents
-    , FileInfo (..)
+    , FileInfo
+    , fileName
+    , fileContentType
+    , fileSource
+    , fileMove
+    , mkFileInfoLBS
+    , mkFileInfoFile
+    , mkFileInfoSource
+    , FileUpload (..)
     -- The below are exported for testing.
     , randomString
     , parseWaiRequest'
@@ -28,6 +36,10 @@ import qualified Data.Set as Set
 import qualified Data.Text as T
 import Data.Text.Encoding (decodeUtf8With)
 import Data.Text.Encoding.Error (lenientDecode)
+import Data.Conduit
+import Data.Conduit.List (sourceList)
+import Data.Conduit.Binary (sourceFile, sinkFile)
+import Data.Word (Word64)
 
 -- | The parsed request information.
 data Request = Request
@@ -38,23 +50,27 @@ data Request = Request
     , reqLangs :: [Text]
       -- | A random, session-specific token used to prevent CSRF attacks.
     , reqToken :: Maybe Text
+      -- | Size of the request body.
+    , reqBodySize :: Word64
     }
 
 parseWaiRequest :: W.Request
                 -> [(Text, ByteString)] -- ^ session
                 -> Bool
+                -> Word64
                 -> IO Request
-parseWaiRequest env session' useToken =
+parseWaiRequest env session' useToken bodySize =
-    parseWaiRequest' env session' useToken <$> newStdGen
+    parseWaiRequest' env session' useToken bodySize <$> newStdGen
 
 parseWaiRequest' :: RandomGen g
                  => W.Request
                  -> [(Text, ByteString)] -- ^ session
                  -> Bool
+                 -> Word64
                  -> g
                  -> Request
-parseWaiRequest' env session' useToken gen = 
+parseWaiRequest' env session' useToken bodySize gen =
-    Request gets'' cookies' env langs'' token
+    Request gets'' cookies' env langs'' token bodySize
   where
     gets' = queryToQueryText $ W.queryString env
     gets'' = map (second $ fromMaybe "") gets'
@@ -116,6 +132,19 @@ type RequestBodyContents =
 data FileInfo = FileInfo
     { fileName :: Text
     , fileContentType :: Text
-    , fileContent :: L.ByteString
+    , fileSource :: Source (ResourceT IO) ByteString
+    , fileMove :: FilePath -> IO ()
     }
-    deriving (Eq, Show)
+
+mkFileInfoLBS :: Text -> Text -> L.ByteString -> FileInfo
+mkFileInfoLBS name ct lbs = FileInfo name ct (sourceList $ L.toChunks lbs) (\fp -> L.writeFile fp lbs)
+
+mkFileInfoFile :: Text -> Text -> FilePath -> FileInfo
+mkFileInfoFile name ct fp = FileInfo name ct (sourceFile fp) (\dst -> runResourceT $ sourceFile fp $$ sinkFile dst)
+
+mkFileInfoSource :: Text -> Text -> Source (ResourceT IO) ByteString -> FileInfo
+mkFileInfoSource name ct src = FileInfo name ct src (\dst -> runResourceT $ src $$ sinkFile dst)
+
+data FileUpload = FileUploadMemory (NWP.BackEnd L.ByteString)
+                | FileUploadDisk (NWP.BackEnd FilePath)
+                | FileUploadSource (NWP.BackEnd (Source (ResourceT IO) ByteString))

yesod-core/Yesod/Internal/Session.hs

@@ -21,9 +21,9 @@ import qualified Network.Wai as W
 
 type BackendSession = [(Text, S8.ByteString)]
 
-type SaveSession = BackendSession -> -- ^ The session contents after running the handler
+type SaveSession = BackendSession    -- ^ The session contents after running the handler
-                   UTCTime ->        -- ^ current time
+                -> UTCTime           -- ^ current time
-                   IO [Header]
+                -> IO [Header]
 
 newtype SessionBackend master = SessionBackend
     { sbLoadSession :: master

yesod-core/Yesod/Logger.hs

@@ -1,138 +0,0 @@
-{-# LANGUAGE BangPatterns #-}
-module Yesod.Logger
-    ( Logger
-    , handle
-    , developmentLogger, productionLogger
-    , defaultDevelopmentLogger, defaultProductionLogger
-    , toProduction
-    , flushLogger
-    , logText
-    , logLazyText
-    , logString
-    , logBS
-    , logMsg
-    , formatLogText
-    , timed
-    -- * Deprecated
-    , makeLoggerWithHandle
-    , makeDefaultLogger
-    ) where
-
-import System.IO (Handle, stdout, hFlush)
-import Data.ByteString (ByteString)
-import Data.ByteString.Char8 (pack)
-import Data.ByteString.Lazy (toChunks)
-import qualified Data.Text.Lazy as TL
-import Data.Text (Text)
-import Data.Text.Encoding (encodeUtf8)
-import qualified Data.Text.Lazy.Encoding as TLE
-import System.Log.FastLogger
-import Network.Wai.Logger.Date (DateRef, dateInit, getDate)
-
--- for timed logging
-import Data.Time (getCurrentTime, diffUTCTime)
-import Control.Monad.IO.Class (MonadIO, liftIO)
-import Text.Printf (printf)
-import Data.Text (unpack)
-
--- for formatter
-import Language.Haskell.TH.Syntax (Loc)
-import Yesod.Core (LogLevel, fileLocationToString)
-
-data Logger = Logger {
-    loggerLogFun   :: [LogStr] -> IO ()
-  , loggerHandle   :: Handle
-  , loggerDateRef  :: DateRef
-  }
-
-handle :: Logger -> Handle
-handle = loggerHandle
-
-flushLogger :: Logger -> IO ()
-flushLogger = hFlush . loggerHandle
-
-makeDefaultLogger :: IO Logger
-makeDefaultLogger = defaultDevelopmentLogger
-{-# DEPRECATED makeDefaultLogger "Use defaultProductionLogger or defaultDevelopmentLogger instead" #-}
-
-makeLoggerWithHandle, developmentLogger, productionLogger :: Handle -> IO Logger
-makeLoggerWithHandle = productionLogger
-{-# DEPRECATED makeLoggerWithHandle "Use productionLogger or developmentLogger instead" #-}
-
--- | uses stdout handle
-defaultProductionLogger, defaultDevelopmentLogger :: IO Logger
-defaultProductionLogger = productionLogger stdout
-defaultDevelopmentLogger = developmentLogger stdout
-
-
-productionLogger h = mkLogger h (handleToLogFun h)
--- | a development logger gets automatically flushed
-developmentLogger h = mkLogger h (\bs -> (handleToLogFun h) bs >> hFlush h)
-
-mkLogger :: Handle -> ([LogStr] -> IO ()) -> IO Logger
-mkLogger h logFun = do
-    initHandle h
-    dateInit >>= return . Logger logFun h
-
--- convert (a development) logger to production settings
-toProduction :: Logger -> Logger
-toProduction (Logger _ h d) = Logger (handleToLogFun h) h d
-
-handleToLogFun :: Handle -> ([LogStr] -> IO ())
-handleToLogFun = hPutLogStr
-
-logMsg :: Logger -> [LogStr] -> IO ()
-logMsg = hPutLogStr . handle
-
-logLazyText :: Logger -> TL.Text -> IO ()
-logLazyText logger msg = loggerLogFun logger $
-  map LB (toChunks $ TLE.encodeUtf8 msg) ++ [newLine]
-
-logText :: Logger -> Text -> IO ()
-logText logger = logBS logger . encodeUtf8
-
-logBS :: Logger -> ByteString -> IO ()
-logBS logger msg = loggerLogFun logger $ [LB msg, newLine]
-
-logString :: Logger -> String -> IO ()
-logString logger msg = loggerLogFun logger $ [LS msg, newLine]
-
-formatLogText :: Logger -> Loc -> LogLevel -> Text -> IO [LogStr]
-formatLogText logger loc level msg = formatLogMsg logger loc level (toLB msg)
-
-toLB :: Text -> LogStr
-toLB = LB . encodeUtf8
-
-formatLogMsg :: Logger -> Loc -> LogLevel -> LogStr -> IO [LogStr]
-formatLogMsg logger loc level msg = do
-    date <- liftIO $ getDate $ loggerDateRef logger
-    return
-        [ LB date
-        , LB $ pack" ["
-        , LS (drop 5 $ show level)
-        , LB $ pack "] "
-        , msg
-        , LB $ pack " @("
-        , LS (fileLocationToString loc)
-        , LB $ pack ") "
-        ]
-
-newLine :: LogStr
-newLine = LB $ pack "\n"
-
--- | Execute a monadic action and log the duration
---
-timed :: MonadIO m
-      => Logger  -- ^ Logger
-      -> Text  -- ^ Message
-      -> m a     -- ^ Action
-      -> m a     -- ^ Timed and logged action
-timed logger msg action = do
-    start <- liftIO getCurrentTime
-    !result <- action
-    stop <- liftIO getCurrentTime
-    let diff = fromEnum $ diffUTCTime stop start
-        ms = diff `div` 10 ^ (9 :: Int)
-        formatted = printf "  [%4dms] %s" ms (unpack msg)
-    liftIO $ logString logger formatted
-    return result

yesod-core/Yesod/Request.hs

@@ -16,7 +16,11 @@ module Yesod.Request
       -- * Request datatype
       RequestBodyContents
     , Request (..)
-    , FileInfo (..)
+    , FileInfo
+    , fileName
+    , fileContentType
+    , fileSource
+    , fileMove
       -- * Convenience functions
     , languages
       -- * Lookup parameters
@@ -51,6 +55,9 @@ import Data.Text (Text)
 --
 -- * Accept-Language HTTP header.
 --
+-- Yesod will seek the first language from the returned list matched with languages supporting by your application. This language will be used to render i18n templates.
+-- If a matching language is not found the default language will be used.
+--
 -- This is handled by parseWaiRequest (not exposed).
 languages :: GHandler s m [Text]
 languages = reqLangs `liftM` getRequest

yesod-core/Yesod/Widget.hs

@@ -43,6 +43,7 @@ module Yesod.Widget
     , addStylesheetRemote
     , addStylesheetRemoteAttrs
     , addStylesheetEither
+    , CssBuilder (..)
       -- ** Javascript
     , addJulius
     , addJuliusBody
@@ -53,6 +54,7 @@ module Yesod.Widget
     , addScriptEither
       -- * Internal
     , unGWidget
+    , whamletFileWithSettings
     ) where
 
 import Data.Monoid
@@ -79,12 +81,18 @@ import Language.Haskell.TH.Syntax (Q, Exp (InfixE, VarE, LamE, AppE), Pat (VarP)
 import Control.Monad.Trans.Control (MonadBaseControl (..))
 import Control.Exception (throwIO)
 import qualified Text.Hamlet as NP
-import Data.Text.Lazy.Builder (fromLazyText)
+import Data.Text.Lazy.Builder (fromLazyText, Builder)
-import Text.Blaze (toHtml, preEscapedLazyText)
+import Text.Blaze.Html (toHtml, preEscapedToMarkup)
+import qualified Data.Text.Lazy as TL
 import Control.Monad.Base (MonadBase (liftBase))
 import Control.Arrow (first)
 import Control.Monad.Trans.Resource
 
+import Control.Monad.Logger
+
+preEscapedLazyText :: TL.Text -> Html
+preEscapedLazyText = preEscapedToMarkup
+
 -- | A generic widget, allowing specification of both the subsite and master
 -- site datatypes. While this is simply a @WriterT@, we define a newtype for
 -- better error messages.
@@ -113,10 +121,21 @@ class ToWidget sub master a where
 
 type RY master = Route master -> [(Text, Text)] -> Text
 
+-- | Newtype wrapper allowing injection of arbitrary content into CSS.
+--
+-- Usage:
+--
+-- > toWidget $ CssBuilder "p { color: red }"
+--
+-- Since: 1.1.3
+newtype CssBuilder = CssBuilder { unCssBuilder :: Builder }
+
 instance render ~ RY master => ToWidget sub master (render -> Html) where
     toWidget x = tell $ GWData (Body x) mempty mempty mempty mempty mempty mempty
 instance render ~ RY master => ToWidget sub master (render -> Css) where
-    toWidget x = tell $ GWData mempty mempty mempty mempty (Map.singleton Nothing $ \r -> fromLazyText $ renderCss $ x r) mempty mempty
+    toWidget x = toWidget $ CssBuilder . fromLazyText . renderCss . x
+instance render ~ RY master => ToWidget sub master (render -> CssBuilder) where
+    toWidget x = tell $ GWData mempty mempty mempty mempty (Map.singleton Nothing $ unCssBuilder . x) mempty mempty
 instance render ~ RY master => ToWidget sub master (render -> Javascript) where
     toWidget x = tell $ GWData mempty mempty mempty mempty mempty (Just x) mempty
 instance (sub' ~ sub, master' ~ master) => ToWidget sub' master' (GWidget sub master ()) where
@@ -141,8 +160,10 @@ instance render ~ RY master => ToWidgetHead sub master (render -> Html) where
     toWidgetHead = tell . GWData mempty mempty mempty mempty mempty mempty . Head
 instance render ~ RY master => ToWidgetHead sub master (render -> Css) where
     toWidgetHead = toWidget
-instance render ~ RY master => ToWidgetHead sub master (render -> Javascript) where
+instance render ~ RY master => ToWidgetHead sub master (render -> CssBuilder) where
     toWidgetHead = toWidget
+instance render ~ RY master => ToWidgetHead sub master (render -> Javascript) where
+    toWidgetHead j = toWidgetHead $ \r -> H.script $ preEscapedLazyText $ renderJavascriptUrl r j
 instance ToWidgetHead sub master Html where
     toWidgetHead = toWidgetHead . const
 
@@ -161,6 +182,7 @@ setTitleI msg = do
 {-# DEPRECATED addHamletHead, addHtmlHead "Use toWidgetHead instead" #-}
 {-# DEPRECATED addHamlet, addHtml, addCassius, addLucius, addJulius "Use toWidget instead" #-}
 {-# DEPRECATED addJuliusBody "Use toWidgetBody instead" #-}
+{-# DEPRECATED addWidget "addWidget can be omitted" #-}
 
 -- | Add a 'Hamlet' to the head tag.
 addHamletHead :: HtmlUrl (Route master) -> GWidget sub master ()
@@ -262,6 +284,9 @@ whamlet = NP.hamletWithSettings rules NP.defaultHamletSettings
 whamletFile :: FilePath -> Q Exp
 whamletFile = NP.hamletFileWithSettings rules NP.defaultHamletSettings
 
+whamletFileWithSettings :: NP.HamletSettings -> FilePath -> Q Exp
+whamletFileWithSettings = NP.hamletFileWithSettings rules
+
 rules :: Q NP.HamletRules
 rules = do
     ah <- [|toWidget|]
@@ -330,7 +355,15 @@ instance MonadUnsafeIO (GWidget sub master) where
 instance MonadThrow (GWidget sub master) where
     monadThrow = liftIO . throwIO
 instance MonadResource (GWidget sub master) where
+#if MIN_VERSION_resourcet(0,4,0)
+    liftResourceT = lift . liftResourceT
+#else
     allocate a = lift . allocate a
     register = lift . register
     release = lift . release
     resourceMask = lift . resourceMask
+#endif
+
+instance MonadLogger (GWidget sub master) where
+    monadLoggerLog a b = lift . monadLoggerLog a b
+    monadLoggerLogSource a b c = lift . monadLoggerLogSource a b c

yesod-core/helloworld.hs

@@ -5,7 +5,7 @@
 import Yesod.Core
 import Control.Monad.IO.Class (liftIO)
 import Network.Wai.Handler.Warp (run)
-import Data.Text (unpack)
+import Data.Text (unpack, pack)
 import Text.Julius (julius)
 
 data Subsite = Subsite String
@@ -22,13 +22,13 @@ getSubRootR = do
     Subsite s <- getYesodSub
     tm <- getRouteToMaster
     render <- getUrlRender
-    $(logDebug) "I'm in SubRootR"
+    $logDebug "I'm in SubRootR"
     return $ RepPlain $ toContent $ "Hello Sub World: " ++ s ++ ". " ++ unpack (render (tm SubRootR))
 
 handleSubMultiR :: Yesod m => Strings -> GHandler Subsite m RepPlain
 handleSubMultiR x = do
     Subsite y <- getYesodSub
-    $(logInfo) "In SubMultiR"
+    $logInfo "In SubMultiR"
     return . RepPlain . toContent . show $ (x, y)
 
 data HelloWorld = HelloWorld { getSubsite :: String -> Subsite }
@@ -38,11 +38,12 @@ mkYesod "HelloWorld" [parseRoutes|
 |]
 instance Yesod HelloWorld where
     addStaticContent a b c = do
-        liftIO $ print (a, b, c)
+        $logInfo $ pack $ show (a, b, c)
         return Nothing
 
 getRootR = do
     $(logOther "HAHAHA") "Here I am"
+    $logOtherS "source" "level" "message"
     defaultLayout $ do
         addScriptRemote "https://ajax.googleapis.com/ajax/libs/jquery/1.6.4/jquery.min.js"
         toWidget [julius|$(function(){$("#mypara").css("color", "red")});|]

yesod-core/test.hs

@@ -2,4 +2,4 @@ import Test.Hspec
 import qualified YesodCoreTest
 
 main :: IO ()
-main = hspecX $ descriptions $ YesodCoreTest.specs
+main = hspec YesodCoreTest.specs

yesod-core/test/YesodCoreTest.hs

@@ -15,18 +15,17 @@ import qualified YesodCoreTest.JsLoader as JsLoader
 
 import Test.Hspec
 
-specs :: [Specs]
+specs :: Spec
-specs = 
+specs = do
-    [ cleanPathTest
+      cleanPathTest
-    , exceptionsTest
+      exceptionsTest
-    , widgetTest
+      widgetTest
-    , mediaTest
+      mediaTest
-    , linksTest
+      linksTest
-    , noOverloadedTest
+      noOverloadedTest
-    , internalRequestTest
+      internalRequestTest
-    , errorHandlingTest
+      errorHandlingTest
-    , cacheTest
+      cacheTest
-    , WaiSubsite.specs
+      WaiSubsite.specs
-    , Redirect.specs
+      Redirect.specs
-    , JsLoader.specs
+      JsLoader.specs
-    ]

yesod-core/test/YesodCoreTest/Cache.hs

@@ -35,11 +35,10 @@ getRootR = do
     Nothing <- cacheLookup key
     return ()
 
-cacheTest :: [Spec]
+cacheTest :: Spec
 cacheTest =
-  describe "Test.Cache"
+  describe "Test.Cache" $ do
-    [ it "works" works
+      it "works" works
-    ]
 
 runner :: Session () -> IO ()
 runner f = toWaiApp C >>= runSession f

yesod-core/test/YesodCoreTest/CleanPath.hs

@@ -14,6 +14,11 @@ import Network.HTTP.Types (status200, decodePathSegments)
 
 import qualified Data.ByteString.Lazy.Char8 as L8
 import qualified Data.Text as TS
+import qualified Data.Text.Encoding as TE
+import Control.Arrow ((***))
+import Network.HTTP.Types (encodePath)
+import Data.Monoid (mappend)
+import Blaze.ByteString.Builder.Char.Utf8 (fromText)
 
 data Subsite = Subsite
 
@@ -26,7 +31,7 @@ instance RenderRoute Subsite where
     renderRoute (SubsiteRoute x) = (x, [])
 
 instance YesodDispatch Subsite master where
-    yesodDispatch _ _ _ _ _ _ pieces _ _ = return $ responseLBS
+    yesodDispatch _ _ _ _ _ _ _ pieces _ _ = return $ responseLBS
         status200
         [ ("Content-Type", "SUBSITE")
         ] $ L8.pack $ show pieces
@@ -52,6 +57,14 @@ instance Yesod Y where
       where
         corrected = filter (not . TS.null) s
 
+    joinPath Y ar pieces' qs' =
+        fromText ar `mappend` encodePath pieces qs
+      where
+        pieces = if null pieces' then [""] else pieces'
+        qs = map (TE.encodeUtf8 *** go) qs'
+        go "" = Nothing
+        go x = Just $ TE.encodeUtf8 x
+
 getFooR :: Handler RepPlain
 getFooR = return $ RepPlain "foo"
 
@@ -62,17 +75,16 @@ getBarR, getPlainR :: Handler RepPlain
 getBarR = return $ RepPlain "bar"
 getPlainR = return $ RepPlain "plain"
 
-cleanPathTest :: [Spec]
+cleanPathTest :: Spec
 cleanPathTest =
-  describe "Test.CleanPath"
+  describe "Test.CleanPath" $ do
-    [ it "remove trailing slash" removeTrailingSlash
+      it "remove trailing slash" removeTrailingSlash
-    , it "noTrailingSlash" noTrailingSlash
+      it "noTrailingSlash" noTrailingSlash
-    , it "add trailing slash" addTrailingSlash
+      it "add trailing slash" addTrailingSlash
-    , it "has trailing slash" hasTrailingSlash
+      it "has trailing slash" hasTrailingSlash
-    , it "/foo/something" fooSomething
+      it "/foo/something" fooSomething
-    , it "subsite dispatch" subsiteDispatch
+      it "subsite dispatch" subsiteDispatch
-    , it "redirect with query string" redQueryString
+      it "redirect with query string" redQueryString
-    ]
 
 runner :: Session () -> IO ()
 runner f = toWaiApp Y >>= runSession f

yesod-core/test/YesodCoreTest/ErrorHandling.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 module YesodCoreTest.ErrorHandling
     ( errorHandlingTest
     , Widget
@@ -11,6 +12,7 @@ import Network.Wai.Test
 import Text.Hamlet (hamlet)
 import qualified Data.ByteString.Lazy as L
 import qualified Data.ByteString.Char8 as S8
+import Control.Exception (SomeException, try)
 
 data App = App
 
@@ -19,12 +21,16 @@ mkYesod "App" [parseRoutes|
 /not_found      NotFoundR POST
 /first_thing    FirstThingR POST
 /after_runRequestBody AfterRunRequestBodyR POST
+/error-in-body ErrorInBodyR GET
+/error-in-body-noeval ErrorInBodyNoEvalR GET
 |]
 
 instance Yesod App
 
 getHomeR :: Handler RepHtml
-getHomeR = defaultLayout $ toWidget [hamlet|
+getHomeR = do
+    $logDebug "Testing logging"
+    defaultLayout $ toWidget [hamlet|
 $doctype 5
 
 <html>
@@ -49,15 +55,24 @@ postFirstThingR = do
 
 postAfterRunRequestBodyR = do
    x <- runRequestBody
-   _ <- error $ show x
+   _ <- error $ show $ fst x
    getHomeR
 
-errorHandlingTest :: [Spec]
+getErrorInBodyR :: Handler RepHtml
-errorHandlingTest = describe "Test.ErrorHandling"
+getErrorInBodyR = do
-    [ it "says not found" caseNotFound
+    let foo = error "error in body 19328" :: String
-    , it "says 'There was an error' before runRequestBody" caseBefore
+    defaultLayout [whamlet|#{foo}|]
-    , it "says 'There was an error' after runRequestBody" caseAfter
+
-    ]
+getErrorInBodyNoEvalR :: Handler (DontFullyEvaluate RepHtml)
+getErrorInBodyNoEvalR = fmap DontFullyEvaluate getErrorInBodyR
+
+errorHandlingTest :: Spec
+errorHandlingTest = describe "Test.ErrorHandling" $ do
+      it "says not found" caseNotFound
+      it "says 'There was an error' before runRequestBody" caseBefore
+      it "says 'There was an error' after runRequestBody" caseAfter
+      it "error in body == 500" caseErrorInBody
+      it "error in body, no eval == 200" caseErrorInBodyNoEval
 
 runner :: Session () -> IO ()
 runner f = toWaiApp App >>= runSession f
@@ -96,3 +111,18 @@ caseAfter = runner $ do
         }
     assertStatus 500 res
     assertBodyContains "bin12345" res
+
+caseErrorInBody :: IO ()
+caseErrorInBody = runner $ do
+    res <- request defaultRequest { pathInfo = ["error-in-body"] }
+    assertStatus 500 res
+    assertBodyContains "error in body 19328" res
+
+caseErrorInBodyNoEval :: IO ()
+caseErrorInBodyNoEval = do
+    eres <- try $ runner $ do
+        _ <- request defaultRequest { pathInfo = ["error-in-body-noeval"] }
+        return ()
+    case eres of
+        Left (_ :: SomeException) -> return ()
+        Right _ -> error "Expected an exception"

yesod-core/test/YesodCoreTest/Exceptions.hs

@@ -30,11 +30,10 @@ getRedirR = do
     setHeader "foo" "bar"
     redirectWith status301 RootR
 
-exceptionsTest :: [Spec]
+exceptionsTest :: Spec
-exceptionsTest = describe "Test.Exceptions"
+exceptionsTest = describe "Test.Exceptions" $ do
-    [ it "500" case500
+      it "500" case500
-    , it "redirect keeps headers" caseRedirect
+      it "redirect keeps headers" caseRedirect
-    ]
 
 runner :: Session () -> IO ()
 runner f = toWaiApp Y >>= runSession f

yesod-core/test/YesodCoreTest/InternalRequest.hs

@@ -10,11 +10,10 @@ import Yesod.Internal.TestApi (randomString, parseWaiRequest')
 import Yesod.Request (Request (..))
 import Test.Hspec
 
-randomStringSpecs :: [Spec]
+randomStringSpecs :: Spec
-randomStringSpecs = describe "Yesod.Internal.Request.randomString"
+randomStringSpecs = describe "Yesod.Internal.Request.randomString" $ do
-  [ it "looks reasonably random" looksRandom
+    it "looks reasonably random" looksRandom
-  , it "does not repeat itself" $ noRepeat 10 100
+    it "does not repeat itself" $ noRepeat 10 100
-  ]
 
 -- NOTE: this testcase may break on other systems/architectures if
 -- mkStdGen is not identical everywhere (is it?).
@@ -30,58 +29,56 @@ g :: StdGen
 g = error "test/YesodCoreTest/InternalRequest.g"
 
 
-tokenSpecs :: [Spec]
+tokenSpecs :: Spec
-tokenSpecs = describe "Yesod.Internal.Request.parseWaiRequest (reqToken)"
+tokenSpecs = describe "Yesod.Internal.Request.parseWaiRequest (reqToken)" $ do
-  [ it "is Nothing if sessions are disabled" noDisabledToken
+    it "is Nothing if sessions are disabled" noDisabledToken
-  , it "ignores pre-existing token if sessions are disabled" ignoreDisabledToken
+    it "ignores pre-existing token if sessions are disabled" ignoreDisabledToken
-  , it "uses preexisting token in session" useOldToken
+    it "uses preexisting token in session" useOldToken
-  , it "generates a new token for sessions without token" generateToken
+    it "generates a new token for sessions without token" generateToken
-  ]
 
 noDisabledToken :: Bool
 noDisabledToken = reqToken r == Nothing where
-  r = parseWaiRequest' defaultRequest [] False g
+  r = parseWaiRequest' defaultRequest [] False 0 g
 
 ignoreDisabledToken :: Bool
 ignoreDisabledToken = reqToken r == Nothing where
-  r = parseWaiRequest' defaultRequest [("_TOKEN", "old")] False g
+  r = parseWaiRequest' defaultRequest [("_TOKEN", "old")] False 0 g
 
 useOldToken :: Bool
 useOldToken = reqToken r == Just "old" where
-  r = parseWaiRequest' defaultRequest [("_TOKEN", "old")] True g
+  r = parseWaiRequest' defaultRequest [("_TOKEN", "old")] True 0 g
 
 generateToken :: Bool
 generateToken = reqToken r /= Nothing where
-  r = parseWaiRequest' defaultRequest [("_TOKEN", "old")] True g
+  r = parseWaiRequest' defaultRequest [("_TOKEN", "old")] True 0 g
 
 
-langSpecs :: [Spec]
+langSpecs :: Spec
-langSpecs = describe "Yesod.Internal.Request.parseWaiRequest (reqLangs)"
+langSpecs = describe "Yesod.Internal.Request.parseWaiRequest (reqLangs)" $ do
-  [ it "respects Accept-Language" respectAcceptLangs
+    it "respects Accept-Language" respectAcceptLangs
-  , it "respects sessions" respectSessionLang
+    it "respects sessions" respectSessionLang
-  , it "respects cookies" respectCookieLang
+    it "respects cookies" respectCookieLang
-  , it "respects queries" respectQueryLang
+    it "respects queries" respectQueryLang
-  , it "prioritizes correctly" prioritizeLangs
+    it "prioritizes correctly" prioritizeLangs
-  ]
 
 respectAcceptLangs :: Bool
 respectAcceptLangs = reqLangs r == ["en-US", "es", "en"] where
   r = parseWaiRequest' defaultRequest
-        { requestHeaders = [("Accept-Language", "en-US, es")] } [] False g
+        { requestHeaders = [("Accept-Language", "en-US, es")] } [] False 0 g
 
 respectSessionLang :: Bool
 respectSessionLang = reqLangs r == ["en"] where
-  r = parseWaiRequest' defaultRequest [("_LANG", "en")] False g
+  r = parseWaiRequest' defaultRequest [("_LANG", "en")] False 0 g
 
 respectCookieLang :: Bool
 respectCookieLang = reqLangs r == ["en"] where
   r = parseWaiRequest' defaultRequest
         { requestHeaders = [("Cookie", "_LANG=en")]
-        } [] False g
+        } [] False 0 g
 
 respectQueryLang :: Bool
 respectQueryLang = reqLangs r == ["en-US", "en"] where
-  r = parseWaiRequest' defaultRequest { queryString = [("_LANG", Just "en-US")] } [] False g
+  r = parseWaiRequest' defaultRequest { queryString = [("_LANG", Just "en-US")] } [] False 0 g
 
 prioritizeLangs :: Bool
 prioritizeLangs = reqLangs r == ["en-QUERY", "en-COOKIE", "en-SESSION", "en", "es"] where
@@ -90,11 +87,11 @@ prioritizeLangs = reqLangs r == ["en-QUERY", "en-COOKIE", "en-SESSION", "en", "e
                            , ("Cookie", "_LANG=en-COOKIE")
                            ]
         , queryString = [("_LANG", Just "en-QUERY")]
-        } [("_LANG", "en-SESSION")] False g
+        } [("_LANG", "en-SESSION")] False 0 g
 
 
-internalRequestTest :: [Spec]
+internalRequestTest :: Spec
-internalRequestTest = descriptions [ randomStringSpecs
+internalRequestTest = describe "Test.InternalRequestTest" $ do
-                                   , tokenSpecs
+      randomStringSpecs
-                                   , langSpecs
+      tokenSpecs
-                                   ]
+      langSpecs

yesod-core/test/YesodCoreTest/JsLoader.hs

@@ -22,20 +22,19 @@ instance Yesod H where
 getHeadR :: Handler RepHtml
 getHeadR = defaultLayout $ addScriptRemote "load.js"
 
-specs :: [Spec]
+specs :: Spec
-specs = describe "Test.JsLoader" [
+specs = describe "Test.JsLoader" $ do
     it "link from head" $ runner H $ do
       res <- request defaultRequest
       assertBody "<!DOCTYPE html>\n<html><head><title></title><script src=\"load.js\"></script></head><body></body></html>" res
 
-  , it "link from head async" $ runner HA $ do
+    it "link from head async" $ runner HA $ do
       res <- request defaultRequest
       assertBody "<!DOCTYPE html>\n<html><head><title></title><script src=\"yepnope.js\"></script><script>yepnope({load:[\"load.js\"]});</script></head><body></body></html>" res
 
-  , it "link from bottom" $ runner B $ do
+    it "link from bottom" $ runner B $ do
       res <- request defaultRequest
       assertBody "<!DOCTYPE html>\n<html><head><title></title></head><body><script src=\"load.js\"></script></body></html>" res
-  ]
 
 runner :: (YesodDispatch master master, Yesod master) => master -> Session () -> IO ()
 runner app f = toWaiApp app >>= runSession f

yesod-core/test/YesodCoreTest/Links.hs

@@ -8,11 +8,17 @@ import Test.Hspec.HUnit ()
 
 import Yesod.Core hiding (Request)
 import Text.Hamlet
+import Network.Wai
 import Network.Wai.Test
+import Data.Text (Text)
+import Control.Monad.IO.Class (liftIO)
+import Blaze.ByteString.Builder (toByteString)
 
 data Y = Y
 mkYesod "Y" [parseRoutes|
 / RootR GET
+/single/#Text TextR GET
+/multi/*Texts TextsR GET
 |]
 
 instance Yesod Y
@@ -20,10 +26,16 @@ instance Yesod Y
 getRootR :: Handler RepHtml
 getRootR = defaultLayout $ toWidget [hamlet|<a href=@{RootR}>|]
 
-linksTest :: [Spec]
+getTextR :: Text -> Handler RepHtml
-linksTest = describe "Test.Links"
+getTextR foo = defaultLayout $ toWidget [hamlet|%#{foo}%|]
-    [ it "linkToHome" case_linkToHome
+
-    ]
+getTextsR :: [Text] -> Handler RepHtml
+getTextsR foos = defaultLayout $ toWidget [hamlet|%#{show foos}%|]
+
+linksTest :: Spec
+linksTest = describe "Test.Links" $ do
+      it "linkToHome" case_linkToHome
+      it "blank path pieces" case_blanks
 
 runner :: Session () -> IO ()
 runner f = toWaiApp Y >>= runSession f
@@ -31,4 +43,26 @@ runner f = toWaiApp Y >>= runSession f
 case_linkToHome :: IO ()
 case_linkToHome = runner $ do
     res <- request defaultRequest
-    assertBody "<!DOCTYPE html>\n<html><head><title></title></head><body><a href=\"/\"></a></body></html>" res
+    assertBody "<!DOCTYPE html>\n<html><head><title></title></head><body><a href=\"/\"></a>\n</body></html>" res
+
+case_blanks :: IO ()
+case_blanks = runner $ do
+    liftIO $ do
+        let go r =
+                let (ps, qs) = renderRoute r
+                 in toByteString $ joinPath Y "" ps qs
+        (go $ TextR "-") `shouldBe` "/single/--"
+        (go $ TextR "") `shouldBe` "/single/-"
+        (go $ TextsR ["", "-", "foo", "", "bar"]) `shouldBe` "/multi/-/--/foo/-/bar"
+
+    res1 <- request defaultRequest
+        { pathInfo = ["single", "-"]
+        , rawPathInfo = "dummy1"
+        }
+    assertBody "<!DOCTYPE html>\n<html><head><title></title></head><body>%%</body></html>" res1
+
+    res2 <- request defaultRequest
+        { pathInfo = ["multi", "foo", "-", "bar"]
+        , rawPathInfo = "dummy2"
+        }
+    assertBody "<!DOCTYPE html>\n<html><head><title></title></head><body>%[&quot;foo&quot;,&quot;&quot;,&quot;bar&quot;]%</body></html>" res2

yesod-core/test/YesodCoreTest/Media.hs

@@ -49,8 +49,7 @@ caseMediaLink = runner $ do
     assertStatus 200 res
     flip assertBody res "<!DOCTYPE html>\n<html><head><title></title><link rel=\"stylesheet\" href=\"all.css\"><link rel=\"stylesheet\" media=\"screen\" href=\"screen.css\"></head><body></body></html>"
 
-mediaTest :: [Spec]
+mediaTest :: Spec
-mediaTest = describe "Test.Media"
+mediaTest = describe "Test.Media" $ do
-    [ it "media" caseMedia
+      it "media" caseMedia
-    , it "media link" caseMediaLink
+      it "media link" caseMediaLink
-    ]

yesod-core/test/YesodCoreTest/NoOverloadedStrings.hs

@@ -44,7 +44,6 @@ case_sanity = runner $ do
     res <- request defaultRequest
     assertBody mempty res
 
-noOverloadedTest :: [Spec]
+noOverloadedTest :: Spec
-noOverloadedTest = describe "Test.NoOverloadedStrings"
+noOverloadedTest = describe "Test.NoOverloadedStrings" $ do
-    [ it "sanity" case_sanity
+      it "sanity" case_sanity
-    ]

yesod-core/test/YesodCoreTest/Redirect.hs

@@ -26,34 +26,33 @@ getR303 = redirectWith H.status303 RootR
 getR307 = redirectWith H.status307 RootR
 getRRegular = redirect RootR
 
-specs :: [Spec]
+specs :: Spec
-specs = describe "Redirect" [
+specs = describe "Redirect" $ do
     it "301 redirect" $ app $ do
       res <- request defaultRequest { pathInfo = ["r301"] }
       assertStatus 301 res
       assertBodyContains "" res
 
-  , it "303 redirect" $ app $ do
+    it "303 redirect" $ app $ do
       res <- request defaultRequest { pathInfo = ["r303"] }
       assertStatus 303 res
       assertBodyContains "" res
 
-  , it "307 redirect" $ app $ do
+    it "307 redirect" $ app $ do
       res <- request defaultRequest { pathInfo = ["r307"] }
       assertStatus 307 res
       assertBodyContains "" res
 
-  , it "303 redirect for regular, HTTP 1.1" $ app $ do
+    it "303 redirect for regular, HTTP 1.1" $ app $ do
       res <- request defaultRequest {
         pathInfo = ["rregular"]
       }
       assertStatus 303 res
       assertBodyContains "" res
-  , it "302 redirect for regular, HTTP 1.0" $ app $ do
+    it "302 redirect for regular, HTTP 1.0" $ app $ do
       res <- request defaultRequest {
         pathInfo = ["rregular"]
       , httpVersion = H.http10
       }
       assertStatus 302 res
       assertBodyContains "" res
-  ]

yesod-core/test/YesodCoreTest/WaiSubsite.hs

@@ -25,15 +25,14 @@ app = yesod Y
 getRootR :: Handler ()
 getRootR = return ()
 
-specs :: [Spec]
+specs :: Spec
-specs = describe "WaiSubsite" [
+specs = describe "WaiSubsite" $ do
     it "root" $ app $ do
       res <- request defaultRequest { pathInfo = [] }
       assertStatus 200 res
       assertBodyContains "" res
 
-  , it "subsite" $ app $ do
+    it "subsite" $ app $ do
       res <- request defaultRequest { pathInfo = ["sub", "foo"] }
       assertStatus 200 res
       assertBodyContains "WAI" res
-  ]

yesod-core/test/YesodCoreTest/Widget.hs

@@ -26,6 +26,7 @@ mkYesod "Y" [parseRoutes|
 /whamlet WhamletR GET
 /towidget TowidgetR GET
 /auto AutoR GET
+/jshead JSHeadR GET
 |]
 
 instance Yesod Y where
@@ -55,12 +56,13 @@ getTowidgetR = defaultLayout $ do
     toWidget [lucius|foo{bar:baz}|]
     toWidgetHead [lucius|foo{bar:baz}|]
 
-    toWidget [hamlet|<foo>|] :: Widget
+    toWidget [hamlet|<foo>|]
     toWidgetHead [hamlet|<foo>|]
     toWidgetBody [hamlet|<foo>|]
 
 getWhamletR :: Handler RepHtml
 getWhamletR = defaultLayout [whamlet|
+$newline never
 <h1>Test
 <h2>@{WhamletR}
 <h3>_{Goodbye}
@@ -68,22 +70,29 @@ getWhamletR = defaultLayout [whamlet|
 ^{embed}
 |]
   where
-    embed = [whamlet|<h4>Embed|]
+    embed = [whamlet|
+$newline never
+<h4>Embed
+|]
 
 getAutoR :: Handler RepHtml
 getAutoR = defaultLayout [whamlet|
+$newline never
 ^{someHtml}
 |]
   where
     someHtml = [shamlet|somehtml|]
 
-widgetTest :: [Spec]
+getJSHeadR :: Handler RepHtml
-widgetTest = describe "Test.Widget"
+getJSHeadR = defaultLayout $ toWidgetHead [julius|alert("hello");|]
-    [ it "addJuliusBody" case_addJuliusBody
+
-    , it "whamlet" case_whamlet
+widgetTest :: Spec
-    , it "two letter lang codes" case_two_letter_lang
+widgetTest = describe "Test.Widget" $ do
-    , it "automatically applies toWidget" case_auto
+      it "addJuliusBody" case_addJuliusBody
-    ]
+      it "whamlet" case_whamlet
+      it "two letter lang codes" case_two_letter_lang
+      it "automatically applies toWidget" case_auto
+      it "toWidgetHead puts JS in head" case_jshead
 
 runner :: Session () -> IO ()
 runner f = toWaiApp Y >>= runSession f
@@ -116,3 +125,10 @@ case_auto = runner $ do
         , requestHeaders = [("Accept-Language", "es")]
         }
     assertBody "<!DOCTYPE html>\n<html><head><title></title></head><body>somehtml</body></html>" res
+
+case_jshead :: IO ()
+case_jshead = runner $ do
+    res <- request defaultRequest
+        { pathInfo = ["jshead"]
+        }
+    assertBody "<!DOCTYPE html>\n<html><head><title></title><script>alert(\"hello\");</script></head><body></body></html>" res

yesod-core/yesod-core.cabal

@@ -1,5 +1,5 @@
 name:            yesod-core
-version:         1.0.0
+version:         1.1.3
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>
@@ -15,78 +15,80 @@ cabal-version:   >= 1.8
 build-type:      Simple
 homepage:        http://www.yesodweb.com/
 extra-source-files:
-  test/en.msg
+  test.hs
-  test/YesodCoreTest/NoOverloadedStrings.hs
+  test/YesodCoreTest.hs
+  test/YesodCoreTest/Cache.hs
+  test/YesodCoreTest/CleanPath.hs
+  test/YesodCoreTest/ErrorHandling.hs
+  test/YesodCoreTest/Exceptions.hs
+  test/YesodCoreTest/InternalRequest.hs
+  test/YesodCoreTest/JsLoader.hs
+  test/YesodCoreTest/JsLoaderSites/Bottom.hs
+  test/YesodCoreTest/JsLoaderSites/HeadAsync.hs
+  test/YesodCoreTest/Links.hs
   test/YesodCoreTest/Media.hs
   test/YesodCoreTest/MediaData.hs
-  test/YesodCoreTest/Exceptions.hs
+  test/YesodCoreTest/NoOverloadedStrings.hs
+  test/YesodCoreTest/Redirect.hs
+  test/YesodCoreTest/WaiSubsite.hs
   test/YesodCoreTest/Widget.hs
-  test/YesodCoreTest/CleanPath.hs
+  test/YesodCoreTest/YesodTest.hs
-  test/YesodCoreTest/Links.hs
+  test/en.msg
-  test/YesodCoreTest/InternalRequest.hs
+  test/test.hs
-  test/YesodCoreTest/ErrorHandling.hs
-  test/YesodCoreTest/Cache.hs
-  test.hs
 
 flag test
   description: Build the executable to run unit tests
   default: False
 
-flag ghc7
-
 library
-    if flag(ghc7)
-        build-depends:   base              >= 4.3      && < 5
-        cpp-options:     -DGHC7
-    else
-        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
+    build-depends:   base                  >= 4.3      && < 5
-                   , yesod-routes          >= 1.0      && < 1.1
+                   , time                  >= 1.1.4
-                   , wai                   >= 1.2      && < 1.3
+                   , yesod-routes          >= 1.1      && < 1.2
-                   , wai-extra             >= 1.2      && < 1.3
+                   , wai                   >= 1.3      && < 1.4
-                   , bytestring            >= 0.9.1.4  && < 0.10
+                   , wai-extra             >= 1.3      && < 1.4
+                   , bytestring            >= 0.9.1.4
                    , text                  >= 0.7      && < 0.12
                    , template-haskell
-                   , path-pieces           >= 0.1      && < 0.2
+                   , path-pieces           >= 0.1.2    && < 0.2
-                   , hamlet                >= 1.0      && < 1.1
+                   , hamlet                >= 1.1      && < 1.2
                    , shakespeare           >= 1.0      && < 1.1
                    , shakespeare-js        >= 1.0      && < 1.1
                    , shakespeare-css       >= 1.0      && < 1.1
                    , shakespeare-i18n      >= 1.0      && < 1.1
                    , blaze-builder         >= 0.2.1.4  && < 0.4
                    , transformers          >= 0.2.2    && < 0.4
-                   , clientsession         >= 0.7.3.1  && < 0.8
+                   , clientsession         >= 0.8      && < 0.9
                    , random                >= 1.0.0.2  && < 1.1
                    , cereal                >= 0.3      && < 0.4
                    , old-locale            >= 1.0.0.2  && < 1.1
                    , failure               >= 0.2      && < 0.3
-                   , containers            >= 0.2      && < 0.5
+                   , containers            >= 0.2
                    , monad-control         >= 0.3      && < 0.4
                    , transformers-base     >= 0.4
                    , cookie                >= 0.4      && < 0.5
-                   , blaze-html            >= 0.4.1.3  && < 0.5
+                   , http-types            >= 0.7      && < 0.8
-                   , http-types            >= 0.6.5    && < 0.7
                    , case-insensitive      >= 0.2
                    , parsec                >= 2        && < 3.2
-                   , directory             >= 1        && < 1.2
+                   , directory             >= 1
-                   , vector                >= 0.9      && < 0.10
+                   , vector                >= 0.9      && < 0.11
                    , aeson                 >= 0.5
-                   , fast-logger           >= 0.0.2
+                   , fast-logger           >= 0.2
-                   , wai-logger            >= 0.0.1
+                   , monad-logger          >= 0.2.1    && < 0.3
-                   , conduit               >= 0.4      && < 0.5
+                   , conduit               >= 0.5      && < 0.6
-                   , resourcet             >= 0.3      && < 0.4
+                   , resourcet             >= 0.3      && < 0.5
-                   , lifted-base           >= 0.1      && < 0.2
+                   , lifted-base           >= 0.1
+                   , blaze-html            >= 0.5      && < 0.6
+                   , blaze-markup          >= 0.5.1    && < 0.6
+
     exposed-modules: Yesod.Content
                      Yesod.Core
                      Yesod.Dispatch
                      Yesod.Handler
-                     Yesod.Logger
                      Yesod.Request
                      Yesod.Widget
                      Yesod.Message
@@ -104,17 +106,9 @@ test-suite tests
     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:         test.hs
-    else
-        type: exitcode-stdio-1.0
-        build-depends:   base                      >= 4        && < 4.3
-        main-is:         test.hs
     cpp-options:   -DTEST
-    build-depends: hspec >= 0.8 && < 0.10
+    build-depends: base
+                  ,hspec >= 1.3 && < 1.4
                   ,wai-test
                   ,wai
                   ,yesod-core
@@ -125,8 +119,10 @@ test-suite tests
                   ,text
                   ,http-types
                   , random
+                  , blaze-builder
                   ,HUnit
                   ,QuickCheck >= 2 && < 3
+                  ,transformers
     ghc-options:     -Wall
 
 source-repository head

yesod-default/LICENSE

@@ -1,25 +1,20 @@
-The following license covers this documentation, and the source code, except
+Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/
-where otherwise indicated.
 
-Copyright 2010, Michael Snoyman. All rights reserved.
+Permission is hereby granted, free of charge, to any person obtaining
+a copy of this software and associated documentation files (the
+"Software"), to deal in the Software without restriction, including
+without limitation the rights to use, copy, modify, merge, publish,
+distribute, sublicense, and/or sell copies of the Software, and to
+permit persons to whom the Software is furnished to do so, subject to
+the following conditions:
 
-Redistribution and use in source and binary forms, with or without
+The above copyright notice and this permission notice shall be
-modification, are permitted provided that the following conditions are met:
+included in all copies or substantial portions of the Software.
 
-* Redistributions of source code must retain the above copyright notice, this
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
-  list of conditions and the following disclaimer.
+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
-
+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
-* Redistributions in binary form must reproduce the above copyright notice,
+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
-  this list of conditions and the following disclaimer in the documentation
+LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
-  and/or other materials provided with the distribution.
+OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
-
+WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
-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

@@ -85,9 +85,15 @@ fromArgs getExtra = do
                 }
     config <- loadConfig cs
 
+    env' <- getEnvironment
+    let config' =
+            case lookup "APPROOT" env' of
+                Nothing -> config
+                Just ar -> config { appRoot = T.pack ar }
+
     return $ if port args /= 0
-                then config { appPort = port args }
+                then config' { appPort = port args }
-                else config
+                else config'
 
 -- | Load your development config (when using @'DefaultEnv'@)
 loadDevelopmentConfig :: IO (AppConfig DefaultEnv ())

yesod-default/Yesod/Default/Main.hs

@@ -7,7 +7,6 @@ module Yesod.Default.Main
     ) where
 
 import Yesod.Default.Config
-import Yesod.Logger (Logger, defaultDevelopmentLogger, logString)
 import Network.Wai (Application)
 import Network.Wai.Handler.Warp
     (runSettings, defaultSettings, settingsPort, settingsHost)
@@ -26,26 +25,18 @@ import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)
 -- | Run your app, taking environment and port settings from the
 --   commandline.
 --
---   Use @'fromArgs'@ when using the provided @'DefaultEnv'@ type, or
+--   @'fromArgs'@ helps parse a custom configuration
---   @'fromArgsWith'@ when using a custom type
 --
 --   > main :: IO ()
---   > main = defaultMain fromArgs withMySite
+--   > main = defaultMain (fromArgs parseExtra) makeApplication
---
---   or
---
---   > main :: IO ()
---   > main = defaultMain (fromArgsWith customArgConfig) withMySite
 --
 defaultMain :: (Show env, Read env)
             => IO (AppConfig env extra)
-            -> (AppConfig env extra -> Logger -> IO Application)
+            -> (AppConfig env extra -> IO Application)
             -> IO ()
 defaultMain load getApp = do
     config <- load
-    logger <- defaultDevelopmentLogger
+    app <- getApp config
-    app <- getApp config logger
-    print $ appHost config
     runSettings defaultSettings
         { settingsPort = appPort config
         , settingsHost = appHost config
@@ -86,12 +77,11 @@ defaultRunner f app = do
 defaultDevelApp
     :: (Show env, Read env)
     => IO (AppConfig env extra) -- ^ A means to load your development @'AppConfig'@
-    -> (AppConfig env extra -> Logger -> IO Application) -- ^ Get your @Application@
+    -> (AppConfig env extra -> IO Application) -- ^ Get your @Application@
     -> IO (Int, Application)
 defaultDevelApp load getApp = do
     conf   <- load
-    logger <- defaultDevelopmentLogger
     let p = appPort conf
-    logString logger $ "Devel application launched: http://localhost:" ++ show p
+    putStrLn $ "Devel application launched: http://localhost:" ++ show p
-    app <- getApp conf logger
+    app <- getApp conf
     return (p, app)

yesod-default/Yesod/Default/Util.hs

@@ -7,7 +7,11 @@ module Yesod.Default.Util
     , globFile
     , widgetFileNoReload
     , widgetFileReload
-    , widgetFileJsCss
+    , TemplateLanguage (..)
+    , defaultTemplateLanguages
+    , WidgetFileSettings
+    , wfsLanguages
+    , wfsHamletSettings
     ) where
 
 import Control.Monad.IO.Class (liftIO)
@@ -20,7 +24,9 @@ import Language.Haskell.TH.Syntax
 import Text.Lucius (luciusFile, luciusFileReload)
 import Text.Julius (juliusFile, juliusFileReload)
 import Text.Cassius (cassiusFile, cassiusFileReload)
+import Text.Hamlet (HamletSettings, defaultHamletSettings)
 import Data.Maybe (catMaybes)
+import Data.Default (Default (def))
 
 -- | An implementation of 'addStaticContent' which stores the contents in an
 -- external file. Files are created in the given static folder with names based
@@ -57,34 +63,40 @@ addStaticContentExternal minify hash staticDir toRoute ext' _ content = do
 globFile :: String -> String -> FilePath
 globFile kind x = "templates/" ++ x ++ "." ++ kind
 
-widgetFileNoReload :: FilePath -> Q Exp
+data TemplateLanguage = TemplateLanguage
-widgetFileNoReload x = combine "widgetFileNoReload" x
+    { tlRequiresToWidget :: Bool
-    [ whenExists x False "hamlet"  whamletFile
+    , tlExtension :: String
-    , whenExists x True  "cassius" cassiusFile
+    , tlNoReload :: FilePath -> Q Exp
-    , whenExists x True  "julius"  juliusFile
+    , tlReload :: FilePath -> Q Exp
-    , whenExists x True  "lucius"  luciusFile
+    }
-    ]
 
-widgetFileReload :: FilePath -> Q Exp
+defaultTemplateLanguages :: HamletSettings -> [TemplateLanguage]
-widgetFileReload x = combine "widgetFileReload" x
+defaultTemplateLanguages hset =
-    [ whenExists x False "hamlet"  whamletFile
+    [ TemplateLanguage False "hamlet"  whamletFile' whamletFile'
-    , whenExists x True  "cassius" cassiusFileReload
+    , TemplateLanguage True  "cassius" cassiusFile  cassiusFileReload
-    , whenExists x True  "julius"  juliusFileReload
+    , TemplateLanguage True  "julius"  juliusFile   juliusFileReload
-    , whenExists x True  "lucius"  luciusFileReload
+    , TemplateLanguage True  "lucius"  luciusFile   luciusFileReload
     ]
+  where
+    whamletFile' = whamletFileWithSettings hset
 
-widgetFileJsCss :: (String, FilePath -> Q Exp) -- ^ Css file extenstion and loading function. example: ("cassius", cassiusFileReload)
+data WidgetFileSettings = WidgetFileSettings
-                -> (String, FilePath -> Q Exp) -- ^ Css file extenstion and loading function. example: ("julius", juliusFileReload)
+    { wfsLanguages :: HamletSettings -> [TemplateLanguage]
-                -> FilePath -> Q Exp
+    , wfsHamletSettings :: HamletSettings
-widgetFileJsCss (jsExt, jsLoad) (csExt, csLoad) x = combine "widgetFileJsCss" x
+    }
-    [ whenExists x False "hamlet"  whamletFile
-    , whenExists x True  csExt csLoad
-    , whenExists x True  jsExt jsLoad
-    ]
 
-combine :: String -> String -> [Q (Maybe Exp)] -> Q Exp
+instance Default WidgetFileSettings where
-combine func file qmexps = do
+    def = WidgetFileSettings defaultTemplateLanguages defaultHamletSettings
-    mexps <- sequence qmexps
+
+widgetFileNoReload :: WidgetFileSettings -> FilePath -> Q Exp
+widgetFileNoReload wfs x = combine "widgetFileNoReload" x False $ wfsLanguages wfs $ wfsHamletSettings wfs
+
+widgetFileReload :: WidgetFileSettings -> FilePath -> Q Exp
+widgetFileReload wfs x = combine "widgetFileReload" x True $ wfsLanguages wfs $ wfsHamletSettings wfs
+
+combine :: String -> String -> Bool -> [TemplateLanguage] -> Q Exp
+combine func file isReload tls = do
+    mexps <- qmexps
     case catMaybes mexps of
         [] -> error $ concat
             [ "Called "
@@ -94,6 +106,12 @@ combine func file qmexps = do
             , ", but no template were found."
             ]
         exps -> return $ DoE $ map NoBindS exps
+  where
+    qmexps :: Q [Maybe Exp]
+    qmexps = mapM go tls
+
+    go :: TemplateLanguage -> Q (Maybe Exp)
+    go tl = whenExists file (tlRequiresToWidget tl) (tlExtension tl) ((if isReload then tlReload else tlNoReload) tl)
 
 whenExists :: String
            -> Bool -- ^ requires toWidget wrap

yesod-default/yesod-default.cabal

@@ -1,5 +1,5 @@
 name:            yesod-default
-version:         1.0.0
+version:         1.1.0.2
 license:         MIT
 license-file:    LICENSE
 author:          Patrick Brisbin
@@ -18,10 +18,10 @@ library
         cpp-options: -DWINDOWS
 
     build-depends:   base                  >= 4       && < 5
-                   , yesod-core            >= 1.0     && < 1.1
+                   , yesod-core            >= 1.1     && < 1.2
-                   , warp                  >= 1.2     && < 1.3
+                   , warp                  >= 1.3     && < 1.4
-                   , wai                   >= 1.2     && < 1.3
+                   , wai                   >= 1.3     && < 1.4
-                   , wai-extra             >= 1.2     && < 1.3
+                   , wai-extra             >= 1.3     && < 1.4
                    , bytestring            >= 0.9.1.4
                    , transformers          >= 0.2.2   && < 0.4
                    , text                  >= 0.9
@@ -29,9 +29,11 @@ library
                    , shakespeare-css       >= 1.0     && < 1.1
                    , shakespeare-js        >= 1.0     && < 1.1
                    , template-haskell
-                   , yaml                  >= 0.7     && < 0.8
+                   , yaml                  >= 0.8     && < 0.9
-                   , network-conduit       >= 0.4     && < 0.5
+                   , network-conduit       >= 0.5     && < 0.7
                    , unordered-containers
+                   , hamlet                >= 1.1     && < 1.2
+                   , data-default
 
     if !os(windows)
          build-depends: unix

yesod-eventsource/LICENSE

@@ -0,0 +1,20 @@
+Copyright (c) 2012 Felipe Lessa
+
+Permission is hereby granted, free of charge, to any person obtaining
+a copy of this software and associated documentation files (the
+"Software"), to deal in the Software without restriction, including
+without limitation the rights to use, copy, modify, merge, publish,
+distribute, sublicense, and/or sell copies of the Software, and to
+permit persons to whom the Software is furnished to do so, subject to
+the following conditions:
+
+The above copyright notice and this permission notice shall be
+included in all copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

yesod-eventsource/Setup.lhs

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

yesod-eventsource/Yesod/EventSource.hs

@@ -0,0 +1,101 @@
+{-# LANGUAGE OverloadedStrings #-}
+-- | This module contains everything that you need to support
+-- server-sent events in Yesod applications.
+module Yesod.EventSource
+  ( RepEventSource
+  , repEventSource
+  , ioToRepEventSource
+  , EventSourcePolyfill(..)
+  ) where
+
+import Blaze.ByteString.Builder (Builder)
+import Control.Monad (when)
+import Control.Monad.IO.Class (liftIO)
+import Data.Functor ((<$>))
+import Data.Monoid (mappend, mempty)
+import Yesod.Content
+import Yesod.Core
+import qualified Data.Conduit as C
+import qualified Network.Wai as W
+import qualified Network.Wai.EventSource as ES
+import qualified Network.Wai.EventSource.EventStream as ES
+
+
+
+-- | Data type representing a response of server-sent events
+-- (e.g., see 'repEventSource' and 'ioToRepEventSource').
+newtype RepEventSource =
+  RepEventSource (C.Source (C.ResourceT IO) (C.Flush Builder))
+
+instance HasReps RepEventSource where
+  chooseRep (RepEventSource src) =
+    const $ return ("text/event-stream", ContentSource src)
+
+
+-- | (Internal) Find out the request's 'EventSourcePolyfill' and
+-- set any necessary headers.
+prepareForEventSource :: GHandler sub master EventSourcePolyfill
+prepareForEventSource = do
+  reqWith <- lookup "X-Requested-With" . W.requestHeaders <$> waiRequest
+  let polyfill | reqWith == Just "XMLHttpRequest" = Remy'sESPolyfill
+               | otherwise                        = NoESPolyfill
+  setHeader "Cache-Control" "no-cache" -- extremely important!
+  return polyfill
+
+
+-- | Returns a Server-Sent Event stream from a 'C.Source' of
+-- 'ES.ServerEvent'@s@.  The HTTP socket is flushed after every
+-- event.  The connection is closed either when the 'C.Source'
+-- finishes outputting data or a 'ES.CloseEvent' is outputted,
+-- whichever comes first.
+repEventSource :: (EventSourcePolyfill -> C.Source (C.ResourceT IO) ES.ServerEvent)
+               -> GHandler sub master RepEventSource
+repEventSource src = RepEventSource . ES.sourceToSource . src <$> prepareForEventSource
+
+
+-- | Return a Server-Sent Event stream given an @IO@ action that
+-- is repeatedly called.  A state is threaded for the action so
+-- that it may avoid using @IORefs@.  The @IO@ action may sleep
+-- or block while waiting for more data.  The HTTP socket is
+-- flushed after every list of simultaneous events.  The
+-- connection is closed as soon as an 'ES.CloseEvent' is
+-- outputted, after which no other events are sent to the client.
+ioToRepEventSource :: s
+                   -> (EventSourcePolyfill -> s -> IO ([ES.ServerEvent], s))
+                   -> GHandler sub master RepEventSource
+ioToRepEventSource initial act = do
+  polyfill <- prepareForEventSource
+  let -- Get new events to be sent.
+      getEvents s = do
+        (evs, s') <- liftIO (act polyfill s)
+        case evs of
+          [] -> getEvents s'
+          _  -> do
+            let (builder, continue) = joinEvents evs mempty
+            C.yield (C.Chunk builder)
+            C.yield C.Flush
+            when continue (getEvents s')
+
+      -- Join all events in a single Builder.  Returns @False@
+      -- when we the connection should be closed.
+      joinEvents (ev:evs) acc =
+        case ES.eventToBuilder ev of
+          Just b  -> joinEvents evs (acc `mappend` b)
+          Nothing -> (fst $ joinEvents [] acc, False)
+      joinEvents [] acc = (acc, True)
+
+  return $ RepEventSource $ getEvents initial
+
+
+-- | Which @EventSource@ polyfill was detected (if any).
+data EventSourcePolyfill =
+    NoESPolyfill
+    -- ^ We didn't detect any @EventSource@ polyfill that we know.
+  | Remy'sESPolyfill
+    -- ^ See
+    -- <https://github.com/remy/polyfills/blob/master/EventSource.js>.
+    -- In order to support Remy\'s polyfill, your server needs to
+    -- explicitly close the connection from time to
+    -- time--browsers such as IE7 will not show any event until
+    -- the connection is closed.
+    deriving (Eq, Ord, Show, Enum)

yesod-eventsource/yesod-eventsource.cabal

@@ -0,0 +1,42 @@
+name:            yesod-eventsource
+version:         1.0.0.1
+license:         MIT
+license-file:    LICENSE
+author:          Felipe Lessa <felipe.lessa@gmail.com>
+maintainer:      Felipe Lessa <felipe.lessa@gmail.com>
+synopsis:        Server-sent events support for Yesod apps.
+category:        Web, Yesod
+stability:       Stable
+cabal-version:   >= 1.6
+build-type:      Simple
+homepage:        http://www.yesodweb.com/
+description:
+  It's easy to send an event from an HTTP client to a server:
+  just send an HTTP request.  However, sending events from the
+  server to the client requires more sophisticated approaches.
+  Server-sent events (<http://www.w3.org/TR/eventsource/>) are a
+  standardized way of pushing events from the server to the
+  client.
+  .
+  This package allows your Yesod application to easily send
+  server-sent events.  On the client side, you may use the
+  @EventSource@ JavaScript object on browsers that support it
+  (<https://developer.mozilla.org/en-US/docs/Server-sent_events/EventSource>)
+  or a polyfill for browsers that don't (we support Remy's
+  polyfill out-of-the-box, although that requires you to
+  explicitly support it).
+
+library
+    build-depends:   base                  >= 4        && < 5
+                   , yesod-core            >= 1.1      && < 1.2
+                   , conduit               >= 0.5      && < 0.6
+                   , wai                   >= 1.3      && < 1.4
+                   , wai-eventsource       >= 1.3      && < 1.4
+                   , blaze-builder
+                   , transformers
+    exposed-modules: Yesod.EventSource
+    ghc-options:     -Wall
+
+source-repository head
+  type:     git
+  location: https://github.com/yesodweb/yesod

yesod-examples/LICENSE

@@ -1,30 +1,20 @@
-Copyright Michael Snoyman 2010
+Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/
 
-All rights reserved.
+Permission is hereby granted, free of charge, to any person obtaining
+a copy of this software and associated documentation files (the
+"Software"), to deal in the Software without restriction, including
+without limitation the rights to use, copy, modify, merge, publish,
+distribute, sublicense, and/or sell copies of the Software, and to
+permit persons to whom the Software is furnished to do so, subject to
+the following conditions:
 
-Redistribution and use in source and binary forms, with or without
+The above copyright notice and this permission notice shall be
-modification, are permitted provided that the following conditions are met:
+included in all copies or substantial portions of the Software.
 
-    * Redistributions of source code must retain the above copyright
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
-      notice, this list of conditions and the following disclaimer.
+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
-
+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
-    * Redistributions in binary form must reproduce the above
+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
-      copyright notice, this list of conditions and the following
+LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
-      disclaimer in the documentation and/or other materials provided
+OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
-      with the distribution.
+WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
-
-    * Neither the name of Michael Snoyman nor the names of other
-      contributors may be used to endorse or promote products derived
-      from this software without specific prior written permission.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-"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
-OWNER OR CONTRIBUTORS 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-form/LICENSE

@@ -1,25 +1,20 @@
-The following license covers this documentation, and the source code, except
+Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/
-where otherwise indicated.
 
-Copyright 2010, Michael Snoyman. All rights reserved.
+Permission is hereby granted, free of charge, to any person obtaining
+a copy of this software and associated documentation files (the
+"Software"), to deal in the Software without restriction, including
+without limitation the rights to use, copy, modify, merge, publish,
+distribute, sublicense, and/or sell copies of the Software, and to
+permit persons to whom the Software is furnished to do so, subject to
+the following conditions:
 
-Redistribution and use in source and binary forms, with or without
+The above copyright notice and this permission notice shall be
-modification, are permitted provided that the following conditions are met:
+included in all copies or substantial portions of the Software.
 
-* Redistributions of source code must retain the above copyright notice, this
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
-  list of conditions and the following disclaimer.
+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
-
+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
-* Redistributions in binary form must reproduce the above copyright notice,
+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
-  this list of conditions and the following disclaimer in the documentation
+LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
-  and/or other materials provided with the distribution.
+OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
-
+WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
-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-form/Yesod/Form/Fields.hs

@@ -3,6 +3,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE CPP #-}
 module Yesod.Form.Fields
     ( -- * i18n
       FormMessage (..)
@@ -46,11 +47,15 @@ module Yesod.Form.Fields
 
 import Yesod.Form.Types
 import Yesod.Form.I18n.English
+import Yesod.Form.Functions (parseHelper)
 import Yesod.Handler (getMessageRender)
 import Yesod.Widget (toWidget, whamlet, GWidget)
 import Yesod.Message (RenderMessage (renderMessage), SomeMessage (..))
 import Text.Hamlet
-import Text.Blaze (ToHtml (..), preEscapedText, unsafeByteString)
+import Text.Blaze (ToMarkup (toMarkup), preEscapedToMarkup, unsafeByteString)
+#define ToHtml ToMarkup
+#define toHtml toMarkup
+#define preEscapedText preEscapedToMarkup
 import Text.Cassius
 import Data.Time (Day, TimeOfDay(..))
 import qualified Text.Email.Validate as Email
@@ -59,14 +64,14 @@ import Database.Persist (PersistField)
 import Database.Persist.Store (Entity (..))
 import Text.HTML.SanitizeXSS (sanitizeBalance)
 import Control.Monad (when, unless)
-import Data.Maybe (listToMaybe)
+import Data.Maybe (listToMaybe, fromMaybe)
 
 import qualified Blaze.ByteString.Builder.Html.Utf8 as B
 import Blaze.ByteString.Builder (writeByteString, toLazyByteString)
 import Blaze.ByteString.Builder.Internal.Write (fromWriteList)
 import Database.Persist.Store (PersistEntityBackend)
 
-import Text.Blaze.Renderer.String (renderHtml)
+import Text.Blaze.Html.Renderer.String (renderHtml)
 import qualified Data.ByteString as S
 import qualified Data.ByteString.Lazy as L
 import Data.Text (Text, unpack, pack)
@@ -76,29 +81,27 @@ import qualified Data.Map as Map
 import Yesod.Handler (newIdent, lift)
 import Yesod.Request (FileInfo)
 
-import Yesod.Core (toPathPiece, GHandler, PathPiece)
+import Yesod.Core (toPathPiece, GHandler, PathPiece, fromPathPiece)
 import Yesod.Persist (selectList, runDB, Filter, SelectOpt, YesodPersistBackend, Key, YesodPersist, PersistEntity, PersistQuery)
 import Control.Arrow ((&&&))
 
-import Control.Applicative ((<$>))
+import Control.Applicative ((<$>), (<|>))
+
+import Data.Attoparsec.Text (Parser, char, string, digit, skipSpace, endOfInput, parseOnly)
 
 defaultFormMessage :: FormMessage -> Text
 defaultFormMessage = englishFormMessage
 
-blank :: (Monad m, RenderMessage master FormMessage)
-      => (Text -> Either FormMessage a) -> [Text] -> m (Either (SomeMessage master) (Maybe a))
-blank _ [] = return $ Right Nothing
-blank _ ("":_) = return $ Right Nothing
-blank f (x:_) = return $ either (Left . SomeMessage) (Right . Just) $ f x
 
 intField :: (Integral i, RenderMessage master FormMessage) => Field sub master i
 intField = Field
-    { fieldParse = blank $ \s ->
+    { fieldParse = parseHelper $ \s ->
         case Data.Text.Read.signed Data.Text.Read.decimal s of
             Right (a, "") -> Right a
             _ -> Left $ MsgInvalidInteger s
 
     , fieldView = \theId name attrs val isReq -> toWidget [hamlet|
+$newline never
 <input id="#{theId}" name="#{name}" *{attrs} type="number" :isReq:required="" value="#{showVal val}">
 |]
     }
@@ -108,12 +111,13 @@ intField = Field
 
 doubleField :: RenderMessage master FormMessage => Field sub master Double
 doubleField = Field
-    { fieldParse = blank $ \s ->
+    { fieldParse = parseHelper $ \s ->
         case Data.Text.Read.double s of
             Right (a, "") -> Right a
             _ -> Left $ MsgInvalidNumber s
 
     , fieldView = \theId name attrs val isReq -> toWidget [hamlet|
+$newline never
 <input id="#{theId}" name="#{name}" *{attrs} type="text" :isReq:required="" value="#{showVal val}">
 |]
     }
@@ -121,8 +125,9 @@ doubleField = Field
 
 dayField :: RenderMessage master FormMessage => Field sub master Day
 dayField = Field
-    { fieldParse = blank $ parseDate . unpack
+    { fieldParse = parseHelper $ parseDate . unpack
     , fieldView = \theId name attrs val isReq -> toWidget [hamlet|
+$newline never
 <input id="#{theId}" name="#{name}" *{attrs} type="date" :isReq:required="" value="#{showVal val}">
 |]
     }
@@ -130,8 +135,9 @@ dayField = Field
 
 timeField :: RenderMessage master FormMessage => Field sub master TimeOfDay
 timeField = Field
-    { fieldParse = blank $ parseTime . unpack
+    { fieldParse = parseHelper parseTime
     , fieldView = \theId name attrs val isReq -> toWidget [hamlet|
+$newline never
 <input id="#{theId}" name="#{name}" *{attrs} :isReq:required="" value="#{showVal val}">
 |]
     }
@@ -144,9 +150,10 @@ timeField = Field
 
 htmlField :: RenderMessage master FormMessage => Field sub master Html
 htmlField = Field
-    { fieldParse = blank $ Right . preEscapedText . sanitizeBalance
+    { fieldParse = parseHelper $ Right . preEscapedText . sanitizeBalance
     , fieldView = \theId name attrs val _isReq -> toWidget [hamlet|
-        -- FIXME: There was a class="html" attribute, for what purpose?
+$newline never
+$# FIXME: There was a class="html" attribute, for what purpose?
 <textarea id="#{theId}" name="#{name}" *{attrs}>#{showVal val}
 |]
     }
@@ -155,7 +162,7 @@ htmlField = Field
 -- | A newtype wrapper around a 'Text' that converts newlines to HTML
 -- br-tags.
 newtype Textarea = Textarea { unTextarea :: Text }
-    deriving (Show, Read, Eq, PersistField)
+    deriving (Show, Read, Eq, PersistField, Ord)
 instance ToHtml Textarea where
     toHtml =
         unsafeByteString
@@ -172,33 +179,38 @@ instance ToHtml Textarea where
 
 textareaField :: RenderMessage master FormMessage => Field sub master Textarea
 textareaField = Field
-    { fieldParse =  blank $ Right . Textarea
+    { fieldParse = parseHelper $ Right . Textarea
     , fieldView = \theId name attrs val _isReq -> toWidget [hamlet|
+$newline never
 <textarea id="#{theId}" name="#{name}" *{attrs}>#{either id unTextarea val}
 |]
     }
 
-hiddenField :: RenderMessage master FormMessage => Field sub master Text
+hiddenField :: (PathPiece p, RenderMessage master FormMessage)
+            => Field sub master p
 hiddenField = Field
-    { fieldParse = blank $ Right
+    { fieldParse = parseHelper $ maybe (Left MsgValueRequired) Right . fromPathPiece
     , fieldView = \theId name attrs val _isReq -> toWidget [hamlet|
-<input type="hidden" id="#{theId}" name="#{name}" *{attrs} value="#{either id id val}">
+$newline never
+<input type="hidden" id="#{theId}" name="#{name}" *{attrs} value="#{either id toPathPiece val}">
 |]
     }
 
 textField :: RenderMessage master FormMessage => Field sub master Text
 textField = Field
-    { fieldParse = blank $ Right
+    { fieldParse = parseHelper $ Right
     , fieldView = \theId name attrs val isReq ->
         [whamlet|
+$newline never
 <input id="#{theId}" name="#{name}" *{attrs} type="text" :isReq:required value="#{either id id val}">
 |]
     }
 
 passwordField :: RenderMessage master FormMessage => Field sub master Text
 passwordField = Field
-    { fieldParse = blank $ Right
+    { fieldParse = parseHelper $ Right
     , fieldView = \theId name attrs val isReq -> toWidget [hamlet|
+$newline never
 <input id="#{theId}" name="#{name}" *{attrs} type="password" :isReq:required="" value="#{either id id val}">
 |]
     }
@@ -217,37 +229,61 @@ parseDate = maybe (Left MsgInvalidDay) Right
 replace :: Eq a => a -> a -> [a] -> [a]
 replace x y = map (\z -> if z == x then y else z)
 
-parseTime :: String -> Either FormMessage TimeOfDay
+parseTime :: Text -> Either FormMessage TimeOfDay
-parseTime (h2:':':m1:m2:[]) = parseTimeHelper ('0', h2, m1, m2, '0', '0')
+parseTime = either (Left . fromMaybe MsgInvalidTimeFormat . readMay . drop 2 . dropWhile (/= ':')) Right . parseOnly timeParser
-parseTime (h1:h2:':':m1:m2:[]) = parseTimeHelper (h1, h2, m1, m2, '0', '0')
-parseTime (h1:h2:':':m1:m2:' ':'A':'M':[]) =
-    parseTimeHelper (h1, h2, m1, m2, '0', '0')
-parseTime (h1:h2:':':m1:m2:' ':'P':'M':[]) =
-    let [h1', h2'] = show $ (read [h1, h2] :: Int) + 12
-    in parseTimeHelper (h1', h2', m1, m2, '0', '0')
-parseTime (h1:h2:':':m1:m2:':':s1:s2:[]) =
-    parseTimeHelper (h1, h2, m1, m2, s1, s2)
-parseTime _ = Left MsgInvalidTimeFormat
 
-parseTimeHelper :: (Char, Char, Char, Char, Char, Char)
+timeParser :: Parser TimeOfDay
-                -> Either FormMessage TimeOfDay
+timeParser = do
-parseTimeHelper (h1, h2, m1, m2, s1, s2)
+    skipSpace
-    | h < 0 || h > 23 = Left $ MsgInvalidHour $ pack [h1, h2]
+    h <- hour
-    | m < 0 || m > 59 = Left $ MsgInvalidMinute $ pack [m1, m2]
+    _ <- char ':'
-    | s < 0 || s > 59 = Left $ MsgInvalidSecond $ pack [s1, s2]
+    m <- minsec MsgInvalidMinute
-    | otherwise = Right $ TimeOfDay h m s
+    hasSec <- (char ':' >> return True) <|> return False
+    s <- if hasSec then minsec MsgInvalidSecond else return 0
+    skipSpace
+    isPM <-
+        (string "am" >> return (Just False)) <|>
+        (string "AM" >> return (Just False)) <|>
+        (string "pm" >> return (Just True)) <|>
+        (string "PM" >> return (Just True)) <|>
+        return Nothing
+    h' <-
+        case isPM of
+            Nothing -> return h
+            Just x
+                | h <= 0 || h > 12 -> fail $ show $ MsgInvalidHour $ pack $ show h
+                | h == 12 -> return $ if x then 12 else 0
+                | otherwise -> return $ h + (if x then 12 else 0)
+    skipSpace
+    endOfInput
+    return $ TimeOfDay h' m s
   where
-    h = read [h1, h2] -- FIXME isn't this a really bad idea?
+    hour = do
-    m = read [m1, m2]
+        x <- digit
-    s = fromInteger $ read [s1, s2]
+        y <- (return <$> digit) <|> return []
+        let xy = x : y
+        let i = read xy
+        if i < 0 || i >= 24
+            then fail $ show $ MsgInvalidHour $ pack xy
+            else return i
+    minsec :: Num a => (Text -> FormMessage) -> Parser a
+    minsec msg = do
+        x <- digit
+        y <- digit <|> fail (show $ msg $ pack [x])
+        let xy = [x, y]
+        let i = read xy
+        if i < 0 || i >= 60
+            then fail $ show $ msg $ pack xy
+            else return $ fromIntegral (i :: Int)
 
 emailField :: RenderMessage master FormMessage => Field sub master Text
 emailField = Field
-    { fieldParse = blank $
+    { fieldParse = parseHelper $
         \s -> if Email.isValid (unpack s)
                 then Right s
                 else Left $ MsgInvalidEmail s
     , fieldView = \theId name attrs val isReq -> toWidget [hamlet|
+$newline never
 <input id="#{theId}" name="#{name}" *{attrs} type="email" :isReq:required="" value="#{either id id val}">
 |]
     }
@@ -255,14 +291,18 @@ emailField = Field
 type AutoFocus = Bool
 searchField :: RenderMessage master FormMessage => AutoFocus -> Field sub master Text
 searchField autoFocus = Field
-    { fieldParse = blank Right
+    { fieldParse = parseHelper Right
     , fieldView = \theId name attrs val isReq -> do
         [whamlet|\
+$newline never
 <input id="#{theId}" name="#{name}" *{attrs} type="search" :isReq:required="" :autoFocus:autofocus="" value="#{either id id val}">
 |]
         when autoFocus $ do
           -- we want this javascript to be placed immediately after the field
-          [whamlet|<script>if (!('autofocus' in document.createElement('input'))) {document.getElementById('#{theId}').focus();}|]
+          [whamlet|
+$newline never
+<script>if (!('autofocus' in document.createElement('input'))) {document.getElementById('#{theId}').focus();}
+|]
           toWidget [cassius|
             #{theId}
               -webkit-appearance: textfield
@@ -271,12 +311,13 @@ searchField autoFocus = Field
 
 urlField :: RenderMessage master FormMessage => Field sub master Text
 urlField = Field
-    { fieldParse = blank $ \s ->
+    { fieldParse = parseHelper $ \s ->
         case parseURI $ unpack s of
             Nothing -> Left $ MsgInvalidUrl s
             Just _ -> Right s
     , fieldView = \theId name attrs val isReq ->
         [whamlet|
+$newline never
 <input ##{theId} name=#{name} *{attrs} type=url :isReq:required value=#{either id id val}>
 |]
     }
@@ -286,9 +327,18 @@ selectFieldList = selectField . optionsPairs
 
 selectField :: (Eq a, RenderMessage master FormMessage) => GHandler sub master (OptionList a) -> Field sub master a
 selectField = selectFieldHelper
-    (\theId name inside -> [whamlet|<select ##{theId} name=#{name}>^{inside}|]) -- outside
+    (\theId name inside -> [whamlet|
-    (\_theId _name isSel -> [whamlet|<option value=none :isSel:selected>_{MsgSelectNone}|]) -- onOpt
+$newline never
-    (\_theId _name attrs value isSel text -> [whamlet|<option value=#{value} :isSel:selected *{attrs}>#{text}|]) -- inside
+<select ##{theId} name=#{name}>^{inside}
+|]) -- outside
+    (\_theId _name isSel -> [whamlet|
+$newline never
+<option value=none :isSel:selected>_{MsgSelectNone}
+|]) -- onOpt
+    (\_theId _name attrs value isSel text -> [whamlet|
+$newline never
+<option value=#{value} :isSel:selected *{attrs}>#{text}
+|]) -- inside
 
 multiSelectFieldList :: (Eq a, RenderMessage master FormMessage, RenderMessage master msg) => [(msg, a)] -> Field sub master [a]
 multiSelectFieldList = multiSelectField . optionsPairs
@@ -310,6 +360,7 @@ multiSelectField ioptlist =
         opts <- fmap olOptions $ lift ioptlist
         let selOpts = map (id &&& (optselected val)) opts
         [whamlet|
+$newline never
             <select ##{theId} name=#{name} :isReq:required multiple *{attrs}>
                 $forall (opt, optsel) <- selOpts
                     <option value=#{optionExternalValue opt} :optsel:selected>#{optionDisplay opt}
@@ -323,22 +374,30 @@ radioFieldList = radioField . optionsPairs
 
 radioField :: (Eq a, RenderMessage master FormMessage) => GHandler sub master (OptionList a) -> Field sub master a
 radioField = selectFieldHelper
-    (\theId _name inside -> [whamlet|<div ##{theId}>^{inside}|])
+    (\theId _name inside -> [whamlet|
+$newline never
+<div ##{theId}>^{inside}
+|])
     (\theId name isSel -> [whamlet|
-<div>
+$newline never
-    <input id=#{theId}-none type=radio name=#{name} value=none :isSel:checked>
+<label .radio for=#{theId}-none>
-    <label for=#{theId}-none>_{MsgSelectNone}
+    <div>
+        <input id=#{theId}-none type=radio name=#{name} value=none :isSel:checked>
+        _{MsgSelectNone}
 |])
     (\theId name attrs value isSel text -> [whamlet|
-<div>
+$newline never
-    <input id=#{theId}-#{value} type=radio name=#{name} value=#{value} :isSel:checked *{attrs}>
+<label .radio for=#{theId}-#{value}>
-    <label for=#{theId}-#{value}>#{text}
+    <div>
+        <input id=#{theId}-#{value} type=radio name=#{name} value=#{value} :isSel:checked *{attrs}>
+        \#{text}
 |])
 
 boolField :: RenderMessage master FormMessage => Field sub master Bool
 boolField = Field
       { fieldParse = return . boolParser
       , fieldView = \theId name attrs val isReq -> [whamlet|
+$newline never
   $if not isReq
       <input id=#{theId}-none *{attrs} type=radio name=#{name} value=none checked>
       <label for=#{theId}-none>_{MsgSelectNone}
@@ -357,6 +416,7 @@ boolField = Field
       "" -> Right Nothing
       "none" -> Right Nothing
       "yes" -> Right $ Just True
+      "on" -> Right $ Just True
       "no" -> Right $ Just False
       t -> Left $ SomeMessage $ MsgInvalidBool t
     showVal = either (\_ -> False)
@@ -372,6 +432,7 @@ checkBoxField :: RenderMessage m FormMessage => Field s m Bool
 checkBoxField = Field
     { fieldParse = return . checkBoxParser
     , fieldView  = \theId name attrs val _ -> [whamlet|
+$newline never
 <input id=#{theId} *{attrs} type=checkbox name=#{name} value=yes :showVal id val:checked>
 |]
     }
@@ -380,6 +441,7 @@ checkBoxField = Field
         checkBoxParser [] = Right $ Just False
         checkBoxParser (x:_) = case x of
             "yes" -> Right $ Just True
+            "on" -> Right $ Just True
             _     -> Right $ Just False
 
         showVal = either (\_ -> False)
@@ -486,6 +548,7 @@ fileAFormReq fs = AForm $ \(master, langs) menvs ints -> do
             , fvTooltip = fmap (toHtml . renderMessage master langs) $ fsTooltip fs
             , fvId = id'
             , fvInput = [whamlet|
+$newline never
 <input type=file name=#{name} ##{id'} *{fsAttrs fs}>
 |]
             , fvErrors = errs
@@ -514,6 +577,7 @@ fileAFormOpt fs = AForm $ \(master, langs) menvs ints -> do
             , fvTooltip = fmap (toHtml . renderMessage master langs) $ fsTooltip fs
             , fvId = id'
             , fvInput = [whamlet|
+$newline never
 <input type=file name=#{name} ##{id'} *{fsAttrs fs}>
 |]
             , fvErrors = errs

yesod-form/Yesod/Form/Functions.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE CPP #-}
 module Yesod.Form.Functions
     ( -- * Running in MForm monad
       newFormIdent
@@ -26,15 +27,19 @@ module Yesod.Form.Functions
     , FormRender
     , renderTable
     , renderDivs
+    , renderDivsNoLabels 
     , renderBootstrap
       -- * Validation
     , check
     , checkBool
     , checkM
+    , checkMMap
+    , checkMMod
     , customErrorMessage
       -- * Utilities
     , fieldSettingsLabel
     , aformM
+    , parseHelper
     ) where
 
 import Yesod.Form.Types
@@ -43,18 +48,21 @@ import Control.Arrow (second)
 import Control.Monad.Trans.RWS (ask, get, put, runRWST, tell, evalRWST)
 import Control.Monad.Trans.Class (lift)
 import Control.Monad (liftM, join)
-import Text.Blaze (Html, toHtml)
+import Crypto.Classes (constTimeEq)
+import Text.Blaze (Markup, toMarkup)
+#define Html Markup
+#define toHtml toMarkup
 import Yesod.Handler (GHandler, getRequest, runRequestBody, newIdent, getYesod)
 import Yesod.Core (RenderMessage, SomeMessage (..))
 import Yesod.Widget (GWidget, whamlet)
-import Yesod.Request (reqToken, reqWaiRequest, reqGetParams, languages, FileInfo (..))
+import Yesod.Request (reqToken, reqWaiRequest, reqGetParams, languages)
 import Network.Wai (requestMethod)
 import Text.Hamlet (shamlet)
 import Data.Monoid (mempty)
 import Data.Maybe (listToMaybe, fromMaybe)
 import Yesod.Message (RenderMessage (..))
 import qualified Data.Map as Map
-import qualified Data.ByteString.Lazy as L
+import qualified Data.Text.Encoding as TE
 import Control.Applicative ((<$>))
 import Control.Arrow (first)
 
@@ -180,16 +188,22 @@ postHelper form env = do
     let token =
             case reqToken req of
                 Nothing -> mempty
-                Just n -> [shamlet|<input type=hidden name=#{tokenKey} value=#{n}>|]
+                Just n -> [shamlet|
+$newline never
+<input type=hidden name=#{tokenKey} value=#{n}>
+|]
     m <- getYesod
     langs <- languages
     ((res, xml), enctype) <- runFormGeneric (form token) m langs env
     let res' =
             case (res, env) of
                 (FormSuccess{}, Just (params, _))
-                    | Map.lookup tokenKey params /= fmap return (reqToken req) ->
+                    | not (Map.lookup tokenKey params === reqToken req) ->
                         FormFailure [renderMessage m langs MsgCsrfWarning]
                 _ -> res
+            where (Just [t1]) === (Just t2) = TE.encodeUtf8 t1 `constTimeEq` TE.encodeUtf8 t2
+                  Nothing     === Nothing   = True   -- ^ It's important to use constTimeEq
+                  _           === _         = False  -- in order to avoid timing attacks.
     return ((res', xml), enctype)
 
 -- | Similar to 'runFormPost', except it always ignore the currently available
@@ -210,9 +224,7 @@ postEnv = do
         else do
             (p, f) <- runRequestBody
             let p' = Map.unionsWith (++) $ map (\(x, y) -> Map.singleton x [y]) p
-            return $ Just (p', Map.fromList $ filter (notEmpty . snd) f)
+            return $ Just (p', Map.fromList f)
-  where
-    notEmpty = not . L.null . fileContent
 
 runFormPostNoToken :: (Html -> MForm sub master (FormResult a, xml)) -> GHandler sub master ((FormResult a, xml), Enctype)
 runFormPostNoToken form = do
@@ -238,7 +250,10 @@ getKey = "_hasdata"
 
 getHelper :: (Html -> MForm sub master a) -> Maybe (Env, FileEnv) -> GHandler sub master (a, Enctype)
 getHelper form env = do
-    let fragment = [shamlet|<input type=hidden name=#{getKey}>|]
+    let fragment = [shamlet|
+$newline never
+<input type=hidden name=#{getKey}>
+|]
     langs <- languages
     m <- getYesod
     runFormGeneric (form fragment) m langs env
@@ -248,12 +263,13 @@ type FormRender sub master a =
     -> Html
     -> MForm sub master (FormResult a, GWidget sub master ())
 
-renderTable, renderDivs :: FormRender sub master a
+renderTable, renderDivs, renderDivsNoLabels :: FormRender sub master a
 renderTable aform fragment = do
     (res, views') <- aFormToForm aform
     let views = views' []
     -- FIXME non-valid HTML
     let widget = [whamlet|
+$newline never
 \#{fragment}
 $forall view <- views
     <tr :fvRequired view:.required :not $ fvRequired view:.optional>
@@ -267,14 +283,23 @@ $forall view <- views
 |]
     return (res, widget)
 
-renderDivs aform fragment = do
+-- | render a field inside a div
+renderDivs = renderDivsMaybeLabels True
+
+-- | render a field inside a div, not displaying any label
+renderDivsNoLabels = renderDivsMaybeLabels False
+
+renderDivsMaybeLabels :: Bool -> FormRender sub master a
+renderDivsMaybeLabels withLabels aform fragment = do
     (res, views') <- aFormToForm aform
     let views = views' []
     let widget = [whamlet|
+$newline never
 \#{fragment}
 $forall view <- views
     <div :fvRequired view:.required :not $ fvRequired view:.optional>
-        <label for=#{fvId view}>#{fvLabel view}
+        $if withLabels
+                <label for=#{fvId view}>#{fvLabel view}
         $maybe tt <- fvTooltip view
             <div .tooltip>#{tt}
         ^{fvInput view}
@@ -305,6 +330,7 @@ renderBootstrap aform fragment = do
         has (Just _) = True
         has Nothing  = False
     let widget = [whamlet|
+$newline never
 \#{fragment}
 $forall view <- views
     <div .control-group .clearfix :fvRequired view:.required :not $ fvRequired view:.optional :has $ fvErrors view:.error>
@@ -331,26 +357,64 @@ checkM :: RenderMessage master msg
        => (a -> GHandler sub master (Either msg a))
        -> Field sub master a
        -> Field sub master a
-checkM f field = field
+checkM f = checkMMap f id
+
+-- | Same as 'checkM', but modifies the datatype.
+--
+-- In order to make this work, you must provide a function to convert back from
+-- the new datatype to the old one (the second argument to this function).
+--
+-- Since 1.1.2
+checkMMap :: RenderMessage master msg
+          => (a -> GHandler sub master (Either msg b))
+          -> (b -> a)
+          -> Field sub master a
+          -> Field sub master b
+checkMMap f inv field = field
     { fieldParse = \ts -> do
         e1 <- fieldParse field ts
         case e1 of
             Left msg -> return $ Left msg
             Right Nothing -> return $ Right Nothing
             Right (Just a) -> fmap (either (Left . SomeMessage) (Right . Just)) $ f a
+    , fieldView = \i n a eres req -> fieldView field i n a (fmap inv eres) req
     }
 
+-- | Deprecated synonym for 'checkMMap'.
+--
+-- Since 1.1.1
+checkMMod :: RenderMessage master msg
+          => (a -> GHandler sub master (Either msg b))
+          -> (b -> a)
+          -> Field sub master a
+          -> Field sub master b
+checkMMod = checkMMap
+{-# DEPRECATED checkMMod "Please use checkMMap instead" #-}
+
 -- | 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 }
 
 -- | Generate a 'FieldSettings' from the given label.
-fieldSettingsLabel :: SomeMessage master -> FieldSettings master
+fieldSettingsLabel :: RenderMessage master msg => msg -> FieldSettings master
-fieldSettingsLabel msg = FieldSettings msg Nothing Nothing Nothing []
+fieldSettingsLabel msg = FieldSettings (SomeMessage msg) Nothing Nothing Nothing []
 
 -- | Generate an 'AForm' that gets its value from the given action.
 aformM :: GHandler sub master a -> AForm sub master a
 aformM action = AForm $ \_ _ ints -> do
     value <- action
     return (FormSuccess value, id, ints, mempty)
+
+-- | A helper function for creating custom fields.
+--
+-- This is intended to help with the common case where a single input value is
+-- required, such as when parsing a text field.
+--
+-- Since 1.1
+parseHelper :: (Monad m, RenderMessage master FormMessage)
+            => (Text -> Either FormMessage a)
+            -> [Text] -> m (Either (SomeMessage master) (Maybe a))
+parseHelper _ [] = return $ Right Nothing
+parseHelper _ ("":_) = return $ Right Nothing
+parseHelper f (x:_) = return $ either (Left . SomeMessage) (Right . Just) $ f x

yesod-form/Yesod/Form/I18n/French.hs

@@ -0,0 +1,26 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Yesod.Form.I18n.French (frenchFormMessage) where
+
+import Yesod.Form.Types (FormMessage (..))
+import Data.Monoid (mappend)
+import Data.Text (Text)
+
+frenchFormMessage :: FormMessage -> Text
+frenchFormMessage (MsgInvalidInteger t) = "Entier invalide : " `mappend` t
+frenchFormMessage (MsgInvalidNumber t) = "Nombre invalide : " `mappend` t
+frenchFormMessage (MsgInvalidEntry t) = "Entrée invalide : " `mappend` t
+frenchFormMessage MsgInvalidTimeFormat = "Heure invalide (elle doit être au format HH:MM ou HH:MM:SS"
+frenchFormMessage MsgInvalidDay = "Date invalide (elle doit être au format AAAA-MM-JJ"
+frenchFormMessage (MsgInvalidUrl t) = "Adresse Internet invalide : " `mappend` t
+frenchFormMessage (MsgInvalidEmail t) = "Adresse électronique invalide : " `mappend` t
+frenchFormMessage (MsgInvalidHour t) = "Heure invalide : " `mappend` t
+frenchFormMessage (MsgInvalidMinute t) = "Minutes invalides : " `mappend` t
+frenchFormMessage (MsgInvalidSecond t) = "Secondes invalides  " `mappend` t
+frenchFormMessage MsgCsrfWarning = "Afin d'empêcher les attaques CSRF, veuillez ré-envoyer ce formulaire"
+frenchFormMessage MsgValueRequired = "Ce champ est requis"
+frenchFormMessage (MsgInputNotFound t) = "Entrée non trouvée : " `mappend` t
+frenchFormMessage MsgSelectNone = "<Rien>"
+frenchFormMessage (MsgInvalidBool t) = "Booléen invalide : " `mappend` t
+frenchFormMessage MsgBoolYes = "Oui"
+frenchFormMessage MsgBoolNo = "Non"
+frenchFormMessage MsgDelete = "Détruire ?"

yesod-form/Yesod/Form/I18n/Japanese.hs

@@ -0,0 +1,26 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Yesod.Form.I18n.Japanese where
+
+import Yesod.Form.Types (FormMessage (..))
+import Data.Monoid (mappend)
+import Data.Text (Text)
+
+japaneseFormMessage :: FormMessage -> Text
+japaneseFormMessage (MsgInvalidInteger t) = "無効な整数です: " `mappend` t
+japaneseFormMessage (MsgInvalidNumber t) = "無効な数値です: " `mappend` t
+japaneseFormMessage (MsgInvalidEntry t) = "無効な入力です: " `mappend` t
+japaneseFormMessage MsgInvalidTimeFormat = "無効な時刻です。HH:MM[:SS]フォーマットで入力してください"
+japaneseFormMessage MsgInvalidDay = "無効な日付です。YYYY-MM-DDフォーマットで入力してください"
+japaneseFormMessage (MsgInvalidUrl t) = "無効なURLです: " `mappend` t
+japaneseFormMessage (MsgInvalidEmail t) = "無効なメールアドレスです: " `mappend` t
+japaneseFormMessage (MsgInvalidHour t) = "無効な時間です: " `mappend` t
+japaneseFormMessage (MsgInvalidMinute t) = "無効な分です: " `mappend` t
+japaneseFormMessage (MsgInvalidSecond t) = "無効な秒です: " `mappend` t
+japaneseFormMessage MsgCsrfWarning = "CSRF攻撃を防ぐため、フォームの入力を確認してください"
+japaneseFormMessage MsgValueRequired = "値は必須です"
+japaneseFormMessage (MsgInputNotFound t) = "入力が見つかりません: " `mappend` t
+japaneseFormMessage MsgSelectNone = "<なし>"
+japaneseFormMessage (MsgInvalidBool t) = "無効なbool値です: " `mappend` t
+japaneseFormMessage MsgBoolYes = "はい"
+japaneseFormMessage MsgBoolNo = "いいえ"
+japaneseFormMessage MsgDelete = "削除しますか?"

yesod-form/Yesod/Form/I18n/Norwegian.hs

@@ -0,0 +1,26 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Yesod.Form.I18n.Norwegian where
+
+import Yesod.Form.Types (FormMessage (..))
+import Data.Monoid (mappend)
+import Data.Text (Text)
+
+norwegianBokmålFormMessage :: FormMessage -> Text
+norwegianBokmålFormMessage (MsgInvalidInteger t) = "Ugyldig antall: " `mappend` t
+norwegianBokmålFormMessage (MsgInvalidNumber t) = "Ugyldig nummer: " `mappend` t
+norwegianBokmålFormMessage (MsgInvalidEntry t) = "Ugyldig oppføring: " `mappend` t
+norwegianBokmålFormMessage MsgInvalidTimeFormat = "Ugyldig klokkeslett, må være i formatet HH:MM[:SS]"
+norwegianBokmålFormMessage MsgInvalidDay = "Ugyldig dato, må være i formatet ÅÅÅÅ-MM-DD"
+norwegianBokmålFormMessage (MsgInvalidUrl t) = "Ugyldig URL: " `mappend` t
+norwegianBokmålFormMessage (MsgInvalidEmail t) = "Ugyldig e-postadresse: " `mappend` t
+norwegianBokmålFormMessage (MsgInvalidHour t) = "Ugyldig time: " `mappend` t
+norwegianBokmålFormMessage (MsgInvalidMinute t) = "Ugyldig minutt: " `mappend` t
+norwegianBokmålFormMessage (MsgInvalidSecond t) = "Ugyldig sekund: " `mappend` t
+norwegianBokmålFormMessage MsgValueRequired = "Feltet er obligatorisk"
+norwegianBokmålFormMessage (MsgInputNotFound t) = "Feltet ble ikke funnet: " `mappend` t
+norwegianBokmålFormMessage MsgSelectNone = "<Ingenting>"
+norwegianBokmålFormMessage (MsgInvalidBool t) = "Ugyldig sannhetsverdi: " `mappend` t
+norwegianBokmålFormMessage MsgBoolYes = "Ja"
+norwegianBokmålFormMessage MsgBoolNo = "Nei"
+norwegianBokmålFormMessage MsgDelete = "Slette?"
+norwegianBokmålFormMessage MsgCsrfWarning = "Som beskyttelse mot «cross-site request forgery»-angrep, vennligst bekreft innsendt skjema."

yesod-form/Yesod/Form/Jquery.hs

@@ -23,7 +23,7 @@ import Text.Hamlet (shamlet)
 import Text.Julius (julius)
 import Data.Text (Text, pack, unpack)
 import Data.Monoid (mconcat)
-import Yesod.Core (RenderMessage, SomeMessage (..))
+import Yesod.Core (RenderMessage)
 
 -- | Gets the Google hosted jQuery UI 1.8 CSS file with the given theme.
 googleHostedJqueryUiCss :: Text -> Text
@@ -34,9 +34,15 @@ googleHostedJqueryUiCss theme = mconcat
     ]
 
 class YesodJquery a where
-    -- | The jQuery 1.4 Javascript file.
+    -- | The jQuery Javascript file. Note that in upgrades to this library, the
+    -- version of jQuery referenced, or where it is downloaded from, may be
+    -- changed without warning. If you are relying on a specific version of
+    -- jQuery, you should give an explicit URL instead of relying on the
+    -- default value.
+    --
+    -- Currently, the default value is jQuery 1.7 from Google\'s CDN.
     urlJqueryJs :: a -> Either (Route a) Text
-    urlJqueryJs _ = Right "http://ajax.googleapis.com/ajax/libs/jquery/1.4/jquery.min.js"
+    urlJqueryJs _ = Right "http://ajax.googleapis.com/ajax/libs/jquery/1.7/jquery.min.js"
 
     -- | The jQuery UI 1.8 Javascript file.
     urlJqueryUiJs :: a -> Either (Route a) Text
@@ -50,20 +56,16 @@ class YesodJquery a where
     urlJqueryUiDateTimePicker :: a -> Either (Route a) Text
     urlJqueryUiDateTimePicker _ = Right "http://github.com/gregwebs/jquery.ui.datetimepicker/raw/master/jquery.ui.datetimepicker.js"
 
-blank :: (RenderMessage master FormMessage, Monad m) => (Text -> Either FormMessage a) -> [Text] -> m (Either (SomeMessage master) (Maybe a))
-blank _ [] = return $ Right Nothing
-blank _ ("":_) = return $ Right Nothing
-blank f (x:_) = return $ either (Left . SomeMessage) (Right . Just) $ f x
-
 jqueryDayField :: (RenderMessage master FormMessage, YesodJquery master) => JqueryDaySettings -> Field sub master Day
 jqueryDayField jds = Field
-    { fieldParse = blank $ maybe
+    { fieldParse = parseHelper $ maybe
                   (Left MsgInvalidDay)
                   Right
               . readMay
               . unpack
     , fieldView = \theId name attrs val isReq -> do
         toWidget [shamlet|
+$newline never
 <input id="#{theId}" name="#{name}" *{attrs} type="date" :isReq:required="" value="#{showVal val}">
 |]
         addScript' urlJqueryJs
@@ -71,9 +73,9 @@ jqueryDayField jds = Field
         addStylesheet' urlJqueryUiCss
         toWidget [julius|
 $(function(){
-    var i = $("##{theId}");
+    var i = document.getElementById("#{theId}");
-    if (i.attr("type") != "date") {
+    if (i.type != "date") {
-        i.datepicker({
+        $(i).datepicker({
             dateFormat:'yy-mm-dd',
             changeMonth:#{jsBool $ jdsChangeMonth jds},
             changeYear:#{jsBool $ jdsChangeYear jds},
@@ -100,9 +102,10 @@ $(function(){
 jqueryAutocompleteField :: (RenderMessage master FormMessage, YesodJquery master)
                         => Route master -> Field sub master Text
 jqueryAutocompleteField src = Field
-    { fieldParse = blank $ Right
+    { fieldParse = parseHelper $ Right
     , fieldView = \theId name attrs val isReq -> do
         toWidget [shamlet|
+$newline never
 <input id="#{theId}" name="#{name}" *{attrs} type="text" :isReq:required="" value="#{either id id val}" .autocomplete>
 |]
         addScript' urlJqueryJs

yesod-form/Yesod/Form/MassInput.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE CPP#-}
 module Yesod.Form.MassInput
     ( inputList
     , massDivs
@@ -14,7 +15,7 @@ import Yesod.Form.Fields (boolField)
 import Yesod.Widget (GWidget, whamlet)
 import Yesod.Message (RenderMessage)
 import Yesod.Handler (newIdent, GHandler)
-import Text.Blaze (Html)
+import Text.Blaze.Html (Html)
 import Control.Monad.Trans.Class (lift)
 import Control.Monad.Trans.RWS (get, put, ask)
 import Data.Maybe (fromMaybe)
@@ -75,6 +76,7 @@ inputList label fixXml single mdef = formToAForm $ do
         , fvTooltip = Nothing
         , fvId = theId
         , fvInput = [whamlet|
+$newline never
 ^{fixXml views}
 <p>
     $forall xml <- xmls
@@ -95,7 +97,10 @@ withDelete af = do
     deleteName <- newFormIdent
     (menv, _, _) <- ask
     res <- case menv >>= Map.lookup deleteName . fst of
-        Just ("yes":_) -> return $ Left [whamlet|<input type=hidden name=#{deleteName} value=yes>|]
+        Just ("yes":_) -> return $ Left [whamlet|
+$newline never
+<input type=hidden name=#{deleteName} value=yes>
+|]
         _ -> do
             (_, xml2) <- aFormToForm $ areq boolField FieldSettings
                 { fsLabel = SomeMessage MsgDelete
@@ -122,6 +127,7 @@ massDivs, massTable
          :: [[FieldView sub master]]
          -> GWidget sub master ()
 massDivs viewss = [whamlet|
+$newline never
 $forall views <- viewss
     <fieldset>
         $forall view <- views
@@ -135,6 +141,7 @@ $forall views <- viewss
 |]
 
 massTable viewss = [whamlet|
+$newline never
 $forall views <- viewss
     <fieldset>
         <table>

yesod-form/Yesod/Form/Nic.hs

@@ -3,6 +3,7 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE NoMonomorphismRestriction #-} -- FIXME remove
+{-# LANGUAGE CPP #-}
 -- | Provide the user with a rich text editor.
 module Yesod.Form.Nic
     ( YesodNic (..)
@@ -16,8 +17,14 @@ import Yesod.Widget
 import Text.HTML.SanitizeXSS (sanitizeBalance)
 import Text.Hamlet (Html, shamlet)
 import Text.Julius (julius)
-import Text.Blaze.Renderer.String (renderHtml)
+#if MIN_VERSION_blaze_html(0, 5, 0)
+import Text.Blaze (preEscapedToMarkup)
+import Text.Blaze.Html.Renderer.String (renderHtml)
+#define preEscapedText preEscapedToMarkup
+#else
 import Text.Blaze (preEscapedText)
+import Text.Blaze.Renderer.String (renderHtml)
+#endif
 import Data.Text (Text, pack)
 import Data.Maybe (listToMaybe)
 
@@ -31,6 +38,7 @@ nicHtmlField = Field
     { fieldParse = return . Right . fmap (preEscapedText . sanitizeBalance) . listToMaybe
     , fieldView = \theId name attrs val _isReq -> do
         toWidget [shamlet|
+$newline never
     <textarea id="#{theId}" *{attrs} name="#{name}" .html>#{showVal val}
 |]
         addScript' urlNicEdit

yesod-form/Yesod/Form/Types.hs

@@ -1,6 +1,8 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 module Yesod.Form.Types
     ( -- * Helpers
       Enctype (..)
@@ -22,11 +24,14 @@ import Control.Monad.Trans.RWS (RWST)
 import Yesod.Request (FileInfo)
 import Data.Text (Text)
 import Data.Monoid (Monoid (..))
-import Text.Blaze (Html, ToHtml (toHtml))
+import Text.Blaze (Markup, ToMarkup (toMarkup))
+#define Html Markup
+#define ToHtml ToMarkup
+#define toHtml toMarkup
 import Control.Applicative ((<$>), Applicative (..))
 import Control.Monad (liftM)
 import Data.String (IsString (..))
-import Yesod.Core (GHandler, GWidget, SomeMessage)
+import Yesod.Core (GHandler, GWidget, SomeMessage, MonadLift (..))
 import qualified Data.Map as Map
 
 -- | A form can produce three different results: there was no data available,
@@ -93,6 +98,10 @@ instance Applicative (AForm sub master) where
 instance Monoid a => Monoid (AForm sub master a) where
     mempty = pure mempty
     mappend a b = mappend <$> a <*> b
+instance MonadLift (GHandler sub master) (AForm sub master) where
+    lift f = AForm $ \_ _ ints -> do
+        x <- f
+        return (FormSuccess x, id, ints, mempty)
 
 data FieldSettings master = FieldSettings
     { fsLabel :: SomeMessage master
@@ -116,12 +125,11 @@ data FieldView sub master = FieldView
 
 data Field sub master a = Field
     { fieldParse :: [Text] -> GHandler sub master (Either (SomeMessage master) (Maybe a))
-    -- | ID, name, attrs, (invalid text OR legimiate result), required?
+    , fieldView :: Text -- ^ ID
-    , fieldView :: Text
+                -> Text -- ^ Name
-                -> Text
+                -> [(Text, Text)] -- ^ Attributes
-                -> [(Text, Text)]
+                -> Either Text a -- ^ Either (invalid text) or (legitimate result)
-                -> Either Text a
+                -> Bool -- ^ Required?
-                -> Bool
                 -> GWidget sub master ()
     }
 
@@ -143,3 +151,4 @@ data FormMessage = MsgInvalidInteger Text
                  | MsgBoolYes
                  | MsgBoolNo
                  | MsgDelete
+    deriving (Show, Eq, Read)

yesod-form/test/main.hs

@@ -0,0 +1,41 @@
+{-# LANGUAGE OverloadedStrings #-}
+import Test.HUnit
+import Test.Hspec.Monadic
+import Test.Hspec.HUnit ()
+import Data.Time (TimeOfDay (TimeOfDay))
+import Data.Text (pack)
+
+import Yesod.Form.Fields (parseTime)
+import Yesod.Form.Types
+
+main :: IO ()
+main = hspec $
+    describe "parseTime" $ mapM_ (\(s, e) -> it s $ parseTime (pack s) @?= e)
+        [ ("01:00:00", Right $ TimeOfDay 1 0 0)
+        , ("1:00", Right $ TimeOfDay 1 0 0)
+        , ("1:00 AM", Right $ TimeOfDay 1 0 0)
+        , ("1:00 am", Right $ TimeOfDay 1 0 0)
+        , ("1:00AM", Right $ TimeOfDay 1 0 0)
+        , ("1:00am", Right $ TimeOfDay 1 0 0)
+        , ("01:00:00am", Right $ TimeOfDay 1 0 0)
+        , ("01:00:00 am", Right $ TimeOfDay 1 0 0)
+        , ("01:00:00AM", Right $ TimeOfDay 1 0 0)
+        , ("01:00:00 AM", Right $ TimeOfDay 1 0 0)
+        , ("1:00:01", Right $ TimeOfDay 1 0 1)
+        , ("1:00:02 AM", Right $ TimeOfDay 1 0 2)
+        , ("1:00:04 am", Right $ TimeOfDay 1 0 4)
+        , ("1:00:05 am", Right $ read "01:00:05")
+        , ("1:00:64 am", Left $ MsgInvalidSecond "64")
+        , ("1:00:4 am", Left $ MsgInvalidSecond "4")
+        , ("0:00", Right $ TimeOfDay 0 0 0)
+        , ("12:00am", Right $ TimeOfDay 0 0 0)
+        , ("12:59:59am", Right $ TimeOfDay 0 59 59)
+        , ("12:59:60am", Left $ MsgInvalidSecond "60")
+        , ("12:60:59am", Left $ MsgInvalidMinute "60")
+        , ("12:00pm", Right $ TimeOfDay 12 0 0)
+        , ("12:59:59pm", Right $ TimeOfDay 12 59 59)
+        , ("12:59:60pm", Left $ MsgInvalidSecond "60")
+        , ("12:60:59pm", Left $ MsgInvalidMinute "60")
+        , ("12:7pm", Left $ MsgInvalidMinute "7")
+        , ("23:47", Right $ TimeOfDay 23 47 0)
+        ]

yesod-form/yesod-form.cabal

@@ -1,5 +1,5 @@
 name:            yesod-form
-version:         1.0.0
+version:         1.1.3
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>
@@ -7,32 +7,36 @@ maintainer:      Michael Snoyman <michael@snoyman.com>
 synopsis:        Form handling support for Yesod Web Framework
 category:        Web, Yesod
 stability:       Stable
-cabal-version:   >= 1.6
+cabal-version:   >= 1.8
 build-type:      Simple
 homepage:        http://www.yesodweb.com/
 description:     Form handling support for Yesod Web Framework
 
 library
     build-depends:   base                  >= 4        && < 5
-                   , yesod-core            >= 1.0      && < 1.1
+                   , yesod-core            >= 1.1      && < 1.2
-                   , yesod-persistent      >= 1.0      && < 1.1
+                   , yesod-persistent      >= 1.1      && < 1.2
                    , time                  >= 1.1.4
-                   , hamlet                >= 1.0      && < 1.1
+                   , hamlet                >= 1.1      && < 1.2
                    , shakespeare-css       >= 1.0      && < 1.1
                    , shakespeare-js        >= 1.0      && < 1.1
-                   , persistent            >= 0.9      && < 0.10
+                   , persistent            >= 1.0      && < 1.1
                    , template-haskell
                    , transformers          >= 0.2.2    && < 0.4
-                   , data-default          >= 0.3      && < 0.4
+                   , data-default
                    , xss-sanitize          >= 0.3.0.1  && < 0.4
                    , blaze-builder         >= 0.2.1.4  && < 0.4
-                   , network               >= 2.2      && < 2.4
+                   , network               >= 2.2
                    , email-validate        >= 0.2.6    && < 0.3
-                   , blaze-html            >= 0.4.1.3  && < 0.5
+                   , bytestring            >= 0.9.1.4
-                   , bytestring            >= 0.9.1.4  && < 0.10
                    , text                  >= 0.9      && < 1.0
-                   , wai                   >= 1.2      && < 1.3
+                   , wai                   >= 1.3      && < 1.4
-                   , containers            >= 0.2      && < 0.5
+                   , containers            >= 0.2
+                   , blaze-html            >= 0.5      && < 0.6
+                   , blaze-markup          >= 0.5.1    && < 0.6
+                   , attoparsec            >= 0.10     && < 0.11
+                   , crypto-api            >= 0.8      && < 0.11
+
     exposed-modules: Yesod.Form
                      Yesod.Form.Class
                      Yesod.Form.Types
@@ -46,9 +50,23 @@ library
                      Yesod.Form.I18n.Portuguese
                      Yesod.Form.I18n.Swedish
                      Yesod.Form.I18n.German
+                     Yesod.Form.I18n.French
+                     Yesod.Form.I18n.Norwegian
+                     Yesod.Form.I18n.Japanese
                      -- FIXME Yesod.Helpers.Crud
     ghc-options:     -Wall
 
+test-suite test
+    type: exitcode-stdio-1.0
+    main-is: main.hs
+    hs-source-dirs: test
+    build-depends:          base
+                          , yesod-form
+                          , time
+                          , hspec
+                          , HUnit
+                          , text
+
 source-repository head
   type:     git
   location: https://github.com/yesodweb/yesod

yesod-json/LICENSE

@@ -1,25 +1,20 @@
-The following license covers this documentation, and the source code, except
+Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/
-where otherwise indicated.
 
-Copyright 2010, Michael Snoyman. All rights reserved.
+Permission is hereby granted, free of charge, to any person obtaining
+a copy of this software and associated documentation files (the
+"Software"), to deal in the Software without restriction, including
+without limitation the rights to use, copy, modify, merge, publish,
+distribute, sublicense, and/or sell copies of the Software, and to
+permit persons to whom the Software is furnished to do so, subject to
+the following conditions:
 
-Redistribution and use in source and binary forms, with or without
+The above copyright notice and this permission notice shall be
-modification, are permitted provided that the following conditions are met:
+included in all copies or substantial portions of the Software.
 
-* Redistributions of source code must retain the above copyright notice, this
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
-  list of conditions and the following disclaimer.
+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
-
+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
-* Redistributions in binary form must reproduce the above copyright notice,
+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
-  this list of conditions and the following disclaimer in the documentation
+LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
-  and/or other materials provided with the distribution.
+OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
-
+WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
-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-json/Yesod/Json.hs

@@ -18,6 +18,7 @@ module Yesod.Json
 
       -- * Convenience functions
     , jsonOrRedirect
+    , acceptsJson
     ) where
 
 import Yesod.Handler (GHandler, waiRequest, lift, invalidArgs, redirect)
@@ -109,7 +110,8 @@ array = J.Array . V.fromList . map J.toJSON
 -- | jsonOrRedirect simplifies the scenario where a POST handler sends a different
 -- response based on Accept headers:
 --
---     1. 200 with JSON data if the client prefers application/json (e.g. AJAX).
+--     1. 200 with JSON data if the client prefers
+--     @application\/json@ (e.g. AJAX, see 'acceptsJSON').
 --
 --     2. 3xx otherwise, following the PRG pattern.
 jsonOrRedirect :: (Yesod master, J.ToJSON a)
@@ -120,9 +122,12 @@ jsonOrRedirect r j = do
     q <- acceptsJson
     if q then jsonToRepJson (J.toJSON j)
          else redirect r
-  where
+
-    acceptsJson = maybe False ((== "application/json") . B8.takeWhile (/= ';'))
+-- | Returns @True@ if the client prefers @application\/json@ as
-                . join
+-- indicated by the @Accept@ HTTP header.
-                . fmap (headMay . parseHttpAccept)
+acceptsJson :: Yesod master => GHandler sub master Bool
-                . lookup "Accept" . requestHeaders
+acceptsJson =  maybe False ((== "application/json") . B8.takeWhile (/= ';'))
-                <$> waiRequest
+            .  join
+            .  fmap (headMay . parseHttpAccept)
+            .  lookup "Accept" . requestHeaders
+           <$> waiRequest

yesod-json/yesod-json.cabal

@@ -1,5 +1,5 @@
 name:            yesod-json
-version:         1.0.0
+version:         1.1.0
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>
@@ -14,20 +14,20 @@ description:     Generate content for Yesod using the aeson package.
 
 library
     build-depends:   base                  >= 4        && < 5
-                   , yesod-core            >= 1.0      && < 1.1
+                   , yesod-core            >= 1.1      && < 1.2
-                   , yesod-routes          >= 1.0      && < 1.1
+                   , yesod-routes          >= 1.1      && < 1.2
                    , aeson                 >= 0.5
                    , text                  >= 0.8      && < 1.0
                    , shakespeare-js        >= 1.0      && < 1.1
                    , vector                >= 0.9
                    , containers            >= 0.2
                    , blaze-builder
-                   , attoparsec-conduit    >= 0.4      && < 0.5
+                   , attoparsec-conduit    >= 0.5      && < 0.6
-                   , conduit               >= 0.4      && < 0.5
+                   , conduit               >= 0.5      && < 0.6
                    , transformers          >= 0.2.2    && < 0.4
-                   , wai                   >= 1.2      && < 1.3
+                   , wai                   >= 1.3      && < 1.4
-                   , wai-extra             >= 1.2      && < 1.3
+                   , wai-extra             >= 1.3      && < 1.4
-                   , bytestring            >= 0.9      && < 0.10
+                   , bytestring            >= 0.9
                    , safe                  >= 0.2      && < 0.4
     exposed-modules: Yesod.Json
     ghc-options:     -Wall

yesod-newsfeed/LICENSE

@@ -1,25 +1,20 @@
-The following license covers this documentation, and the source code, except
+Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/
-where otherwise indicated.
 
-Copyright 2010, Michael Snoyman. All rights reserved.
+Permission is hereby granted, free of charge, to any person obtaining
+a copy of this software and associated documentation files (the
+"Software"), to deal in the Software without restriction, including
+without limitation the rights to use, copy, modify, merge, publish,
+distribute, sublicense, and/or sell copies of the Software, and to
+permit persons to whom the Software is furnished to do so, subject to
+the following conditions:
 
-Redistribution and use in source and binary forms, with or without
+The above copyright notice and this permission notice shall be
-modification, are permitted provided that the following conditions are met:
+included in all copies or substantial portions of the Software.
 
-* Redistributions of source code must retain the above copyright notice, this
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
-  list of conditions and the following disclaimer.
+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
-
+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
-* Redistributions in binary form must reproduce the above copyright notice,
+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
-  this list of conditions and the following disclaimer in the documentation
+LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
-  and/or other materials provided with the distribution.
+OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
-
+WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
-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-newsfeed/Yesod/AtomFeed.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE CPP #-}
 ---------------------------------------------------------
 --
 -- Module        : Yesod.AtomFeed
@@ -30,7 +31,8 @@ import qualified Data.ByteString.Char8 as S8
 import Data.Text (Text)
 import Data.Text.Lazy (toStrict)
 import Text.XML
-import Text.Blaze.Renderer.Text (renderHtml)
+import Text.Blaze.Html.Renderer.Text (renderHtml)
+import qualified Data.Map as Map
 
 newtype RepAtom = RepAtom Content
 instance HasReps RepAtom where
@@ -50,21 +52,22 @@ template Feed {..} render =
     addNS' n = n
     namespace = "http://www.w3.org/2005/Atom"
 
-    root = Element "feed" [] $ map NodeElement
+    root = Element "feed" Map.empty $ map NodeElement
-        $ Element "title" [] [NodeContent feedTitle]
+        $ Element "title" Map.empty [NodeContent feedTitle]
-        : Element "link" [("rel", "self"), ("href", render feedLinkSelf)] []
+        : Element "link" (Map.fromList [("rel", "self"), ("href", render feedLinkSelf)]) []
-        : Element "link" [("href", render feedLinkHome)] []
+        : Element "link" (Map.singleton "href" $ render feedLinkHome) []
-        : Element "updated" [] [NodeContent $ formatW3 feedUpdated]
+        : Element "updated" Map.empty [NodeContent $ formatW3 feedUpdated]
-        : Element "id" [] [NodeContent $ render feedLinkHome]
+        : Element "id" Map.empty [NodeContent $ render feedLinkHome]
+        : Element "author" Map.empty [NodeContent feedAuthor]
         : map (flip entryTemplate render) feedEntries
 
 entryTemplate :: FeedEntry url -> (url -> Text) -> Element
-entryTemplate FeedEntry {..} render = Element "entry" [] $ map NodeElement
+entryTemplate FeedEntry {..} render = Element "entry" Map.empty $ map NodeElement
-    [ Element "id" [] [NodeContent $ render feedEntryLink]
+    [ Element "id" Map.empty [NodeContent $ render feedEntryLink]
-    , Element "link" [("href", render feedEntryLink)] []
+    , Element "link" (Map.singleton "href" $ render feedEntryLink) []
-    , Element "updated" [] [NodeContent $ formatW3 feedEntryUpdated]
+    , Element "updated" Map.empty [NodeContent $ formatW3 feedEntryUpdated]
-    , Element "title" [] [NodeContent feedEntryTitle]
+    , Element "title" Map.empty [NodeContent feedEntryTitle]
-    , Element "content" [("type", "html")] [NodeContent $ toStrict $ renderHtml feedEntryContent]
+    , Element "content" (Map.singleton "type" "html") [NodeContent $ toStrict $ renderHtml feedEntryContent]
     ]
 
 -- | Generates a link tag in the head of a widget.
@@ -72,5 +75,6 @@ atomLink :: Route m
          -> Text -- ^ title
          -> GWidget s m ()
 atomLink r title = toWidgetHead [hamlet|
+$newline never
 <link href=@{r} type=#{S8.unpack typeAtom} rel="alternate" title=#{title}>
 |]

yesod-newsfeed/Yesod/FeedTypes.hs

@@ -7,11 +7,12 @@ import Text.Hamlet      (Html)
 import Data.Time.Clock  (UTCTime)
 import Data.Text        (Text)
 
--- | The overal feed
+-- | The overall feed
 data Feed url = Feed
     { feedTitle       :: Text
     , feedLinkSelf    :: url
     , feedLinkHome    :: url
+    , feedAuthor      :: Text
 
 
     -- | note: currently only used for Rss

yesod-newsfeed/Yesod/RssFeed.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE CPP #-}
 -------------------------------------------------------------------------------
 --
 -- Module        : Yesod.RssFeed
@@ -26,7 +27,8 @@ import qualified Data.ByteString.Char8 as S8
 import Data.Text (Text, pack)
 import Data.Text.Lazy (toStrict)
 import Text.XML
-import Text.Blaze.Renderer.Text (renderHtml)
+import Text.Blaze.Html.Renderer.Text (renderHtml)
+import qualified Data.Map as Map
 
 newtype RepRss = RepRss Content
 instance HasReps RepRss where
@@ -42,26 +44,26 @@ template :: Feed url -> (url -> Text) -> Document
 template Feed {..} render =
     Document (Prologue [] Nothing []) root []
   where
-    root = Element "rss" [("version", "2.0")] $ return $ NodeElement $ Element "channel" [] $ map NodeElement
+    root = Element "rss" (Map.singleton "version" "2.0") $ return $ NodeElement $ Element "channel" Map.empty $ map NodeElement
-        $ Element "{http://www.w3.org/2005/Atom}link"
+        $ Element "{http://www.w3.org/2005/Atom}link" (Map.fromList
             [ ("href", render feedLinkSelf)
             , ("rel", "self")
             , ("type", pack $ S8.unpack typeRss)
-            ] []
+            ]) []
-        : Element "title" [] [NodeContent feedTitle]
+        : Element "title" Map.empty [NodeContent feedTitle]
-        : Element "link" [] [NodeContent $ render feedLinkHome]
+        : Element "link" Map.empty [NodeContent $ render feedLinkHome]
-        : Element "description" [] [NodeContent $ toStrict $ renderHtml feedDescription]
+        : Element "description" Map.empty [NodeContent $ toStrict $ renderHtml feedDescription]
-        : Element "lastBuildDate" [] [NodeContent $ formatRFC822 feedUpdated]
+        : Element "lastBuildDate" Map.empty [NodeContent $ formatRFC822 feedUpdated]
-        : Element "language" [] [NodeContent feedLanguage]
+        : Element "language" Map.empty [NodeContent feedLanguage]
         : map (flip entryTemplate render) feedEntries
 
 entryTemplate :: FeedEntry url -> (url -> Text) -> Element
-entryTemplate FeedEntry {..} render = Element "item" [] $ map NodeElement
+entryTemplate FeedEntry {..} render = Element "item" Map.empty $ map NodeElement
-    [ Element "title" [] [NodeContent feedEntryTitle]
+    [ Element "title" Map.empty [NodeContent feedEntryTitle]
-    , Element "link" [] [NodeContent $ render feedEntryLink]
+    , Element "link" Map.empty [NodeContent $ render feedEntryLink]
-    , Element "guid" [] [NodeContent $ render feedEntryLink]
+    , Element "guid" Map.empty [NodeContent $ render feedEntryLink]
-    , Element "pubDate" [] [NodeContent $ formatRFC822 feedEntryUpdated]
+    , Element "pubDate" Map.empty [NodeContent $ formatRFC822 feedEntryUpdated]
-    , Element "description" [] [NodeContent $ toStrict $ renderHtml feedEntryContent]
+    , Element "description" Map.empty [NodeContent $ toStrict $ renderHtml feedEntryContent]
     ]
 
 -- | Generates a link tag in the head of a widget.
@@ -69,5 +71,6 @@ rssLink :: Route m
         -> Text -- ^ title
         -> GWidget s m ()
 rssLink r title = toWidgetHead [hamlet|
+$newline never
     <link href=@{r} type=#{S8.unpack typeRss} rel="alternate" title=#{title}>
     |]

yesod-newsfeed/yesod-newsfeed.cabal

@@ -1,5 +1,5 @@
 name:            yesod-newsfeed
-version:         1.0.0
+version:         1.1.0
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman, Patrick Brisbin
@@ -14,13 +14,16 @@ description:     Helper functions and data types for producing News feeds.
 
 library
     build-depends:   base                 >= 4        && < 5
-                   , yesod-core           >= 1.0      && < 1.1
+                   , yesod-core           >= 1.1      && < 1.2
                    , time                 >= 1.1.4
-                   , hamlet               >= 1.0      && < 1.1
+                   , hamlet               >= 1.1      && < 1.2
-                   , bytestring           >= 0.9.1.4  && < 0.10
+                   , bytestring           >= 0.9.1.4
                    , text                 >= 0.9      && < 0.12
-                   , xml-conduit          >= 0.7      && < 0.8
+                   , xml-conduit          >= 1.0      && < 1.1
-                   , blaze-html           >= 0.4      && < 0.5
+                   , blaze-html           >= 0.5      && < 0.6
+                   , blaze-markup         >= 0.5.1    && < 0.6
+                   , containers
+
     exposed-modules: Yesod.AtomFeed
                    , Yesod.RssFeed
                    , Yesod.Feed

yesod-persistent/LICENSE

@@ -1,25 +1,20 @@
-The following license covers this documentation, and the source code, except
+Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/
-where otherwise indicated.
 
-Copyright 2010, Michael Snoyman. All rights reserved.
+Permission is hereby granted, free of charge, to any person obtaining
+a copy of this software and associated documentation files (the
+"Software"), to deal in the Software without restriction, including
+without limitation the rights to use, copy, modify, merge, publish,
+distribute, sublicense, and/or sell copies of the Software, and to
+permit persons to whom the Software is furnished to do so, subject to
+the following conditions:
 
-Redistribution and use in source and binary forms, with or without
+The above copyright notice and this permission notice shall be
-modification, are permitted provided that the following conditions are met:
+included in all copies or substantial portions of the Software.
 
-* Redistributions of source code must retain the above copyright notice, this
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
-  list of conditions and the following disclaimer.
+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
-
+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
-* Redistributions in binary form must reproduce the above copyright notice,
+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
-  this list of conditions and the following disclaimer in the documentation
+LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
-  and/or other materials provided with the distribution.
+OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
-
+WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
-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-persistent/yesod-persistent.cabal

@@ -1,5 +1,5 @@
 name:            yesod-persistent
-version:         1.0.0
+version:         1.1.0
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>
@@ -14,9 +14,9 @@ description:     Some helpers for using Persistent from Yesod.
 
 library
     build-depends:   base                      >= 4        && < 5
-                   , yesod-core                >= 1.0      && < 1.1
+                   , yesod-core                >= 1.1      && < 1.2
-                   , persistent                >= 0.9      && < 0.10
+                   , persistent                >= 1.0      && < 1.1
-                   , persistent-template       >= 0.9      && < 0.10
+                   , persistent-template       >= 1.0      && < 1.1
                    , transformers              >= 0.2.2    && < 0.4
     exposed-modules: Yesod.Persist
     ghc-options:     -Wall

yesod-platform/LICENSE

@@ -1,25 +1,20 @@
-The following license covers this documentation, and the source code, except
+Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/
-where otherwise indicated.
 
-Copyright 2010, Michael Snoyman. All rights reserved.
+Permission is hereby granted, free of charge, to any person obtaining
+a copy of this software and associated documentation files (the
+"Software"), to deal in the Software without restriction, including
+without limitation the rights to use, copy, modify, merge, publish,
+distribute, sublicense, and/or sell copies of the Software, and to
+permit persons to whom the Software is furnished to do so, subject to
+the following conditions:
 
-Redistribution and use in source and binary forms, with or without
+The above copyright notice and this permission notice shall be
-modification, are permitted provided that the following conditions are met:
+included in all copies or substantial portions of the Software.
 
-* Redistributions of source code must retain the above copyright notice, this
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
-  list of conditions and the following disclaimer.
+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
-
+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
-* Redistributions in binary form must reproduce the above copyright notice,
+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
-  this list of conditions and the following disclaimer in the documentation
+LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
-  and/or other materials provided with the distribution.
+OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
-
+WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
-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-platform/make-cabal.sh

@@ -7,4 +7,4 @@ then
     cabal install cabal-nirvana -fgenerate
 fi
 
-cabal-nirvana-generate yesod | runghc to-cabal.hs > yesod-platform.cabal
+cabal-nirvana-generate yesod yesod-static yesod-default hjsmin blaze-html yesod-test | runghc to-cabal.hs > yesod-platform.cabal

yesod-platform/to-cabal.hs

@@ -3,14 +3,14 @@ import Control.Applicative ((<$>))
 
 main = do
     pkgs <- map (intercalate " == ")
-          . filter (\xs -> not $ ["parsec"] `isPrefixOf` xs)
+          . filter (\xs -> not $ any (`isPrefixOf` xs) $ map return ["parsec", "text", "transformers", "mtl", "HUnit", "QuickCheck", "binary", "zlib", "stm", "regex-compat"])
           . map words
           . filter (not . null)
           . lines
         <$> getContents
     putStrLn "name:            yesod-platform"
     putStrLn "version:         FIXME"
-    putStrLn "license:         BSD3"
+    putStrLn "license:         MIT"
     putStrLn "license-file:    LICENSE"
     putStrLn "author:          Michael Snoyman <michael@snoyman.com>"
     putStrLn "maintainer:      Michael Snoyman <michael@snoyman.com>"

yesod-platform/yesod-platform.cabal

@@ -0,0 +1,137 @@
+name:            yesod-platform
+version:         1.1.3
+license:         MIT
+license-file:    LICENSE
+author:          Michael Snoyman <michael@snoyman.com>
+maintainer:      Michael Snoyman <michael@snoyman.com>
+synopsis:        Meta package for Yesod
+description:     Instead of allowing version ranges of dependencies, this package requires specific versions to avoid dependency hell
+category:        Web, Yesod
+stability:       Stable
+cabal-version:   >= 1.6
+build-type:      Simple
+homepage:        http://www.yesodweb.com/
+
+library
+    build-depends: base >= 4 && < 5
+                 , SHA == 1.5.1
+                 , aeson == 0.6.0.2
+                 , ansi-terminal == 0.5.5
+                 , asn1-data == 0.7.1
+                 , attoparsec == 0.10.2.0
+                 , attoparsec-conduit == 0.5.0.2
+                 , authenticate == 1.3.1.1
+                 , base-unicode-symbols == 0.2.2.4
+                 , base64-bytestring == 1.0.0.0
+                 , blaze-builder == 0.3.1.0
+                 , blaze-builder-conduit == 0.5.0.1
+                 , blaze-html == 0.5.1.0
+                 , blaze-markup == 0.5.1.1
+                 , byteorder == 1.0.3
+                 , case-insensitive == 0.4.0.3
+                 , cereal == 0.3.5.2
+                 , certificate == 1.2.8
+                 , clientsession == 0.8.0.1
+                 , conduit == 0.5.2.4
+                 , cookie == 0.4.0.1
+                 , cprng-aes == 0.2.4
+                 , cpu == 0.1.1
+                 , crypto-api == 0.10.2
+                 , crypto-conduit == 0.4.0.1
+                 , crypto-pubkey-types == 0.1.1
+                 , cryptocipher == 0.3.5
+                 , cryptohash == 0.7.5
+                 , css-text == 0.1.1
+                 , data-default == 0.5.0
+                 , date-cache == 0.3.0
+                 , dlist == 0.5
+                 , email-validate == 0.2.8
+                 , entropy == 0.2.1
+                 , failure == 0.2.0.1
+                 , fast-logger == 0.3.1
+                 , file-embed == 0.0.4.5
+                 , filesystem-conduit == 0.5.0.1
+                 , hamlet == 1.1.1
+                 , hashable == 1.1.2.5
+                 , hjsmin == 0.1.2
+                 , hspec == 1.3.0
+                 , hspec-expectations == 0.3.0.2
+                 , html-conduit == 0.1.0.2
+                 , http-conduit == 1.6.1
+                 , http-date == 0.0.2
+                 , http-types == 0.7.3.0.1
+                 , language-javascript == 0.5.4
+                 , largeword == 1.0.3
+                 , lifted-base == 0.1.2
+                 , mime-mail == 0.4.1.2
+                 , mime-types == 0.1.0.0
+                 , monad-control == 0.3.1.4
+                 , monad-logger == 0.2.1
+                 , network-conduit == 0.5.0.2
+                 , path-pieces == 0.1.2
+                 , pem == 0.1.1
+                 , persistent == 1.0.1.2
+                 , persistent-template == 1.0.0.2
+                 , pool-conduit == 0.1.0.3
+                 , primitive == 0.4.1
+                 , pureMD5 == 2.1.2.1
+                 , pwstore-fast == 2.3
+                 , ranges == 0.2.4
+                 , resource-pool == 0.2.1.1
+                 , resourcet == 0.4.0.1
+                 , safe == 0.3.3
+                 , semigroups == 0.8.4.1
+                 , shakespeare == 1.0.1.4
+                 , shakespeare-css == 1.0.1.5
+                 , shakespeare-i18n == 1.0.0.2
+                 , shakespeare-js == 1.0.0.6
+                 , shakespeare-text == 1.0.0.5
+                 , silently == 1.2.0.2
+                 , simple-sendfile == 0.2.7
+                 , skein == 0.1.0.9
+                 , socks == 0.4.2
+                 , stringsearch == 0.3.6.3
+                 , system-fileio == 0.3.10
+                 , system-filepath == 0.4.7
+                 , tagged == 0.4.4
+                 , tagsoup == 0.12.8
+                 , tagstream-conduit == 0.5.3
+                 , tar == 0.4.0.0
+                 , tls == 0.9.11
+                 , tls-extra == 0.4.6
+                 , transformers-base == 0.4.1
+                 , unix-compat == 0.3.0.2
+                 , unordered-containers == 0.2.2.1
+                 , utf8-light == 0.4.0.1
+                 , utf8-string == 0.3.7
+                 , vault == 0.2.0.1
+                 , vector == 0.9.1
+                 , void == 0.5.8
+                 , wai == 1.3.0.1
+                 , wai-app-static == 1.3.0.2
+                 , wai-extra == 1.3.0.2
+                 , wai-logger == 0.3.0
+                 , wai-test == 1.3.0
+                 , warp == 1.3.2
+                 , xml-conduit == 1.0.3.1
+                 , xml-types == 0.3.3
+                 , xss-sanitize == 0.3.2
+                 , yaml == 0.8.0.2
+                 , yesod == 1.1.1
+                 , yesod-auth == 1.1.1.1
+                 , yesod-core == 1.1.2
+                 , yesod-default == 1.1.0
+                 , yesod-form == 1.1.3
+                 , yesod-json == 1.1.0
+                 , yesod-persistent == 1.1.0
+                 , yesod-routes == 1.1.0
+                 , yesod-static == 1.1.0.1
+                 , yesod-test == 0.3.0.1
+                 , zlib-bindings == 0.1.1.1
+                 , zlib-conduit == 0.5.0.1
+
+    exposed-modules: Yesod.Platform
+
+source-repository head
+  type:     git
+  location: https://github.com/yesodweb/yesod

yesod-routes/LICENSE

@@ -1,25 +1,20 @@
-The following license covers this documentation, and the source code, except
+Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/
-where otherwise indicated.
 
-Copyright 2010, Michael Snoyman. All rights reserved.
+Permission is hereby granted, free of charge, to any person obtaining
+a copy of this software and associated documentation files (the
+"Software"), to deal in the Software without restriction, including
+without limitation the rights to use, copy, modify, merge, publish,
+distribute, sublicense, and/or sell copies of the Software, and to
+permit persons to whom the Software is furnished to do so, subject to
+the following conditions:
 
-Redistribution and use in source and binary forms, with or without
+The above copyright notice and this permission notice shall be
-modification, are permitted provided that the following conditions are met:
+included in all copies or substantial portions of the Software.
 
-* Redistributions of source code must retain the above copyright notice, this
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
-  list of conditions and the following disclaimer.
+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
-
+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
-* Redistributions in binary form must reproduce the above copyright notice,
+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
-  this list of conditions and the following disclaimer in the documentation
+LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
-  and/or other materials provided with the distribution.
+OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
-
+WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
-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-routes/Yesod/Routes/Overlap.hs

@@ -2,27 +2,41 @@
 module Yesod.Routes.Overlap
     ( findOverlaps
     , findOverlapNames
+    , Overlap (..)
     ) where
 
 import Yesod.Routes.TH.Types
-import Control.Arrow ((***))
+import Data.List (intercalate)
-import Data.Maybe (mapMaybe)
 
-findOverlaps :: [Resource t] -> [(Resource t, Resource t)]
+data Overlap t = Overlap
-findOverlaps [] = []
+    { overlapParents :: [String] -> [String] -- ^ parent resource trees
-findOverlaps (x:xs) = mapMaybe (findOverlap x) xs ++ findOverlaps xs
+    , overlap1 :: ResourceTree t
+    , overlap2 :: ResourceTree t
+    }
 
-findOverlap :: Resource t -> Resource t -> Maybe (Resource t, Resource t)
+findOverlaps :: ([String] -> [String]) -> [ResourceTree t] -> [Overlap t]
-findOverlap x y
+findOverlaps _ [] = []
-    | overlaps (resourcePieces x) (resourcePieces y) (hasSuffix x) (hasSuffix y) = Just (x, y)
+findOverlaps front (x:xs) = concatMap (findOverlap front x) xs ++ findOverlaps front xs
-    | otherwise = Nothing
 
-hasSuffix :: Resource t -> Bool
+findOverlap :: ([String] -> [String]) -> ResourceTree t -> ResourceTree t -> [Overlap t]
-hasSuffix r =
+findOverlap front x y =
+    here rest
+  where
+    here
+        | overlaps (resourceTreePieces x) (resourceTreePieces y) (hasSuffix x) (hasSuffix y) = (Overlap front x y:)
+        | otherwise = id
+    rest =
+        case x of
+            ResourceParent name _ children -> findOverlaps (front . (name:)) children
+            ResourceLeaf{} -> []
+
+hasSuffix :: ResourceTree t -> Bool
+hasSuffix (ResourceLeaf r) =
     case resourceDispatch r of
         Subsite{} -> True
         Methods Just{} _ -> True
         Methods Nothing _ -> False
+hasSuffix ResourceParent{} = True
 
 overlaps :: [(CheckOverlap, Piece t)] -> [(CheckOverlap, Piece t)] -> Bool -> Bool -> Bool
 
@@ -50,9 +64,14 @@ piecesOverlap :: Piece t -> Piece t -> Bool
 piecesOverlap (Static x) (Static y) = x == y
 piecesOverlap _ _ = True
 
-findOverlapNames :: [Resource t] -> [(String, String)]
+findOverlapNames :: [ResourceTree t] -> [(String, String)]
-findOverlapNames = map (resourceName *** resourceName) . findOverlaps
+findOverlapNames =
-
+    map go . findOverlaps id
+  where
+    go (Overlap front x y) =
+        (go' $ resourceTreeName x, go' $ resourceTreeName y)
+      where
+        go' = intercalate "/" . front . return
 {-
 -- n^2, should be a way to speed it up
 findOverlaps :: [Resource a] -> [[Resource a]]

yesod-routes/Yesod/Routes/Parse.hs

@@ -10,7 +10,6 @@ module Yesod.Routes.Parse
     ) where
 
 import Language.Haskell.TH.Syntax
-import Data.Maybe
 import Data.Char (isUpper)
 import Language.Haskell.TH.Quote
 import qualified System.IO as SIO
@@ -55,18 +54,29 @@ parseRoutesNoCheck = QuasiQuoter
 -- | Convert a multi-line string to a set of resources. See documentation for
 -- the format of this string. This is a partial function which calls 'error' on
 -- invalid input.
-resourcesFromString :: String -> [Resource String]
+resourcesFromString :: String -> [ResourceTree String]
 resourcesFromString =
-    mapMaybe go . lines
+    fst . parse 0 . lines
   where
-    go s =
+    parse _ [] = ([], [])
-        case takeWhile (/= "--") $ words s of
+    parse indent (thisLine:otherLines)
-            (pattern:constr:rest) ->
+        | length spaces < indent = ([], thisLine : otherLines)
-                let (pieces, mmulti) = piecesFromString $ drop1Slash pattern
+        | otherwise = (this others, remainder)
-                    disp = dispatchFromString rest mmulti
+      where
-                 in Just $ Resource constr pieces disp
+        spaces = takeWhile (== ' ') thisLine
-            [] -> Nothing
+        (others, remainder) = parse indent otherLines'
-            _ -> error $ "Invalid resource line: " ++ s
+        (this, otherLines') =
+            case takeWhile (/= "--") $ words thisLine of
+                [pattern, constr] | last constr == ':' ->
+                    let (children, otherLines'') = parse (length spaces + 1) otherLines
+                        (pieces, Nothing) = piecesFromString $ drop1Slash pattern
+                     in ((ResourceParent (init constr) pieces children :), otherLines'')
+                (pattern:constr:rest) ->
+                    let (pieces, mmulti) = piecesFromString $ drop1Slash pattern
+                        disp = dispatchFromString rest mmulti
+                     in ((ResourceLeaf (Resource constr pieces disp):), otherLines)
+                [] -> (id, otherLines)
+                _ -> error $ "Invalid resource line: " ++ thisLine
 
 dispatchFromString :: [String] -> Maybe String -> Dispatch String
 dispatchFromString rest mmulti

yesod-routes/Yesod/Routes/TH/Dispatch.hs

@@ -17,6 +17,16 @@ import Web.PathPieces (PathPiece (..), PathMultiPiece (..))
 import Control.Applicative ((<$>))
 import Data.List (foldl')
 
+data FlatResource a = FlatResource [(String, [(CheckOverlap, Piece a)])] String [(CheckOverlap, Piece a)] (Dispatch a)
+
+flatten :: [ResourceTree a] -> [FlatResource a]
+flatten =
+    concatMap (go id)
+  where
+    go front (ResourceLeaf (Resource a b c)) = [FlatResource (front []) a b c]
+    go front (ResourceParent name pieces children) =
+        concatMap (go (front . ((name, pieces):))) children
+
 -- |
 --
 -- This function will generate a single clause that will address all
@@ -83,9 +93,9 @@ import Data.List (foldl')
 mkDispatchClause :: Q Exp -- ^ runHandler function
                  -> Q Exp -- ^ dispatcher function
                  -> Q Exp -- ^ fixHandler function
-                 -> [Resource a]
+                 -> [ResourceTree a]
                  -> Q Clause
-mkDispatchClause runHandler dispatcher fixHandler ress = do
+mkDispatchClause runHandler dispatcher fixHandler ress' = do
     -- Allocate the names to be used. Start off with the names passed to the
     -- function itself (with a 0 suffix).
     --
@@ -130,22 +140,25 @@ mkDispatchClause runHandler dispatcher fixHandler ress = do
             Nothing -> $(return $ VarE app4040)
           |]
     return $ Clause pats (NormalB u) $ dispatchFun : methodMaps
+  where
+    ress = flatten ress'
 
 -- | Determine the name of the method map for a given resource name.
 methodMapName :: String -> Name
 methodMapName s = mkName $ "methods" ++ s
 
 buildMethodMap :: Q Exp -- ^ fixHandler
-               -> Resource a
+               -> FlatResource a
                -> Q (Maybe Dec)
-buildMethodMap _ (Resource _ _ (Methods _ [])) = return Nothing -- single handle function
+buildMethodMap _ (FlatResource _ _ _ (Methods _ [])) = return Nothing -- single handle function
-buildMethodMap fixHandler (Resource name pieces (Methods mmulti methods)) = do
+buildMethodMap fixHandler (FlatResource parents name pieces' (Methods mmulti methods)) = do
     fromList <- [|Map.fromList|]
     methods' <- mapM go methods
     let exp = fromList `AppE` ListE methods'
     let fun = FunD (methodMapName name) [Clause [] (NormalB exp) []]
     return $ Just fun
   where
+    pieces = concat $ map snd parents ++ [pieces']
     go method = do
         fh <- fixHandler
         let func = VarE $ mkName $ map toLower method ++ name
@@ -156,28 +169,31 @@ buildMethodMap fixHandler (Resource name pieces (Methods mmulti methods)) = do
         xs <- replicateM argCount $ newName "arg"
         let rhs = LamE (map VarP xs) $ fh `AppE` (foldl' AppE func $ map VarE xs)
         return $ TupE [pack' `AppE` LitE (StringL method), rhs]
-buildMethodMap _ (Resource _ _ Subsite{}) = return Nothing
+buildMethodMap _ (FlatResource _ _ _ Subsite{}) = return Nothing
 
 -- | Build a single 'D.Route' expression.
-buildRoute :: Q Exp -> Q Exp -> Q Exp -> Resource a -> Q Exp
+buildRoute :: Q Exp -> Q Exp -> Q Exp -> FlatResource a -> Q Exp
-buildRoute runHandler dispatcher fixHandler (Resource name resPieces resDisp) = do
+buildRoute runHandler dispatcher fixHandler (FlatResource parents name resPieces resDisp) = do
     -- First two arguments to D.Route
-    routePieces <- ListE <$> mapM (convertPiece . snd) resPieces
+    routePieces <- ListE <$> mapM (convertPiece . snd) allPieces
     isMulti <-
         case resDisp of
             Methods Nothing _ -> [|False|]
             _ -> [|True|]
 
-    [|D.Route $(return routePieces) $(return isMulti) $(routeArg3 runHandler dispatcher fixHandler name (map snd resPieces) resDisp)|]
+    [|D.Route $(return routePieces) $(return isMulti) $(routeArg3 runHandler dispatcher fixHandler parents name (map snd allPieces) resDisp)|]
+  where
+    allPieces = concat $ map snd parents ++ [resPieces]
 
 routeArg3 :: Q Exp -- ^ runHandler
           -> Q Exp -- ^ dispatcher
           -> Q Exp -- ^ fixHandler
+          -> [(String, [(CheckOverlap, Piece a)])]
           -> String -- ^ name of resource
           -> [Piece a]
           -> Dispatch a
           -> Q Exp
-routeArg3 runHandler dispatcher fixHandler name resPieces resDisp = do
+routeArg3 runHandler dispatcher fixHandler parents name resPieces resDisp = do
     pieces <- newName "pieces"
 
     -- Allocate input piece variables (xs) and variables that have been
@@ -187,8 +203,11 @@ routeArg3 runHandler dispatcher fixHandler name resPieces resDisp = do
             Static _ -> return Nothing
             Dynamic _ -> Just <$> newName "x"
 
-    ys <- forM (catMaybes xs) $ \x -> do
+    -- Note: the zipping with Ints is just a workaround for (apparently) a bug
-        y <- newName "y"
+    -- in GHC where the identifiers are considered to be overlapping. Using
+    -- newName should avoid the problem, but it doesn't.
+    ys <- forM (zip (catMaybes xs) [1..]) $ \(x, i) -> do
+        y <- newName $ "y" ++ show (i :: Int)
         return (x, y)
 
     -- In case we have multi pieces at the end
@@ -216,7 +235,7 @@ routeArg3 runHandler dispatcher fixHandler name resPieces resDisp = do
             _ -> return ([], [])
 
     -- The final expression that actually uses the values we've computed
-    caller <- buildCaller runHandler dispatcher fixHandler xrest name resDisp $ map snd ys ++ yrest'
+    caller <- buildCaller runHandler dispatcher fixHandler xrest parents name resDisp $ map snd ys ++ yrest'
 
     -- Put together all the statements
     just <- [|Just|]
@@ -239,11 +258,12 @@ buildCaller :: Q Exp -- ^ runHandler
             -> Q Exp -- ^ dispatcher
             -> Q Exp -- ^ fixHandler
             -> Name -- ^ xrest
+            -> [(String, [(CheckOverlap, Piece a)])]
             -> String -- ^ name of resource
             -> Dispatch a
             -> [Name] -- ^ ys
             -> Q Exp
-buildCaller runHandler dispatcher fixHandler xrest name resDisp ys = do
+buildCaller runHandler dispatcher fixHandler xrest parents name resDisp ys = do
     master <- newName "master"
     sub <- newName "sub"
     toMaster <- newName "toMaster"
@@ -254,7 +274,7 @@ buildCaller runHandler dispatcher fixHandler xrest name resDisp ys = do
     let pat = map VarP [master, sub, toMaster, app404, handler405, method]
 
     -- Create the route
-    let route = foldl' (\a b -> a `AppE` VarE b) (ConE $ mkName name) ys
+    let route = routeFromDynamics parents name ys
 
     exp <-
         case resDisp of
@@ -309,3 +329,16 @@ buildCaller runHandler dispatcher fixHandler xrest name resDisp ys = do
 convertPiece :: Piece a -> Q Exp
 convertPiece (Static s) = [|D.Static (pack $(lift s))|]
 convertPiece (Dynamic _) = [|D.Dynamic|]
+
+routeFromDynamics :: [(String, [(CheckOverlap, Piece a)])] -- ^ parents
+                  -> String -- ^ constructor name
+                  -> [Name]
+                  -> Exp
+routeFromDynamics [] name ys = foldl' (\a b -> a `AppE` VarE b) (ConE $ mkName name) ys
+routeFromDynamics ((parent, pieces):rest) name ys =
+    foldl' (\a b -> a `AppE` b) (ConE $ mkName parent) here
+  where
+    (here', ys') = splitAt (length $ filter (isDynamic . snd) pieces) ys
+    isDynamic Dynamic{} = True
+    isDynamic _ = False
+    here = map VarE here' ++ [routeFromDynamics rest name ys']

yesod-routes/Yesod/Routes/TH/RenderRoute.hs

@@ -14,17 +14,19 @@ import Control.Monad (replicateM)
 import Data.Text (pack)
 import Web.PathPieces (PathPiece (..), PathMultiPiece (..))
 import Yesod.Routes.Class
+import Data.Monoid (mconcat)
 
 -- | Generate the constructors of a route data type.
-mkRouteCons :: [Resource Type] -> [Con]
+mkRouteCons :: [ResourceTree Type] -> ([Con], [Dec])
 mkRouteCons =
-    map mkRouteCon
+    mconcat . map mkRouteCon
   where
-    mkRouteCon res =
+    mkRouteCon (ResourceLeaf res) =
-        NormalC (mkName $ resourceName res)
+        ([con], [])
+      where
+        con = NormalC (mkName $ resourceName res)
             $ map (\x -> (NotStrict, x))
             $ concat [singles, multi, sub]
-      where
         singles = concatMap (toSingle . snd) $ resourcePieces res
         toSingle Static{} = []
         toSingle (Dynamic typ) = [typ]
@@ -35,16 +37,53 @@ mkRouteCons =
             case resourceDispatch res of
                 Subsite { subsiteType = typ } -> [ConT ''Route `AppT` typ]
                 _ -> []
+    mkRouteCon (ResourceParent name pieces children) =
+        ([con], dec : decs)
+      where
+        (cons, decs) = mkRouteCons children
+        con = NormalC (mkName name)
+            $ map (\x -> (NotStrict, x))
+            $ concat [singles, [ConT $ mkName name]]
+        dec = DataD [] (mkName name) [] cons [''Show, ''Read, ''Eq]
+
+        singles = concatMap (toSingle . snd) pieces
+        toSingle Static{} = []
+        toSingle (Dynamic typ) = [typ]
 
 -- | Clauses for the 'renderRoute' method.
-mkRenderRouteClauses :: [Resource Type] -> Q [Clause]
+mkRenderRouteClauses :: [ResourceTree Type] -> Q [Clause]
 mkRenderRouteClauses =
     mapM go
   where
     isDynamic Dynamic{} = True
     isDynamic _ = False
 
-    go res = do
+    go (ResourceParent name pieces children) = do
+        let cnt = length $ filter (isDynamic . snd) pieces
+        dyns <- replicateM cnt $ newName "dyn"
+        child <- newName "child"
+        let pat = ConP (mkName name) $ map VarP $ dyns ++ [child]
+
+        pack' <- [|pack|]
+        tsp <- [|toPathPiece|]
+        let piecesSingle = mkPieces (AppE pack' . LitE . StringL) tsp (map snd pieces) dyns
+
+        childRender <- newName "childRender"
+        let rr = VarE childRender
+        childClauses <- mkRenderRouteClauses children
+
+        a <- newName "a"
+        b <- newName "b"
+
+        colon <- [|(:)|]
+        let cons y ys = InfixE (Just y) colon (Just ys)
+        let pieces' = foldr cons (VarE a) piecesSingle
+
+        let body = LamE [TupP [VarP a, VarP b]] (TupE [pieces', VarE b]) `AppE` (rr `AppE` VarE child)
+
+        return $ Clause [pat] (NormalB body) [FunD childRender childClauses]
+
+    go (ResourceLeaf res) = do
         let cnt = length (filter (isDynamic . snd) $ resourcePieces res) + maybe 0 (const 1) (resourceMulti res)
         dyns <- replicateM cnt $ newName "dyn"
         sub <-
@@ -93,18 +132,19 @@ mkRenderRouteClauses =
 -- This includes both the 'Route' associated type and the
 -- 'renderRoute' method.  This function uses both 'mkRouteCons' and
 -- 'mkRenderRouteClasses'.
-mkRenderRouteInstance :: Type -> [Resource Type] -> Q Dec
+mkRenderRouteInstance :: Type -> [ResourceTree Type] -> Q [Dec]
 mkRenderRouteInstance = mkRenderRouteInstance' []
 
 -- | A more general version of 'mkRenderRouteInstance' which takes an
 -- additional context.
 
-mkRenderRouteInstance' :: Cxt -> Type -> [Resource Type] -> Q Dec
+mkRenderRouteInstance' :: Cxt -> Type -> [ResourceTree Type] -> Q [Dec]
 mkRenderRouteInstance' cxt typ ress = do
     cls <- mkRenderRouteClauses ress
+    let (cons, decs) = mkRouteCons ress
     return $ InstanceD cxt (ConT ''RenderRoute `AppT` typ)
-        [ DataInstD [] ''Route [typ] (mkRouteCons ress) clazzes
+        [ DataInstD [] ''Route [typ] cons clazzes
         , FunD (mkName "renderRoute") cls
-        ]
+        ] : decs
   where
     clazzes = [''Show, ''Eq, ''Read]

yesod-routes/Yesod/Routes/TH/Types.hs

@@ -2,16 +2,37 @@
 module Yesod.Routes.TH.Types
     ( -- * Data types
       Resource (..)
+    , ResourceTree (..)
     , Piece (..)
     , Dispatch (..)
     , CheckOverlap
       -- ** Helper functions
     , resourceMulti
+    , resourceTreePieces
+    , resourceTreeName
     ) where
 
 import Language.Haskell.TH.Syntax
 import Control.Arrow (second)
 
+data ResourceTree typ = ResourceLeaf (Resource typ) | ResourceParent String [(CheckOverlap, Piece typ)] [ResourceTree typ]
+
+resourceTreePieces :: ResourceTree typ -> [(CheckOverlap, Piece typ)]
+resourceTreePieces (ResourceLeaf r) = resourcePieces r
+resourceTreePieces (ResourceParent _ x _) = x
+
+resourceTreeName :: ResourceTree typ -> String
+resourceTreeName (ResourceLeaf r) = resourceName r
+resourceTreeName (ResourceParent x _ _) = x
+
+instance Functor ResourceTree where
+    fmap f (ResourceLeaf r) = ResourceLeaf (fmap f r)
+    fmap f (ResourceParent a b c) = ResourceParent a (map (second $ fmap f) b) $ map (fmap f) c
+
+instance Lift t => Lift (ResourceTree t) where
+    lift (ResourceLeaf r) = [|ResourceLeaf $(lift r)|]
+    lift (ResourceParent a b c) = [|ResourceParent $(lift a) $(lift b) $(lift c)|]
+
 data Resource typ = Resource
     { resourceName :: String
     , resourcePieces :: [(CheckOverlap, Piece typ)]

yesod-routes/test/Hierarchy.hs

@@ -0,0 +1,103 @@
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Hierarchy
+    ( hierarchy
+    , Dispatcher (..)
+    , RunHandler (..)
+    , Handler
+    , App
+    , toText
+    ) where
+
+import Test.Hspec.Monadic
+import Test.Hspec.HUnit ()
+import Test.HUnit
+import Yesod.Routes.Parse
+import Yesod.Routes.TH
+import Yesod.Routes.Class
+import Language.Haskell.TH.Syntax
+import qualified Yesod.Routes.Class as YRC
+import Data.Text (Text, pack, append)
+
+class ToText a where
+    toText :: a -> Text
+
+instance ToText Text where toText = id
+instance ToText String where toText = pack
+
+type Handler sub master = Text
+type App sub master = (Text, Maybe (YRC.Route master))
+
+class Dispatcher sub master where
+    dispatcher
+        :: master
+        -> sub
+        -> (YRC.Route sub -> YRC.Route master)
+        -> App sub master -- ^ 404 page
+        -> (YRC.Route sub -> App sub master) -- ^ 405 page
+        -> Text -- ^ method
+        -> [Text]
+        -> App sub master
+
+class RunHandler sub master where
+    runHandler
+        :: Handler sub master
+        -> master
+        -> sub
+        -> Maybe (YRC.Route sub)
+        -> (YRC.Route sub -> YRC.Route master)
+        -> App sub master
+
+data Hierarchy = Hierarchy
+
+do
+    let resources = [parseRoutes|
+/ HomeR GET
+/admin/#Int AdminR:
+    / AdminRootR GET
+    /login LoginR GET POST
+    /table/#Text TableR GET
+|]
+    rrinst <- mkRenderRouteInstance (ConT ''Hierarchy) $ map (fmap parseType) resources
+    dispatch <- mkDispatchClause [|runHandler|] [|dispatcher|] [|toText|] resources
+    return
+        $ InstanceD
+            []
+            (ConT ''Dispatcher
+                `AppT` ConT ''Hierarchy
+                `AppT` ConT ''Hierarchy)
+            [FunD (mkName "dispatcher") [dispatch]]
+        : rrinst
+
+getHomeR :: Handler sub master
+getHomeR = "home"
+
+getAdminRootR :: Int -> Handler sub master
+getAdminRootR i = pack $ "admin root: " ++ show i
+
+getLoginR :: Int -> Handler sub master
+getLoginR i = pack $ "login: " ++ show i
+
+postLoginR :: Int -> Handler sub master
+postLoginR i = pack $ "post login: " ++ show i
+
+getTableR :: Int -> Text -> Handler sub master
+getTableR _ t = append "TableR " t
+
+instance RunHandler Hierarchy master where
+    runHandler h _ _ subRoute toMaster = (h, fmap toMaster subRoute)
+
+hierarchy :: Specs
+hierarchy = describe "hierarchy" $ do
+    it "renders root correctly" $
+        renderRoute (AdminR 5 AdminRootR) @?= (["admin", "5"], [])
+    it "renders table correctly" $
+        renderRoute (AdminR 6 $ TableR "foo") @?= (["admin", "6", "table", "foo"], [])
+    let disp m ps = dispatcher Hierarchy Hierarchy id (pack "404", Nothing) (\route -> (pack "405", Just route)) (pack m) (map pack ps)
+    it "dispatches root correctly" $ disp "GET" ["admin", "7"] @?= ("admin root: 7", Just $ AdminR 7 AdminRootR)
+    it "dispatches table correctly" $ disp "GET" ["admin", "8", "table", "bar"] @?= ("TableR bar", Just $ AdminR 8 $ TableR "bar")

yesod-routes/test/main.hs

@@ -20,12 +20,7 @@ import Yesod.Routes.Parse (parseRoutesNoCheck)
 import Yesod.Routes.Overlap (findOverlapNames)
 import Yesod.Routes.TH hiding (Dispatch)
 import Language.Haskell.TH.Syntax
-
+import Hierarchy
-class ToText a where
-    toText :: a -> Text
-
-instance ToText Text where toText = id
-instance ToText String where toText = pack
 
 result :: ([Text] -> Maybe Int) -> Dispatch Int
 result f ts = f ts
@@ -101,32 +96,9 @@ instance RenderRoute MySubParam where
 getMySubParam :: MyApp -> Int -> MySubParam
 getMySubParam _ = MySubParam
 
-type Handler sub master = Text
-type App sub master = (Text, Maybe (YRC.Route master))
-
-class Dispatcher sub master where
-    dispatcher
-        :: master
-        -> sub
-        -> (YRC.Route sub -> YRC.Route master)
-        -> App sub master -- ^ 404 page
-        -> (YRC.Route sub -> App sub master) -- ^ 405 page
-        -> Text -- ^ method
-        -> [Text]
-        -> App sub master
-
-class RunHandler sub master where
-    runHandler
-        :: Handler sub master
-        -> master
-        -> sub
-        -> Maybe (YRC.Route sub)
-        -> (YRC.Route sub -> YRC.Route master)
-        -> App sub master
-
 do
     texts <- [t|[Text]|]
-    let ress =
+    let ress = map ResourceLeaf
             [ Resource "RootR" [] $ Methods Nothing ["GET"]
             , Resource "BlogPostR" (addCheck [Static "blog", Dynamic $ ConT ''Text]) $ Methods Nothing ["GET", "POST"]
             , Resource "WikiR" (addCheck [Static "wiki"]) $ Methods (Just texts) []
@@ -137,14 +109,13 @@ do
     rrinst <- mkRenderRouteInstance (ConT ''MyApp) ress
     dispatch <- mkDispatchClause [|runHandler|] [|dispatcher|] [|toText|] ress
     return
-        [ rrinst
+        $ InstanceD
-        , InstanceD
             []
             (ConT ''Dispatcher
                 `AppT` ConT ''MyApp
                 `AppT` ConT ''MyApp)
             [FunD (mkName "dispatcher") [dispatch]]
-        ]
+        : rrinst
 
 instance RunHandler MyApp master where
     runHandler h _ _ subRoute toMaster = (h, fmap toMaster subRoute)
@@ -328,6 +299,7 @@ main = hspecX $ do
 /bar/baz Foo3
 |]
             findOverlapNames routes @?= []
+    hierarchy
 
 getRootR :: Text
 getRootR = pack "this is the root"

yesod-routes/yesod-routes.cabal

@@ -1,5 +1,5 @@
 name:            yesod-routes
-version:         1.0.0
+version:         1.1.0.2
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>
@@ -11,12 +11,14 @@ stability:       Stable
 cabal-version:   >= 1.8
 build-type:      Simple
 homepage:        http://www.yesodweb.com/
+extra-source-files:
+  test/main.hs
 
 library
     build-depends:   base                      >= 4        && < 5
                    , text                      >= 0.5      && < 0.12
-                   , vector                    >= 0.8      && < 0.10
+                   , vector                    >= 0.8      && < 0.11
-                   , containers                >= 0.2      && < 0.5
+                   , containers                >= 0.2
                    , template-haskell
                    , path-pieces               >= 0.1      && < 0.2
 
@@ -34,12 +36,13 @@ test-suite runtests
     type: exitcode-stdio-1.0
     main-is: main.hs
     hs-source-dirs: test
+    other-modules: Hierarchy
 
     build-depends: base                      >= 4.3      && < 5
                  , yesod-routes
                  , text                      >= 0.5      && < 0.12
                  , HUnit                     >= 1.2      && < 1.3
-                 , hspec                     >= 0.6      && < 0.10
+                 , hspec                     >= 1.3      && < 1.4
                  , containers
                  , template-haskell
                  , path-pieces

yesod-sitemap/LICENSE

@@ -1,25 +1,20 @@
-The following license covers this documentation, and the source code, except
+Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/
-where otherwise indicated.
 
-Copyright 2010, Michael Snoyman. All rights reserved.
+Permission is hereby granted, free of charge, to any person obtaining
+a copy of this software and associated documentation files (the
+"Software"), to deal in the Software without restriction, including
+without limitation the rights to use, copy, modify, merge, publish,
+distribute, sublicense, and/or sell copies of the Software, and to
+permit persons to whom the Software is furnished to do so, subject to
+the following conditions:
 
-Redistribution and use in source and binary forms, with or without
+The above copyright notice and this permission notice shall be
-modification, are permitted provided that the following conditions are met:
+included in all copies or substantial portions of the Software.
 
-* Redistributions of source code must retain the above copyright notice, this
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
-  list of conditions and the following disclaimer.
+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
-
+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
-* Redistributions in binary form must reproduce the above copyright notice,
+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
-  this list of conditions and the following disclaimer in the documentation
+LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
-  and/or other materials provided with the distribution.
+OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
-
+WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
-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-sitemap/Yesod/Sitemap.hs

@@ -30,6 +30,7 @@ import Data.Time (UTCTime)
 import Data.Monoid (mappend)
 import Text.XML
 import Data.Text (Text, pack)
+import qualified Data.Map as Map
 
 data SitemapChangeFreq = Always
                        | Hourly
@@ -66,13 +67,13 @@ template urls render =
     addNS' n = n
     namespace = "http://www.sitemaps.org/schemas/sitemap/0.9"
 
-    root = Element "urlset" [] $ map go urls
+    root = Element "urlset" Map.empty $ map go urls
 
-    go SitemapUrl {..} = NodeElement $ Element "url" [] $ map NodeElement
+    go SitemapUrl {..} = NodeElement $ Element "url" Map.empty $ map NodeElement
-        [ Element "loc" [] [NodeContent $ render sitemapLoc]
+        [ Element "loc" Map.empty [NodeContent $ render sitemapLoc]
-        , Element "lastmod" [] [NodeContent $ formatW3 sitemapLastMod]
+        , Element "lastmod" Map.empty [NodeContent $ formatW3 sitemapLastMod]
-        , Element "changefreq" [] [NodeContent $ showFreq sitemapChangeFreq]
+        , Element "changefreq" Map.empty [NodeContent $ showFreq sitemapChangeFreq]
-        , Element "priority" [] [NodeContent $ pack $ show sitemapPriority]
+        , Element "priority" Map.empty [NodeContent $ pack $ show sitemapPriority]
         ]
 
 sitemap :: [SitemapUrl (Route master)] -> GHandler sub master RepXml

yesod-sitemap/yesod-sitemap.cabal

@@ -1,5 +1,5 @@
 name:            yesod-sitemap
-version:         1.0.0
+version:         1.1.0
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>
@@ -14,10 +14,11 @@ description:     Generate XML sitemaps.
 
 library
     build-depends:   base                      >= 4        && < 5
-                   , yesod-core                >= 1.0      && < 1.1
+                   , yesod-core                >= 1.1      && < 1.2
                    , time                      >= 1.1.4
-                   , xml-conduit               >= 0.7      && < 0.8
+                   , xml-conduit               >= 1.0      && < 1.1
                    , text
+                   , containers
     exposed-modules: Yesod.Sitemap
     ghc-options:     -Wall
 

yesod-static/LICENSE

@@ -1,25 +1,20 @@
-The following license covers this documentation, and the source code, except
+Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/
-where otherwise indicated.
 
-Copyright 2010, Michael Snoyman. All rights reserved.
+Permission is hereby granted, free of charge, to any person obtaining
+a copy of this software and associated documentation files (the
+"Software"), to deal in the Software without restriction, including
+without limitation the rights to use, copy, modify, merge, publish,
+distribute, sublicense, and/or sell copies of the Software, and to
+permit persons to whom the Software is furnished to do so, subject to
+the following conditions:
 
-Redistribution and use in source and binary forms, with or without
+The above copyright notice and this permission notice shall be
-modification, are permitted provided that the following conditions are met:
+included in all copies or substantial portions of the Software.
 
-* Redistributions of source code must retain the above copyright notice, this
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
-  list of conditions and the following disclaimer.
+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
-
+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
-* Redistributions in binary form must reproduce the above copyright notice,
+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
-  this list of conditions and the following disclaimer in the documentation
+LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
-  and/or other materials provided with the distribution.
+OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
-
+WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
-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/Yesod/Static.hs

@@ -66,7 +66,6 @@ import qualified Data.ByteString.Char8 as S8
 import qualified Data.ByteString.Lazy as L
 import qualified Data.Serialize
 import Data.Text (Text, pack)
-import Data.Monoid (mempty)
 import qualified Data.Map as M
 import Data.IORef (readIORef, newIORef, writeIORef)
 import Network.Wai (pathInfo, rawPathInfo, responseLBS)
@@ -79,19 +78,15 @@ import System.Posix.Types (EpochTime)
 import Data.Conduit (($$))
 import Data.Conduit.List (sourceList)
 import Data.Functor.Identity (runIdentity)
+import qualified Filesystem.Path.CurrentOS as F
 
 import Network.Wai.Application.Static
     ( StaticSettings (..)
-    , defaultWebAppSettings
     , staticApp
-    , embeddedLookup
-    , toEmbedded
-    , toFilePath
-    , fromFilePath
-    , FilePath
-    , ETagLookup
     , webAppSettingsWithLookup
+    , embeddedSettings
     )
+import WaiAppStatic.Storage.Filesystem (ETagLookup)
 
 -- | Type used for the subsite with static contents.
 newtype Static = Static StaticSettings
@@ -107,7 +102,7 @@ type StaticRoute = Route Static
 static :: Prelude.FilePath -> IO Static
 static dir = do
     hashLookup <- cachedETagLookup dir
-    return $ Static $ webAppSettingsWithLookup (toFilePath dir) hashLookup
+    return $ Static $ webAppSettingsWithLookup (F.decodeString dir) hashLookup
 
 -- | Same as 'static', but does not assumes that the files do not
 -- change and checks their modification time whenever a request
@@ -115,15 +110,19 @@ static dir = do
 staticDevel :: Prelude.FilePath -> IO Static
 staticDevel dir = do
     hashLookup <- cachedETagLookupDevel dir
-    return $ Static $ webAppSettingsWithLookup (toFilePath dir) hashLookup
+    return $ Static $ webAppSettingsWithLookup (F.decodeString dir) hashLookup
 
 -- | Produce a 'Static' based on embedding all of the static
 -- files' contents in the executable at compile time.
+-- Nota Bene: if you replace the scaffolded 'static' call in Settings/StaticFiles.hs
+-- you will need to change the scaffolded addStaticContent.  Otherwise, some of your
+-- assets will be 404'ed.  This is because by default yesod will generate compile those
+-- assets to @static/tmp@ which for 'static' is fine since they are served out of the 
+-- directory itself.  With embedded static, that will not work.  
+-- You can easily change @addStaticContent@ to @\_ _ _ -> return Nothing@ as a workaround.
+-- This will cause yesod to embed those assets into the generated HTML file itself.  
 embed :: Prelude.FilePath -> Q Exp
-embed fp =
+embed fp = [|Static (embeddedSettings $(embedDir fp))|]
-    [|Static (defaultWebAppSettings
-        { ssFolder = embeddedLookup (toEmbedded $(embedDir fp))
-        })|]
 
 instance RenderRoute Static where
     -- | A route on the static subsite (see also 'staticFiles').
@@ -146,10 +145,10 @@ instance RenderRoute Static where
 
 instance Yesod master => YesodDispatch Static master where
     -- Need to append trailing slash to make relative links work
-    yesodDispatch _ _ _ _ _ _ [] _ req =
+    yesodDispatch _ _ _ _ _ _ _ [] _ req =
         return $ responseLBS status301 [("Location", rawPathInfo req `S.append` "/")] ""
 
-    yesodDispatch _ (Static set) _ _ _ _ textPieces  _ req =
+    yesodDispatch _ _ (Static set) _ _ _ _ textPieces  _ req =
         staticApp set req { pathInfo = textPieces }
 
 notHidden :: Prelude.FilePath -> Bool
@@ -227,18 +226,18 @@ publicFiles :: Prelude.FilePath -> Q [Dec]
 publicFiles dir = mkStaticFiles' dir "StaticRoute" False
 
 
-mkHashMap :: Prelude.FilePath -> IO (M.Map FilePath S8.ByteString)
+mkHashMap :: Prelude.FilePath -> IO (M.Map F.FilePath S8.ByteString)
 mkHashMap dir = do
     fs <- getFileListPieces dir
     hashAlist fs >>= return . M.fromList
   where
-    hashAlist :: [[String]] -> IO [(FilePath, S8.ByteString)]
+    hashAlist :: [[String]] -> IO [(F.FilePath, S8.ByteString)]
     hashAlist fs = mapM hashPair fs
       where
-        hashPair :: [String] -> IO (FilePath, S8.ByteString)
+        hashPair :: [String] -> IO (F.FilePath, S8.ByteString)
         hashPair pieces = do let file = pathFromRawPieces dir pieces
                              h <- base64md5File file
-                             return (toFilePath file, S8.pack h)
+                             return (F.decodeString file, S8.pack h)
 
 pathFromRawPieces :: Prelude.FilePath -> [String] -> Prelude.FilePath
 pathFromRawPieces =
@@ -249,12 +248,12 @@ pathFromRawPieces =
 cachedETagLookupDevel :: Prelude.FilePath -> IO ETagLookup
 cachedETagLookupDevel dir = do
     etags <- mkHashMap dir
-    mtimeVar <- newIORef (M.empty :: M.Map FilePath EpochTime)
+    mtimeVar <- newIORef (M.empty :: M.Map F.FilePath EpochTime)
     return $ \f ->
       case M.lookup f etags of
         Nothing -> return Nothing
         Just checksum -> do
-          fs <- getFileStatus $ fromFilePath f
+          fs <- getFileStatus $ F.encodeString f
           let newt = modificationTime fs
           mtimes <- readIORef mtimeVar
           oldt <- case M.lookup f mtimes of
@@ -307,7 +306,7 @@ mkStaticFilesList fp fs routeConName makeHash = do
         pack' <- [|pack|]
         qs <- if makeHash
                     then do hash <- qRunIO $ base64md5File $ pathFromRawPieces fp f
-                            [|[(pack $(lift hash), mempty)]|]
+                            [|[("etag" :: Text, pack $(lift hash))]|]
                     else return $ ListE []
         return
             [ SigD routeName $ ConT route

yesod-static/test/YesodStaticTest.hs

@@ -6,11 +6,9 @@ import Test.Hspec.HUnit ( )
 
 import Yesod.Static (getFileListPieces)
 
-specs :: [Specs]
+specs :: Spec
-specs = [
+specs = do
-    describe "get file list" [
+    describe "get file list" $ do
       it "pieces" $ do
         x <- getFileListPieces "test/fs"
         x @?= [["foo"], ["bar", "baz"]]
-    ]
-  ]

yesod-static/test/tests.hs

@@ -4,4 +4,4 @@ import Test.Hspec
 import YesodStaticTest (specs)
 
 main :: IO ()
-main = hspecX $ descriptions specs
+main = hspec specs