haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

merge master, switch to optparse-applicative

Browse Source
This commit is contained in:
Luite Stegeman 2012-10-15 16:30:35 +02:00
commit 75b8dc4457
147 changed files with 3333 additions and 1943 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitignore vendored
View File

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

7
.travis.yml Normal file
View File

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

39
LICENSE
View File

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

121
README.md
View File

@ -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.
Instead of using the `cabal` command, use the `cabal-dev` command which will use the sandbox.
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.
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.
## Installing the latest development version from github for use with your application
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
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:
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:
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
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
for repo in shakespeare 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
~~~
#### installing repo packages
### Clean build (sometimes necessary)
~~~ { .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.

2
scripts

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

1
sources.txt
View File

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

39
yesod-auth-oauth/LICENSE
View File

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

15
yesod-auth-oauth/yesod-auth-oauth.cabal
View File

@ -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: Authentication for Yesod.
description: Oauth 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-auth >= 1.0 && < 1.1
, yesod-core >= 1.1 && < 1.2
, yesod-auth >= 1.1 && < 1.2
, text >= 0.7 && < 0.12
, yesod-form >= 1.0 && < 1.1
, transformers >= 0.2.2 && < 0.3
, yesod-form >= 1.1 && < 1.2
, transformers >= 0.2.2 && < 0.4
exposed-modules: Yesod.Auth.OAuth
ghc-options: -Wall

39
yesod-auth/LICENSE
View File

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

6
yesod-auth/Yesod/Auth.hs
View File

@ -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.

1
yesod-auth/Yesod/Auth/BrowserId.hs
View File

@ -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">

1
yesod-auth/Yesod/Auth/Dummy.hs
View File

@ -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">

13
yesod-auth/Yesod/Auth/Email.hs
View File

@ -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>

26
yesod-auth/Yesod/Auth/GoogleEmail.hs
View File

@ -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

7
yesod-auth/Yesod/Auth/HashDB.hs
View File

@ -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

144
yesod-auth/Yesod/Auth/Message.hs
View File

@ -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"

89
yesod-auth/Yesod/Auth/OpenId.hs
View File

@ -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
authOpenId = authOpenIdExtended []
data IdentifierType = Claimed | OPLocal
authOpenIdExtended :: YesodAuth m => [(Text, Text)] -> AuthPlugin m
authOpenIdExtended extensionFields =
authOpenId :: YesodAuth m
=> 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 gets' = do
completeHelper :: YesodAuth m => IdentifierType -> [(Text, Text)] -> GHandler Auth m ()
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, _) =
setCreds True $ Creds "openid" ident gets'
let onSuccess oir = do
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)

1
yesod-auth/Yesod/Auth/Rpxnow.hs
View File

@ -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

4
yesod-auth/openid.hs
View File

@ -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

31
yesod-auth/yesod-auth.cabal
View File

@ -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
, bytestring >= 0.9.1.4 && < 0.10
, yesod-core >= 1.0 && < 1.1
, wai >= 1.2 && < 1.3
, authenticate >= 1.3 && < 1.4
, bytestring >= 0.9.1.4
, yesod-core >= 1.1 && < 1.2
, 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.0 && < 1.1
, hamlet >= 1.0 && < 1.1
, yesod-persistent >= 1.1 && < 1.2
, hamlet >= 1.1 && < 1.2
, 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-template >= 0.9 && < 0.10
, persistent >= 1.0 && < 1.1
, 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

39
yesod-core/LICENSE
View File

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

24
yesod-core/Yesod/Content.hs
View File

@ -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.
| ContentSource (Source (ResourceT IO) (Flush Builder))
| ContentFile FilePath (Maybe FilePart)
data Content = ContentBuilder !Builder !(Maybe Int) -- ^ The content and optional content length.
| ContentSource !(Source (ResourceT IO) (Flush Builder))
| 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

42
yesod-core/Yesod/Core.hs
View File

@ -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 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
import Control.Monad.Logger
-- | Return an 'Unauthorized' value, with the given i18n message.
unauthorizedI :: RenderMessage master msg => msg -> GHandler sub master AuthResult

44
yesod-core/Yesod/Dispatch.hs
View File

@ -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
handler405 route = yesodRunner badMethod y y (Just route) id
app404 = yesodRunner logger notFound y y Nothing 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

190
yesod-core/Yesod/Handler.hs
View File

@ -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 req =
(map fix1 *** map fix2) <$> (NWP.parseRequestBody NWP.lbsBackEnd req)
rbHelper :: FileUpload -> W.Request -> ResourceT IO RequestBodyContents
rbHelper upload =
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) =
(go x, FileInfo (go a) (go b) c)
fix2 (x, NWP.FileInfo a' 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
eh' er = runHandler (errorHandler' er) 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 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
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
go c
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)

36
yesod-core/Yesod/Internal.hs
View File

@ -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
| Header Ascii Ascii
| DeleteCookie ByteString ByteString
| 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 (Remote s) = [hamlet|\#{s}
|]
locationToHtmlUrl (Local url) render = toHtml $ render url []
locationToHtmlUrl (Remote s) _ = toHtml 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)
!(Last Title)
!(UniqueList (Script a))
!(UniqueList (Stylesheet a))
!(Map.Map (Maybe Text) (CssBuilderUrl a)) -- media type
!(Maybe (JavascriptUrl a))
!(Head a)
{ gwdBody :: !(Body a)
, gwdTitle :: !(Last Title)
, gwdScripts :: !(UniqueList (Script a))
, gwdStylesheets :: !(UniqueList (Stylesheet a))
, gwdCss :: !(Map.Map (Maybe Text) (CssBuilderUrl a)) -- media type
, gwdJavascript :: !(Maybe (JavascriptUrl 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)

275
yesod-core/Yesod/Internal/Core.hs
View File

@ -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 qualified Data.Text.Lazy.IO
import qualified Data.Text.Lazy.Builder as TB
import Language.Haskell.TH.Syntax (Loc (..), Lift (..))
import Text.Blaze (preEscapedLazyText)
import Language.Haskell.TH.Syntax (Loc (..))
import Text.Blaze (preEscapedToMarkup)
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 =
if level < logLevel a
then return ()
else
formatLogMessage loc level msg >>=
Data.Text.Lazy.IO.putStrLn
messageLogger a logger loc = messageLoggerSource a logger loc ""
-- | Send a message to the @Logger@ provided by @getLogger@.
messageLoggerSource :: a
-> Logger
-> 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
=> Loc -> LogLevel -> Text -> GHandler s m ()
messageLoggerHandler loc level msg = do
y <- getYesod
liftIO $ messageLogger y loc level msg
-- | Should we log the given log source/level combination.
--
-- Default: Logs everything at or above 'logLevel'
shouldLog :: a -> LogSource -> LogLevel -> Bool
shouldLog a _ level = level >= logLevel a
data LogLevel = LevelDebug | LevelInfo | LevelWarn | LevelError | LevelOther Text
deriving (Eq, Show, Read, Ord)
{-# DEPRECATED messageLogger "Please use messageLoggerSource (since yesod-core 1.1.2)" #-}
instance Lift LogLevel where
lift LevelDebug = [|LevelDebug|]
lift LevelInfo = [|LevelInfo|]
lift LevelWarn = [|LevelWarn|]
lift LevelError = [|LevelError|]
lift (LevelOther x) = [|LevelOther $ T.pack $(lift $ T.unpack x)|]
formatLogMessage :: Loc
formatLogMessage :: IO ZonedDate
-> Loc
-> LogSource
-> LogLevel
-> Text -- ^ message
-> IO TL.Text
formatLogMessage loc level msg = do
now <- getCurrentTime
return $ TB.toLazyText $
TB.fromText (T.pack $ show now)
`mappend` TB.fromText " ["
`mappend` TB.fromText (T.pack $ drop 5 $ show level)
`mappend` TB.fromText "] "
`mappend` TB.fromText msg
`mappend` TB.fromText " @("
`mappend` TB.fromText (T.pack $ fileLocationToString loc)
`mappend` TB.fromText ") "
-> LogStr -- ^ message
-> IO [LogStr]
formatLogMessage getdate loc src level msg = do
now <- getdate
return
[ LB now
, LB " ["
, LS $
case level of
LevelOther t -> T.unpack t
_ -> drop 5 $ show level
, LS $
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
| maximumContentLength master (fmap toMaster murl) < len =
defaultYesodRunner logger handler master sub murl toMasterRoute msb req
| 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
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
| otherwise = 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." #-}

43
yesod-core/Yesod/Internal/Request.hs
View File

@ -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 <$> newStdGen
parseWaiRequest env session' useToken bodySize =
parseWaiRequest' env session' useToken bodySize <$> newStdGen
parseWaiRequest' :: RandomGen g
=> W.Request
-> [(Text, ByteString)] -- ^ session
-> Bool
-> Word64
-> g
-> Request
parseWaiRequest' env session' useToken gen =
Request gets'' cookies' env langs'' token
parseWaiRequest' env session' useToken bodySize gen =
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))

6
yesod-core/Yesod/Internal/Session.hs
View File

@ -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
UTCTime -> -- ^ current time
IO [Header]
type SaveSession = BackendSession -- ^ The session contents after running the handler
-> UTCTime -- ^ current time
-> IO [Header]
newtype SessionBackend master = SessionBackend
{ sbLoadSession :: master

138
yesod-core/Yesod/Logger.hs
View File

@ -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

9
yesod-core/Yesod/Request.hs
View File

@ -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

41
yesod-core/Yesod/Widget.hs
View File

@ -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 Text.Blaze (toHtml, preEscapedLazyText)
import Data.Text.Lazy.Builder (fromLazyText, Builder)
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

9
yesod-core/helloworld.hs
View File

@ -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")});|]

2
yesod-core/test.hs
View File

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

29
yesod-core/test/YesodCoreTest.hs
View File

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

7
yesod-core/test/YesodCoreTest/Cache.hs
View File

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

34
yesod-core/test/YesodCoreTest/CleanPath.hs
View File

@ -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"
[ it "remove trailing slash" removeTrailingSlash
, it "noTrailingSlash" noTrailingSlash
, it "add trailing slash" addTrailingSlash
, it "has trailing slash" hasTrailingSlash
, it "/foo/something" fooSomething
, it "subsite dispatch" subsiteDispatch
, it "redirect with query string" redQueryString
]
describe "Test.CleanPath" $ do
it "remove trailing slash" removeTrailingSlash
it "noTrailingSlash" noTrailingSlash
it "add trailing slash" addTrailingSlash
it "has trailing slash" hasTrailingSlash
it "/foo/something" fooSomething
it "subsite dispatch" subsiteDispatch
it "redirect with query string" redQueryString
runner :: Session () -> IO ()
runner f = toWaiApp Y >>= runSession f

46
yesod-core/test/YesodCoreTest/ErrorHandling.hs
View File

@ -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]
errorHandlingTest = describe "Test.ErrorHandling"
[ it "says not found" caseNotFound
, it "says 'There was an error' before runRequestBody" caseBefore
, it "says 'There was an error' after runRequestBody" caseAfter
]
getErrorInBodyR :: Handler RepHtml
getErrorInBodyR = do
let foo = error "error in body 19328" :: String
defaultLayout [whamlet|#{foo}|]
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"

9
yesod-core/test/YesodCoreTest/Exceptions.hs
View File

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

65
yesod-core/test/YesodCoreTest/InternalRequest.hs
View File

@ -10,11 +10,10 @@ import Yesod.Internal.TestApi (randomString, parseWaiRequest')
import Yesod.Request (Request (..))
import Test.Hspec
randomStringSpecs :: [Spec]
randomStringSpecs = describe "Yesod.Internal.Request.randomString"
[ it "looks reasonably random" looksRandom
, it "does not repeat itself" $ noRepeat 10 100
]
randomStringSpecs :: Spec
randomStringSpecs = describe "Yesod.Internal.Request.randomString" $ do
it "looks reasonably random" looksRandom
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 = describe "Yesod.Internal.Request.parseWaiRequest (reqToken)"
[ it "is Nothing if sessions are disabled" noDisabledToken
, it "ignores pre-existing token if sessions are disabled" ignoreDisabledToken
, it "uses preexisting token in session" useOldToken
, it "generates a new token for sessions without token" generateToken
]
tokenSpecs :: Spec
tokenSpecs = describe "Yesod.Internal.Request.parseWaiRequest (reqToken)" $ do
it "is Nothing if sessions are disabled" noDisabledToken
it "ignores pre-existing token if sessions are disabled" ignoreDisabledToken
it "uses preexisting token in session" useOldToken
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 = describe "Yesod.Internal.Request.parseWaiRequest (reqLangs)"
[ it "respects Accept-Language" respectAcceptLangs
, it "respects sessions" respectSessionLang
, it "respects cookies" respectCookieLang
, it "respects queries" respectQueryLang
, it "prioritizes correctly" prioritizeLangs
]
langSpecs :: Spec
langSpecs = describe "Yesod.Internal.Request.parseWaiRequest (reqLangs)" $ do
it "respects Accept-Language" respectAcceptLangs
it "respects sessions" respectSessionLang
it "respects cookies" respectCookieLang
it "respects queries" respectQueryLang
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 = descriptions [ randomStringSpecs
, tokenSpecs
, langSpecs
]
internalRequestTest :: Spec
internalRequestTest = describe "Test.InternalRequestTest" $ do
randomStringSpecs
tokenSpecs
langSpecs

9
yesod-core/test/YesodCoreTest/JsLoader.hs
View File

@ -22,20 +22,19 @@ instance Yesod H where
getHeadR :: Handler RepHtml
getHeadR = defaultLayout $ addScriptRemote "load.js"
specs :: [Spec]
specs = describe "Test.JsLoader" [
specs :: Spec
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

44
yesod-core/test/YesodCoreTest/Links.hs
View File

@ -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]
linksTest = describe "Test.Links"
[ it "linkToHome" case_linkToHome
]
getTextR :: Text -> Handler RepHtml
getTextR foo = defaultLayout $ toWidget [hamlet|%#{foo}%|]
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

9
yesod-core/test/YesodCoreTest/Media.hs
View File

@ -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 = describe "Test.Media"
[ it "media" caseMedia
, it "media link" caseMediaLink
]
mediaTest :: Spec
mediaTest = describe "Test.Media" $ do
it "media" caseMedia
it "media link" caseMediaLink

7
yesod-core/test/YesodCoreTest/NoOverloadedStrings.hs
View File

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

13
yesod-core/test/YesodCoreTest/Redirect.hs
View File

@ -26,34 +26,33 @@ getR303 = redirectWith H.status303 RootR
getR307 = redirectWith H.status307 RootR
getRRegular = redirect RootR
specs :: [Spec]
specs = describe "Redirect" [
specs :: Spec
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
]

7
yesod-core/test/YesodCoreTest/WaiSubsite.hs
View File

@ -25,15 +25,14 @@ app = yesod Y
getRootR :: Handler ()
getRootR = return ()
specs :: [Spec]
specs = describe "WaiSubsite" [
specs :: Spec
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
]

34
yesod-core/test/YesodCoreTest/Widget.hs
View File

@ -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]
widgetTest = describe "Test.Widget"
[ it "addJuliusBody" case_addJuliusBody
, it "whamlet" case_whamlet
, it "two letter lang codes" case_two_letter_lang
, it "automatically applies toWidget" case_auto
]
getJSHeadR :: Handler RepHtml
getJSHeadR = defaultLayout $ toWidgetHead [julius|alert("hello");|]
widgetTest :: Spec
widgetTest = describe "Test.Widget" $ do
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

90
yesod-core/yesod-core.cabal
View File

@ -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/YesodCoreTest/NoOverloadedStrings.hs
test.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/Links.hs
test/YesodCoreTest/InternalRequest.hs
test/YesodCoreTest/ErrorHandling.hs
test/YesodCoreTest/Cache.hs
test.hs
test/YesodCoreTest/YesodTest.hs
test/en.msg
test/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
, yesod-routes >= 1.0 && < 1.1
, wai >= 1.2 && < 1.3
, wai-extra >= 1.2 && < 1.3
, bytestring >= 0.9.1.4 && < 0.10
build-depends: base >= 4.3 && < 5
, time >= 1.1.4
, yesod-routes >= 1.1 && < 1.2
, wai >= 1.3 && < 1.4
, wai-extra >= 1.3 && < 1.4
, bytestring >= 0.9.1.4
, text >= 0.7 && < 0.12
, template-haskell
, path-pieces >= 0.1 && < 0.2
, hamlet >= 1.0 && < 1.1
, path-pieces >= 0.1.2 && < 0.2
, 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.6.5 && < 0.7
, http-types >= 0.7 && < 0.8
, case-insensitive >= 0.2
, parsec >= 2 && < 3.2
, directory >= 1 && < 1.2
, vector >= 0.9 && < 0.10
, directory >= 1
, vector >= 0.9 && < 0.11
, aeson >= 0.5
, fast-logger >= 0.0.2
, wai-logger >= 0.0.1
, conduit >= 0.4 && < 0.5
, resourcet >= 0.3 && < 0.4
, lifted-base >= 0.1 && < 0.2
, fast-logger >= 0.2
, monad-logger >= 0.2.1 && < 0.3
, conduit >= 0.5 && < 0.6
, resourcet >= 0.3 && < 0.5
, 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

39
yesod-default/LICENSE
View File

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

10
yesod-default/Yesod/Default/Config.hs
View File

@ -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 }
else config
then config' { appPort = port args }
else config'
-- | Load your development config (when using @'DefaultEnv'@)
loadDevelopmentConfig :: IO (AppConfig DefaultEnv ())

24
yesod-default/Yesod/Default/Main.hs
View File

@ -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
-- @'fromArgsWith'@ when using a custom type
-- @'fromArgs'@ helps parse a custom configuration
--
-- > main :: IO ()
-- > main = defaultMain fromArgs withMySite
--
-- or
--
-- > main :: IO ()
-- > main = defaultMain (fromArgsWith customArgConfig) withMySite
-- > main = defaultMain (fromArgs parseExtra) makeApplication
--
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 logger
print $ appHost config
app <- getApp 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
app <- getApp conf logger
putStrLn $ "Devel application launched: http://localhost:" ++ show p
app <- getApp conf
return (p, app)

68
yesod-default/Yesod/Default/Util.hs
View File

@ -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
widgetFileNoReload x = combine "widgetFileNoReload" x
[ whenExists x False "hamlet" whamletFile
, whenExists x True "cassius" cassiusFile
, whenExists x True "julius" juliusFile
, whenExists x True "lucius" luciusFile
]
data TemplateLanguage = TemplateLanguage
{ tlRequiresToWidget :: Bool
, tlExtension :: String
, tlNoReload :: FilePath -> Q Exp
, tlReload :: FilePath -> Q Exp
}
widgetFileReload :: FilePath -> Q Exp
widgetFileReload x = combine "widgetFileReload" x
[ whenExists x False "hamlet" whamletFile
, whenExists x True "cassius" cassiusFileReload
, whenExists x True "julius" juliusFileReload
, whenExists x True "lucius" luciusFileReload
defaultTemplateLanguages :: HamletSettings -> [TemplateLanguage]
defaultTemplateLanguages hset =
[ TemplateLanguage False "hamlet" whamletFile' whamletFile'
, TemplateLanguage True "cassius" cassiusFile cassiusFileReload
, TemplateLanguage True "julius" juliusFile juliusFileReload
, TemplateLanguage True "lucius" luciusFile luciusFileReload
]
where
whamletFile' = whamletFileWithSettings hset
widgetFileJsCss :: (String, FilePath -> Q Exp) -- ^ Css file extenstion and loading function. example: ("cassius", cassiusFileReload)
-> (String, FilePath -> Q Exp) -- ^ Css file extenstion and loading function. example: ("julius", juliusFileReload)
-> FilePath -> Q Exp
widgetFileJsCss (jsExt, jsLoad) (csExt, csLoad) x = combine "widgetFileJsCss" x
[ whenExists x False "hamlet" whamletFile
, whenExists x True csExt csLoad
, whenExists x True jsExt jsLoad
]
data WidgetFileSettings = WidgetFileSettings
{ wfsLanguages :: HamletSettings -> [TemplateLanguage]
, wfsHamletSettings :: HamletSettings
}
combine :: String -> String -> [Q (Maybe Exp)] -> Q Exp
combine func file qmexps = do
mexps <- sequence qmexps
instance Default WidgetFileSettings where
def = WidgetFileSettings defaultTemplateLanguages defaultHamletSettings
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

16
yesod-default/yesod-default.cabal
View File

@ -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
, warp >= 1.2 && < 1.3
, wai >= 1.2 && < 1.3
, wai-extra >= 1.2 && < 1.3
, yesod-core >= 1.1 && < 1.2
, warp >= 1.3 && < 1.4
, wai >= 1.3 && < 1.4
, 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
, network-conduit >= 0.4 && < 0.5
, yaml >= 0.8 && < 0.9
, network-conduit >= 0.5 && < 0.7
, unordered-containers
, hamlet >= 1.1 && < 1.2
, data-default
if !os(windows)
build-depends: unix

20
yesod-eventsource/LICENSE Normal file
View File

@ -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.

7
yesod-eventsource/Setup.lhs Executable file
View File

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

101
yesod-eventsource/Yesod/EventSource.hs Normal file
View File

@ -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)

42
yesod-eventsource/yesod-eventsource.cabal Normal file
View File

@ -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

44
yesod-examples/LICENSE
View File

@ -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
modification, are permitted provided that the following conditions are met:
The above copyright notice and this permission notice shall be
included in all copies or substantial portions of the Software.
* Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above
copyright notice, this list of conditions and the following
disclaimer in the documentation and/or other materials provided
with the distribution.
* 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.
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.

39
yesod-form/LICENSE
View File

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

180
yesod-form/Yesod/Form/Fields.hs
View File

@ -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 (h2:':':m1:m2:[]) = parseTimeHelper ('0', h2, m1, m2, '0', '0')
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
parseTime :: Text -> Either FormMessage TimeOfDay
parseTime = either (Left . fromMaybe MsgInvalidTimeFormat . readMay . drop 2 . dropWhile (/= ':')) Right . parseOnly timeParser
parseTimeHelper :: (Char, Char, Char, Char, Char, Char)
-> Either FormMessage TimeOfDay
parseTimeHelper (h1, h2, m1, m2, s1, s2)
| h < 0 || h > 23 = Left $ MsgInvalidHour $ pack [h1, h2]
| m < 0 || m > 59 = Left $ MsgInvalidMinute $ pack [m1, m2]
| s < 0 || s > 59 = Left $ MsgInvalidSecond $ pack [s1, s2]
| otherwise = Right $ TimeOfDay h m s
timeParser :: Parser TimeOfDay
timeParser = do
skipSpace
h <- hour
_ <- char ':'
m <- minsec MsgInvalidMinute
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?
m = read [m1, m2]
s = fromInteger $ read [s1, s2]
hour = do
x <- digit
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 isSel -> [whamlet|<option value=none :isSel:selected>_{MsgSelectNone}|]) -- onOpt
(\_theId _name attrs value isSel text -> [whamlet|<option value=#{value} :isSel:selected *{attrs}>#{text}|]) -- inside
(\theId name inside -> [whamlet|
$newline never
<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>
<input id=#{theId}-none type=radio name=#{name} value=none :isSel:checked>
<label for=#{theId}-none>_{MsgSelectNone}
$newline never
<label .radio for=#{theId}-none>
<div>
<input id=#{theId}-none type=radio name=#{name} value=none :isSel:checked>
_{MsgSelectNone}
|])
(\theId name attrs value isSel text -> [whamlet|
<div>
<input id=#{theId}-#{value} type=radio name=#{name} value=#{value} :isSel:checked *{attrs}>
<label for=#{theId}-#{value}>#{text}
$newline never
<label .radio for=#{theId}-#{value}>
<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

94
yesod-form/Yesod/Form/Functions.hs
View File

@ -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)
where
notEmpty = not . L.null . fileContent
return $ Just (p', Map.fromList f)
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 msg = FieldSettings msg Nothing Nothing Nothing []
fieldSettingsLabel :: RenderMessage master msg => msg -> FieldSettings master
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

26
yesod-form/Yesod/Form/I18n/French.hs Normal file
View File

@ -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 ?"

26
yesod-form/Yesod/Form/I18n/Japanese.hs Normal file
View File

@ -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 = "削除しますか?"

26
yesod-form/Yesod/Form/I18n/Norwegian.hs Normal file
View File

@ -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."

29
yesod-form/Yesod/Form/Jquery.hs
View File

@ -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}");
if (i.attr("type") != "date") {
i.datepicker({
var i = document.getElementById("#{theId}");
if (i.type != "date") {
$(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

11
yesod-form/Yesod/Form/MassInput.hs
View File

@ -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>

10
yesod-form/Yesod/Form/Nic.hs
View File

@ -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

25
yesod-form/Yesod/Form/Types.hs
View File

@ -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
-> Text
-> [(Text, Text)]
-> Either Text a
-> Bool
, fieldView :: Text -- ^ ID
-> Text -- ^ Name
-> [(Text, Text)] -- ^ Attributes
-> Either Text a -- ^ Either (invalid text) or (legitimate result)
-> Bool -- ^ Required?
-> GWidget sub master ()
}
@ -143,3 +151,4 @@ data FormMessage = MsgInvalidInteger Text
| MsgBoolYes
| MsgBoolNo
| MsgDelete
deriving (Show, Eq, Read)

41
yesod-form/test/main.hs Normal file
View File

@ -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)
]

42
yesod-form/yesod-form.cabal
View File

@ -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-persistent >= 1.0 && < 1.1
, yesod-core >= 1.1 && < 1.2
, 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 && < 0.10
, bytestring >= 0.9.1.4
, text >= 0.9 && < 1.0
, wai >= 1.2 && < 1.3
, containers >= 0.2 && < 0.5
, wai >= 1.3 && < 1.4
, 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

39
yesod-json/LICENSE
View File

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

19
yesod-json/Yesod/Json.hs
View File

@ -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 (/= ';'))
. join
. fmap (headMay . parseHttpAccept)
. lookup "Accept" . requestHeaders
<$> waiRequest
-- | Returns @True@ if the client prefers @application\/json@ as
-- indicated by the @Accept@ HTTP header.
acceptsJson :: Yesod master => GHandler sub master Bool
acceptsJson = maybe False ((== "application/json") . B8.takeWhile (/= ';'))
. join
. fmap (headMay . parseHttpAccept)
. lookup "Accept" . requestHeaders
<$> waiRequest

16
yesod-json/yesod-json.cabal
View File

@ -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-routes >= 1.0 && < 1.1
, yesod-core >= 1.1 && < 1.2
, 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
, conduit >= 0.4 && < 0.5
, attoparsec-conduit >= 0.5 && < 0.6
, conduit >= 0.5 && < 0.6
, transformers >= 0.2.2 && < 0.4
, wai >= 1.2 && < 1.3
, wai-extra >= 1.2 && < 1.3
, bytestring >= 0.9 && < 0.10
, wai >= 1.3 && < 1.4
, wai-extra >= 1.3 && < 1.4
, bytestring >= 0.9
, safe >= 0.2 && < 0.4
exposed-modules: Yesod.Json
ghc-options: -Wall

39
yesod-newsfeed/LICENSE
View File

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

30
yesod-newsfeed/Yesod/AtomFeed.hs
View File

@ -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
$ Element "title" [] [NodeContent feedTitle]
: Element "link" [("rel", "self"), ("href", render feedLinkSelf)] []
: Element "link" [("href", render feedLinkHome)] []
: Element "updated" [] [NodeContent $ formatW3 feedUpdated]
: Element "id" [] [NodeContent $ render feedLinkHome]
root = Element "feed" Map.empty $ map NodeElement
$ Element "title" Map.empty [NodeContent feedTitle]
: Element "link" (Map.fromList [("rel", "self"), ("href", render feedLinkSelf)]) []
: Element "link" (Map.singleton "href" $ render feedLinkHome) []
: Element "updated" Map.empty [NodeContent $ formatW3 feedUpdated]
: 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
[ Element "id" [] [NodeContent $ render feedEntryLink]
, Element "link" [("href", render feedEntryLink)] []
, Element "updated" [] [NodeContent $ formatW3 feedEntryUpdated]
, Element "title" [] [NodeContent feedEntryTitle]
, Element "content" [("type", "html")] [NodeContent $ toStrict $ renderHtml feedEntryContent]
entryTemplate FeedEntry {..} render = Element "entry" Map.empty $ map NodeElement
[ Element "id" Map.empty [NodeContent $ render feedEntryLink]
, Element "link" (Map.singleton "href" $ render feedEntryLink) []
, Element "updated" Map.empty [NodeContent $ formatW3 feedEntryUpdated]
, Element "title" Map.empty [NodeContent feedEntryTitle]
, 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}>
|]

3
yesod-newsfeed/Yesod/FeedTypes.hs
View File

@ -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

33
yesod-newsfeed/Yesod/RssFeed.hs
View File

@ -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
$ Element "{http://www.w3.org/2005/Atom}link"
root = Element "rss" (Map.singleton "version" "2.0") $ return $ NodeElement $ Element "channel" Map.empty $ map NodeElement
$ 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 "link" [] [NodeContent $ render feedLinkHome]
: Element "description" [] [NodeContent $ toStrict $ renderHtml feedDescription]
: Element "lastBuildDate" [] [NodeContent $ formatRFC822 feedUpdated]
: Element "language" [] [NodeContent feedLanguage]
]) []
: Element "title" Map.empty [NodeContent feedTitle]
: Element "link" Map.empty [NodeContent $ render feedLinkHome]
: Element "description" Map.empty [NodeContent $ toStrict $ renderHtml feedDescription]
: Element "lastBuildDate" Map.empty [NodeContent $ formatRFC822 feedUpdated]
: Element "language" Map.empty [NodeContent feedLanguage]
: map (flip entryTemplate render) feedEntries
entryTemplate :: FeedEntry url -> (url -> Text) -> Element
entryTemplate FeedEntry {..} render = Element "item" [] $ map NodeElement
[ Element "title" [] [NodeContent feedEntryTitle]
, Element "link" [] [NodeContent $ render feedEntryLink]
, Element "guid" [] [NodeContent $ render feedEntryLink]
, Element "pubDate" [] [NodeContent $ formatRFC822 feedEntryUpdated]
, Element "description" [] [NodeContent $ toStrict $ renderHtml feedEntryContent]
entryTemplate FeedEntry {..} render = Element "item" Map.empty $ map NodeElement
[ Element "title" Map.empty [NodeContent feedEntryTitle]
, Element "link" Map.empty [NodeContent $ render feedEntryLink]
, Element "guid" Map.empty [NodeContent $ render feedEntryLink]
, Element "pubDate" Map.empty [NodeContent $ formatRFC822 feedEntryUpdated]
, 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}>
|]

15
yesod-newsfeed/yesod-newsfeed.cabal
View File

@ -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
, bytestring >= 0.9.1.4 && < 0.10
, hamlet >= 1.1 && < 1.2
, bytestring >= 0.9.1.4
, text >= 0.9 && < 0.12
, xml-conduit >= 0.7 && < 0.8
, blaze-html >= 0.4 && < 0.5
, xml-conduit >= 1.0 && < 1.1
, blaze-html >= 0.5 && < 0.6
, blaze-markup >= 0.5.1 && < 0.6
, containers
exposed-modules: Yesod.AtomFeed
, Yesod.RssFeed
, Yesod.Feed

39
yesod-persistent/LICENSE
View File

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

8
yesod-persistent/yesod-persistent.cabal
View File

@ -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
, persistent >= 0.9 && < 0.10
, persistent-template >= 0.9 && < 0.10
, yesod-core >= 1.1 && < 1.2
, persistent >= 1.0 && < 1.1
, persistent-template >= 1.0 && < 1.1
, transformers >= 0.2.2 && < 0.4
exposed-modules: Yesod.Persist
ghc-options: -Wall

39
yesod-platform/LICENSE
View File

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

2
yesod-platform/make-cabal.sh
View File

@ -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

4
yesod-platform/to-cabal.hs
View File

@ -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>"

137
yesod-platform/yesod-platform.cabal Normal file
View File

@ -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

39
yesod-routes/LICENSE
View File

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

47
yesod-routes/Yesod/Routes/Overlap.hs
View File

@ -2,27 +2,41 @@
module Yesod.Routes.Overlap
( findOverlaps
, findOverlapNames
, Overlap (..)
) where
import Yesod.Routes.TH.Types
import Control.Arrow ((***))
import Data.Maybe (mapMaybe)
import Data.List (intercalate)
findOverlaps :: [Resource t] -> [(Resource t, Resource t)]
findOverlaps [] = []
findOverlaps (x:xs) = mapMaybe (findOverlap x) xs ++ findOverlaps xs
data Overlap t = Overlap
{ overlapParents :: [String] -> [String] -- ^ parent resource trees
, overlap1 :: ResourceTree t
, overlap2 :: ResourceTree t
}
findOverlap :: Resource t -> Resource t -> Maybe (Resource t, Resource t)
findOverlap x y
| overlaps (resourcePieces x) (resourcePieces y) (hasSuffix x) (hasSuffix y) = Just (x, y)
| otherwise = Nothing
findOverlaps :: ([String] -> [String]) -> [ResourceTree t] -> [Overlap t]
findOverlaps _ [] = []
findOverlaps front (x:xs) = concatMap (findOverlap front x) xs ++ findOverlaps front xs
hasSuffix :: Resource t -> Bool
hasSuffix r =
findOverlap :: ([String] -> [String]) -> ResourceTree t -> ResourceTree t -> [Overlap t]
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 = map (resourceName *** resourceName) . findOverlaps
findOverlapNames :: [ResourceTree t] -> [(String, String)]
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]]

32
yesod-routes/Yesod/Routes/Parse.hs
View File

@ -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 =
case takeWhile (/= "--") $ words s of
(pattern:constr:rest) ->
let (pieces, mmulti) = piecesFromString $ drop1Slash pattern
disp = dispatchFromString rest mmulti
in Just $ Resource constr pieces disp
[] -> Nothing
_ -> error $ "Invalid resource line: " ++ s
parse _ [] = ([], [])
parse indent (thisLine:otherLines)
| length spaces < indent = ([], thisLine : otherLines)
| otherwise = (this others, remainder)
where
spaces = takeWhile (== ' ') thisLine
(others, remainder) = parse indent otherLines'
(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

65
yesod-routes/Yesod/Routes/TH/Dispatch.hs
View File

@ -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 fixHandler (Resource name pieces (Methods mmulti methods)) = do
buildMethodMap _ (FlatResource _ _ _ (Methods _ [])) = return Nothing -- single handle function
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 runHandler dispatcher fixHandler (Resource name resPieces resDisp) = do
buildRoute :: Q Exp -> Q Exp -> Q Exp -> FlatResource a -> Q Exp
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
y <- newName "y"
-- Note: the zipping with Ints is just a workaround for (apparently) a bug
-- 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']

62
yesod-routes/Yesod/Routes/TH/RenderRoute.hs
View File

@ -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 =
NormalC (mkName $ resourceName res)
mkRouteCon (ResourceLeaf 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]

21
yesod-routes/Yesod/Routes/TH/Types.hs
View File

@ -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)]

103
yesod-routes/test/Hierarchy.hs Normal file
View File

@ -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")

38
yesod-routes/test/main.hs
View File

@ -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
class ToText a where
toText :: a -> Text
instance ToText Text where toText = id
instance ToText String where toText = pack
import Hierarchy
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"

11
yesod-routes/yesod-routes.cabal
View File

@ -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
, containers >= 0.2 && < 0.5
, vector >= 0.8 && < 0.11
, 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

39
yesod-sitemap/LICENSE
View File

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

13
yesod-sitemap/Yesod/Sitemap.hs
View File

@ -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
[ Element "loc" [] [NodeContent $ render sitemapLoc]
, Element "lastmod" [] [NodeContent $ formatW3 sitemapLastMod]
, Element "changefreq" [] [NodeContent $ showFreq sitemapChangeFreq]
, Element "priority" [] [NodeContent $ pack $ show sitemapPriority]
go SitemapUrl {..} = NodeElement $ Element "url" Map.empty $ map NodeElement
[ Element "loc" Map.empty [NodeContent $ render sitemapLoc]
, Element "lastmod" Map.empty [NodeContent $ formatW3 sitemapLastMod]
, Element "changefreq" Map.empty [NodeContent $ showFreq sitemapChangeFreq]
, Element "priority" Map.empty [NodeContent $ pack $ show sitemapPriority]
]
sitemap :: [SitemapUrl (Route master)] -> GHandler sub master RepXml

7
yesod-sitemap/yesod-sitemap.cabal
View File

@ -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

39
yesod-static/LICENSE
View File

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

45
yesod-static/Yesod/Static.hs
View File

@ -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 =
[|Static (defaultWebAppSettings
{ ssFolder = embeddedLookup (toEmbedded $(embedDir fp))
})|]
embed fp = [|Static (embeddedSettings $(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

8
yesod-static/test/YesodStaticTest.hs
View File

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

2
yesod-static/test/tests.hs
View File

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

Some files were not shown because too many files have changed in this diff Show More