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

Merge remote-tracking branch 'upstream/master'

Browse Source
This commit is contained in:
Anthony Burzillo 2014-07-06 18:26:01 -04:00
commit 6d1a25187a
118 changed files with 30453 additions and 12942 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
.gitignore vendored
View File

@ -1,3 +1,4 @@
*~
*.o
*.o_p
*.hi
@ -6,7 +7,12 @@ dist
client_session_key.aes
cabal-dev/
yesod/foobar/
.virthualenv
.hsenv/
.cabal-sandbox/
cabal.sandbox.config
/vendor/
/.shelly/
/tarballs/
.shelly/
tarballs/
*.swp
dist
client_session_key.aes

3
.gitmodules vendored
View File

@ -1,3 +0,0 @@
[submodule "scripts"]
path = scripts
url = git://github.com/yesodweb/scripts.git

12
.travis.yml
View File

@ -2,12 +2,12 @@ language: haskell
install:
- cabal update
- cabal install mega-sdist hspec cabal-meta cabal-src
- git clone https://github.com/snoyberg/tagstream-conduit.git
- cd tagstream-conduit
- cabal-src-install --src-only
- cd ..
- cabal-meta install --force-reinstalls --enable-tests
- cabal install --force-reinstalls hspec cabal-meta cabal-src alex
- cabal-meta install --force-reinstalls
script:
- echo Done
- cabal-meta install --enable-tests
- mega-sdist --test
- cabal install hspec cabal-meta cabal-src
- cabal-meta install --force-reinstalls

15
README Normal file
View File

@ -0,0 +1,15 @@
Authentication methods for Haskell web applications.
Note for Rpxnow:
By default on some (all?) installs wget does not come with root certificates
for SSL. If this is the case then Web.Authenticate.Rpxnow.authenticate will
fail as wget cannot establish a secure connection to rpxnow's servers.
A simple *nix solution, if potentially insecure (man in the middle attacks as
you are downloading the certs) is to grab a copy of the certs extracted from
those that come with firefox, hosted by CURL at
http://curl.haxx.se/ca/cacert.pem , put them somewhere (for ex,
~/.wget/cacert.pem) and then edit your ~/.wgetrc to include:
ca_certificate=~/.wget/cacert.pem
This should fix the problem.

40
README.md
View File

@ -9,7 +9,6 @@ An advanced web framework using the Haskell programming language. Featuring:
* techniques for constant-space memory consumption
* asynchronous IO
* 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/
@ -27,18 +26,19 @@ Your application is a cabal package and you use `cabal` to install its dependenc
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 `hsenv`.
You can prevent this by using cabal sandbox.
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.
Isolating an entire project is also a great idea, you just need some tools to help that process.
On Linux you can use Docker.
On any OS you can use a virtual machine. [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
## Using cabal sandbox
cabal-dev creates a sandboxed environment for an individual cabal package.
Instead of using the `cabal` command, use the `cabal-dev` command which will use the sandbox.
To sandbox a project, type:
Use `yesod devel --dev` when developing your application.
cabal sandbox init
This ensures that future installs will be local to the sandboxed directory.
## Installing the latest development version from github for use with your application
@ -55,32 +55,18 @@ In your application folder, create a `sources.txt` file with the following conte
https://github.com/yesodweb/wai
`./` 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`
Now run: `cabal-meta 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.
## hsenv (Linux only)
## hsenv (Linux and Mac OS X)
[hsenv](http://hackage.haskell.org/package/hsenv) prevents your custom build of Yesod from interfering with your currently installed cabal packages:
[hsenv](https://github.com/tmhedberg/hsenv) also provides a sandbox, but works at the shell level.
Generally we recommend using cabal sandbox, but hsenv has tools for allowing you to use different versions of GHC, which may be useful for you.
* hsenv creates an isolated environment like cabal-dev
* hsenv works at the shell level, so every shell must activate the hsenv
* cabal-dev by default isolates a single cabal package, but hsenv isolates multiple packages together.
* cabal-dev can isolate multiple packages together by using the -s sandbox argument
## cabal-src
The cabal-src tool helps resolve dependency conflicts when installing local packages.
This capability is already built in if you are using cabal-dev or cabal-meta. Otherwise install cabal-src with:
cabal install cabal-src
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.
## Cloning the repos
@ -100,7 +86,7 @@ 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.
The traditional Yesod stack requires 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

15
package-list.sh
View File

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

1
scripts

@ -1 +0,0 @@
Subproject commit 9902ff808afbcb417c6ad125941343878e3afe11

2
sources.txt
View File

@ -9,3 +9,5 @@
./yesod-test
./yesod-bin
./yesod
./yesod-eventsource
./yesod-websockets

4
yesod-auth-oauth/Yesod/Auth/OAuth.hs
View File

@ -43,6 +43,7 @@ authOAuth oauth mkCreds = AuthPlugin name dispatch login
url = PluginR name []
lookupTokenSecret = bsToText . fromMaybe "" . lookup "oauth_token_secret" . unCredential
oauthSessionName = "__oauth_token_secret"
dispatch "GET" ["forward"] = do
render <- lift getUrlRender
tm <- getRouteToParent
@ -72,8 +73,9 @@ authOAuth oauth mkCreds = AuthPlugin name dispatch login
master <- getYesod
accTok <- getAccessToken oauth reqTok (authHttpManager master)
creds <- liftIO $ mkCreds accTok
setCreds True creds
setCredsRedirect creds
dispatch _ _ = notFound
login tm = do
render <- getUrlRender
let oaUrl = render $ tm $ oauthUrl name

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

@ -1,9 +1,9 @@
name: yesod-auth-oauth
version: 1.2.0
version: 1.3.0
license: BSD3
license-file: LICENSE
author: Hiromi Ishii
maintainer: Hiromi Ishii
maintainer: Michael Litchard
synopsis: OAuth Authentication for Yesod.
category: Web, Yesod
stability: Stable
@ -20,13 +20,13 @@ library
cpp-options: -DGHC7
else
build-depends: base >= 4 && < 4.3
build-depends: authenticate-oauth >= 1.4 && < 1.5
build-depends: authenticate-oauth >= 1.5 && < 1.6
, bytestring >= 0.9.1.4
, yesod-core >= 1.2 && < 1.3
, yesod-auth >= 1.2 && < 1.3
, text >= 0.7 && < 0.12
, yesod-auth >= 1.3 && < 1.4
, text >= 0.7
, yesod-form >= 1.3 && < 1.4
, transformers >= 0.2.2 && < 0.4
, transformers >= 0.2.2 && < 0.5
, lifted-base >= 0.2 && < 0.3
exposed-modules: Yesod.Auth.OAuth
ghc-options: -Wall

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

@ -22,6 +22,7 @@ module Yesod.Auth
-- * Plugin interface
, Creds (..)
, setCreds
, setCredsRedirect
, clearCreds
, loginErrorMessage
, loginErrorMessageI
@ -34,6 +35,11 @@ module Yesod.Auth
, AuthException (..)
-- * Helper
, AuthHandler
-- * Internal
, credsKey
, provideJsonMessage
, messageJson401
, asHtml
) where
import Control.Monad (when)
@ -62,6 +68,7 @@ import Control.Exception (Exception)
import Network.HTTP.Types (unauthorized401)
import Control.Monad.Trans.Resource (MonadResourceBase)
import qualified Control.Monad.Trans.Writer as Writer
import Control.Monad (void)
type AuthRoute = Route Auth
@ -72,7 +79,7 @@ type Piece = Text
data AuthPlugin master = AuthPlugin
{ apName :: Text
, apDispatch :: Method -> [Piece] -> AuthHandler master ()
, apDispatch :: Method -> [Piece] -> AuthHandler master TypedContent
, apLogin :: (Route Auth -> Route master) -> WidgetT master IO ()
}
@ -89,6 +96,10 @@ data Creds master = Creds
class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage) => YesodAuth master where
type AuthId master
-- | specify the layout. Uses defaultLayout by default
authLayout :: WidgetT master IO () -> HandlerT master IO Html
authLayout = defaultLayout
-- | Default destination on successful login, if no other
-- destination exists.
loginDest :: master -> Route master
@ -104,10 +115,10 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage
authPlugins :: master -> [AuthPlugin master]
-- | What to show on the login page.
loginHandler :: AuthHandler master RepHtml
loginHandler :: AuthHandler master Html
loginHandler = do
tp <- getRouteToParent
lift $ defaultLayout $ do
lift $ authLayout $ do
setTitleI Msg.LoginTitle
master <- getYesod
mapM_ (flip apLogin tp) (authPlugins master)
@ -163,6 +174,16 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage
=> HandlerT master IO (Maybe (AuthId master))
maybeAuthId = defaultMaybeAuthId
-- | Called on login error for HTTP requests. By default, calls
-- @setMessage@ and redirects to @dest@.
onErrorHtml :: (MonadResourceBase m) => Route master -> Text -> HandlerT master m Html
onErrorHtml dest msg = do
setMessage $ toHtml msg
fmap asHtml $ redirect dest
-- | Internal session key used to hold the authentication information.
--
-- Since 1.2.3
credsKey :: Text
credsKey = "_ID"
@ -212,7 +233,7 @@ cachedAuth aid = runMaybeT $ do
loginErrorMessageI :: (MonadResourceBase m, YesodAuth master)
=> Route child
-> AuthMessage
-> HandlerT child (HandlerT master m) a
-> HandlerT child (HandlerT master m) TypedContent
loginErrorMessageI dest msg = do
toParent <- getRouteToParent
lift $ loginErrorMessageMasterI (toParent dest) msg
@ -221,61 +242,74 @@ loginErrorMessageI dest msg = do
loginErrorMessageMasterI :: (YesodAuth master, MonadResourceBase m, RenderMessage master AuthMessage)
=> Route master
-> AuthMessage
-> HandlerT master m a
-> HandlerT master m TypedContent
loginErrorMessageMasterI dest msg = do
mr <- getMessageRender
loginErrorMessage dest (mr msg)
-- | For HTML, set the message and redirect to the route.
-- For JSON, send the message and a 401 status
loginErrorMessage :: MonadResourceBase m
=> Route site
loginErrorMessage :: (YesodAuth master, MonadResourceBase m)
=> Route master
-> Text
-> HandlerT site m a
loginErrorMessage dest msg =
sendResponseStatus unauthorized401 =<< (
selectRep $ do
provideRep $ do
setMessage $ toHtml msg
fmap asHtml $ redirect dest
provideJsonMessage msg
)
where
asHtml :: Html -> Html
asHtml = id
-> HandlerT master m TypedContent
loginErrorMessage dest msg = messageJson401 msg (onErrorHtml dest msg)
messageJson401 :: MonadResourceBase m => Text -> HandlerT master m Html -> HandlerT master m TypedContent
messageJson401 msg html = selectRep $ do
provideRep html
provideRep $ do
let obj = object ["message" .= msg]
void $ sendResponseStatus unauthorized401 obj
return obj
provideJsonMessage :: Monad m => Text -> Writer.Writer (Endo [ProvidedRep m]) ()
provideJsonMessage msg = provideRep $ return $ object ["message" .= msg]
setCredsRedirect :: YesodAuth master
=> Creds master -- ^ new credentials
-> HandlerT master IO TypedContent
setCredsRedirect creds = do
y <- getYesod
maid <- getAuthId creds
case maid of
Nothing ->
case authRoute y of
Nothing -> do
messageJson401 "Invalid Login" $ authLayout $
toWidget [shamlet|<h1>Invalid login|]
Just ar -> loginErrorMessageMasterI ar Msg.InvalidLogin
Just aid -> do
setSession credsKey $ toPathPiece aid
onLogin
res <- selectRep $ do
provideRepType typeHtml $
fmap asHtml $ redirectUltDest $ loginDest y
provideJsonMessage "Login Successful"
sendResponse res
-- | Sets user credentials for the session after checking them with authentication backends.
setCreds :: YesodAuth master
=> Bool -- ^ if HTTP redirects should be done
-> Creds master -- ^ new credentials
-> HandlerT master IO ()
setCreds doRedirects creds = do
y <- getYesod
maid <- getAuthId creds
case maid of
Nothing -> when doRedirects $ do
case authRoute y of
Nothing -> do
sendResponseStatus unauthorized401 =<< (
selectRep $ do
provideRep $ defaultLayout $ toWidget [shamlet|<h1>Invalid login|]
provideJsonMessage "Invalid Login"
)
Just ar -> loginErrorMessageMasterI ar Msg.InvalidLogin
Just aid -> do
setSession credsKey $ toPathPiece aid
when doRedirects $ do
onLogin
res <- selectRep $ do
provideRepType typeHtml $ do
_ <- redirectUltDest $ loginDest y
return ()
provideJsonMessage "Login Successful"
sendResponse res
setCreds doRedirects creds =
if doRedirects
then void $ setCredsRedirect creds
else do maid <- getAuthId creds
case maid of
Nothing -> return ()
Just aid -> setSession credsKey $ toPathPiece aid
-- | same as defaultLayoutJson, but uses authLayout
authLayoutJson :: (YesodAuth site, ToJSON j)
=> WidgetT site IO () -- ^ HTML
-> HandlerT site IO j -- ^ JSON
-> HandlerT site IO TypedContent
authLayoutJson w json = selectRep $ do
provideRep $ authLayout w
provideRep $ fmap toJSON json
-- | Clears current user credentials for the session.
--
@ -293,7 +327,7 @@ clearCreds doRedirects = do
getCheckR :: AuthHandler master TypedContent
getCheckR = lift $ do
creds <- maybeAuthId
defaultLayoutJson (do
authLayoutJson (do
setTitle "Authentication Status"
toWidget $ html' creds) (return $ jsonCreds creds)
where
@ -316,7 +350,7 @@ setUltDestReferer' = lift $ do
master <- getYesod
when (redirectToReferer master) setUltDestReferer
getLoginR :: AuthHandler master RepHtml
getLoginR :: AuthHandler master Html
getLoginR = setUltDestReferer' >> loginHandler
getLogoutR :: AuthHandler master ()
@ -325,7 +359,7 @@ getLogoutR = setUltDestReferer' >> redirectToPost LogoutR
postLogoutR :: AuthHandler master ()
postLogoutR = lift $ clearCreds True
handlePluginR :: Text -> [Text] -> AuthHandler master ()
handlePluginR :: Text -> [Text] -> AuthHandler master TypedContent
handlePluginR plugin pieces = do
master <- lift getYesod
env <- waiRequest
@ -334,6 +368,11 @@ handlePluginR plugin pieces = do
[] -> notFound
ap:_ -> apDispatch ap method pieces
-- | Similar to 'maybeAuthId', but additionally look up the value associated
-- with the user\'s database identifier to get the value in the database. This
-- assumes that you are using a Persistent database.
--
-- Since 1.1.0
maybeAuth :: ( YesodAuth master
, PersistMonadBackend (b (HandlerT master IO)) ~ PersistEntityBackend val
, b ~ YesodPersistBackend master
@ -383,6 +422,10 @@ type AuthEntity master = KeyEntity (AuthId master)
requireAuthId :: YesodAuthPersist master => HandlerT master IO (AuthId master)
requireAuthId = maybeAuthId >>= maybe redirectLogin return
-- | Similar to 'maybeAuth', but redirects to a login page if user is not
-- authenticated.
--
-- Since 1.1.0
requireAuth :: YesodAuthPersist master => HandlerT master IO (Entity (AuthEntity master))
requireAuth = maybeAuth >>= maybe redirectLogin return
@ -403,3 +446,6 @@ instance Exception AuthException
instance YesodAuth master => YesodSubDispatch Auth (HandlerT master IO) where
yesodSubDispatch = $(mkYesodSubDispatch resourcesAuth)
asHtml :: Html -> Html
asHtml = id

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

@ -4,7 +4,7 @@
{-# LANGUAGE RecordWildCards #-}
module Yesod.Auth.BrowserId
( authBrowserId
, createOnClick
, createOnClick, createOnClickOverride
, def
, BrowserIdSettings
, bisAudience
@ -75,8 +75,9 @@ authBrowserId bis@BrowserIdSettings {..} = AuthPlugin
case memail of
Nothing -> do
$logErrorS "yesod-auth" "BrowserID assertion failure"
loginErrorMessage LoginR "BrowserID login error."
Just email -> lift $ setCreds True Creds
tm <- getRouteToParent
lift $ loginErrorMessage (tm LoginR) "BrowserID login error."
Just email -> lift $ setCredsRedirect Creds
{ credsPlugin = pid
, credsIdent = email
, credsExtra = []
@ -106,14 +107,16 @@ $newline never
-- | Generates a function to handle on-click events, and returns that function
-- name.
createOnClick :: BrowserIdSettings
createOnClickOverride :: BrowserIdSettings
-> (Route Auth -> Route master)
-> Maybe (Route master)
-> WidgetT master IO Text
createOnClick BrowserIdSettings {..} toMaster = do
createOnClickOverride BrowserIdSettings {..} toMaster mOnRegistration = do
unless bisLazyLoad $ addScriptRemote browserIdJs
onclick <- newIdent
render <- getUrlRender
let login = toJSON $ getPath $ render (toMaster LoginR)
let login = toJSON $ getPath $ render loginRoute -- (toMaster LoginR)
loginRoute = maybe (toMaster LoginR) id mOnRegistration
toWidget [julius|
function #{rawJS onclick}() {
if (navigator.id) {
@ -151,3 +154,10 @@ createOnClick BrowserIdSettings {..} toMaster = do
getPath t = fromMaybe t $ do
uri <- parseURI $ T.unpack t
return $ T.pack $ uriPath uri
-- | Generates a function to handle on-click events, and returns that function
-- name.
createOnClick :: BrowserIdSettings
-> (Route Auth -> Route master)
-> WidgetT master IO Text
createOnClick bidSettings toMaster = createOnClickOverride bidSettings toMaster Nothing

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

@ -18,7 +18,7 @@ authDummy =
where
dispatch "POST" [] = do
ident <- lift $ runInputPost $ ireq textField "ident"
lift $ setCreds True $ Creds "dummy" ident []
lift $ setCredsRedirect $ Creds "dummy" ident []
dispatch _ _ = notFound
url = PluginR "dummy" []
login authToMaster =

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

@ -2,6 +2,7 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE Rank2Types #-}
module Yesod.Auth.Email
( -- * Plugin
authEmail
@ -24,25 +25,32 @@ module Yesod.Auth.Email
-- * Misc
, loginLinkKey
, setLoginLinkKey
-- * Default handlers
, defaultRegisterHandler
, defaultForgotPasswordHandler
, defaultSetPasswordHandler
) where
import Network.Mail.Mime (randomString)
import Yesod.Auth
import System.Random
import Data.Digest.Pure.MD5
import qualified Data.Text as TS
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Encoding as TE
import qualified Data.Text.Lazy.Encoding as TLE
import qualified Crypto.Hash.MD5 as H
import Data.ByteString.Base16 as B16
import Data.Text.Encoding (encodeUtf8, decodeUtf8With)
import Data.Text.Encoding.Error (lenientDecode)
import Data.Text (Text)
import Yesod.Core
import qualified Crypto.PasswordStore as PS
import qualified Yesod.PasswordStore as PS
import qualified Text.Email.Validate
import qualified Yesod.Auth.Message as Msg
import Control.Applicative ((<$>), (<*>))
import Control.Monad (void)
import Yesod.Form
import Control.Monad (when)
import Data.Time (getCurrentTime, addUTCTime)
import Safe (readMay)
@ -78,7 +86,11 @@ data EmailCreds site = EmailCreds
, emailCredsEmail :: Email
}
class (YesodAuth site, PathPiece (AuthEmailId site)) => YesodAuthEmail site where
class ( YesodAuth site
, PathPiece (AuthEmailId site)
, (RenderMessage site Msg.AuthMessage)
)
=> YesodAuthEmail site where
type AuthEmailId site
-- | Add a new email address to the database, but indicate that the address
@ -164,6 +176,63 @@ class (YesodAuth site, PathPiece (AuthEmailId site)) => YesodAuthEmail site wher
| TS.length x >= 3 = return $ Right ()
| otherwise = return $ Left "Password must be at least three characters"
-- | Response after sending a confirmation email.
--
-- Since 1.2.2
confirmationEmailSentResponse :: Text -> HandlerT site IO TypedContent
confirmationEmailSentResponse identifier = do
mr <- getMessageRender
messageJson401 (mr msg) $ authLayout $ do
setTitleI Msg.ConfirmationEmailSentTitle
[whamlet|<p>_{msg}|]
where
msg = Msg.ConfirmationEmailSent identifier
-- | Additional normalization of email addresses, besides standard canonicalization.
--
-- Default: Lower case the email address.
--
-- Since 1.2.3
normalizeEmailAddress :: site -> Text -> Text
normalizeEmailAddress _ = TS.toLower
-- | Handler called to render the registration page. The
-- default works fine, but you may want to override it in
-- order to have a different DOM.
--
-- Default: 'defaultRegisterHandler'.
--
-- Since: 1.2.6.
registerHandler :: AuthHandler site Html
registerHandler = defaultRegisterHandler
-- | Handler called to render the \"forgot password\" page.
-- The default works fine, but you may want to override it in
-- order to have a different DOM.
--
-- Default: 'defaultForgotPasswordHandler'.
--
-- Since: 1.2.6.
forgotPasswordHandler :: AuthHandler site Html
forgotPasswordHandler = defaultForgotPasswordHandler
-- | Handler called to render the \"set password\" page. The
-- default works fine, but you may want to override it in
-- order to have a different DOM.
--
-- Default: 'defaultSetPasswordHandler'.
--
-- Since: 1.2.6.
setPasswordHandler ::
Bool
-- ^ Whether the old password is needed. If @True@, a
-- field for the old password should be presented.
-- Otherwise, just two fields for the new password are
-- needed.
-> AuthHandler site TypedContent
setPasswordHandler = defaultSetPasswordHandler
authEmail :: YesodAuthEmail m => AuthPlugin m
authEmail =
AuthPlugin "email" dispatch $ \tm ->
@ -181,8 +250,11 @@ $newline never
<input type="password" name="password">
<tr>
<td colspan="2">
<input type="submit" value=_{Msg.LoginViaEmail}>
<a href="@{tm registerR}">I don't have an account
<button type=submit .btn .btn-success>
_{Msg.LoginViaEmail}
&nbsp;
<a href="@{tm registerR}" .btn .btn-default>
_{Msg.RegisterLong}
|]
where
dispatch "GET" ["register"] = getRegisterR >>= sendResponse
@ -199,10 +271,16 @@ $newline never
dispatch _ _ = notFound
getRegisterR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) Html
getRegisterR = do
getRegisterR = registerHandler
-- | Default implementation of 'registerHandler'.
--
-- Since: 1.2.6
defaultRegisterHandler :: YesodAuthEmail master => AuthHandler master Html
defaultRegisterHandler = do
email <- newIdent
tp <- getRouteToParent
lift $ defaultLayout $ do
lift $ authLayout $ do
setTitleI Msg.RegisterLong
[whamlet|
<p>_{Msg.EnterEmail}
@ -216,51 +294,59 @@ getRegisterR = do
registerHelper :: YesodAuthEmail master
=> Bool -- ^ allow usernames?
-> Route Auth
-> HandlerT Auth (HandlerT master IO) Html
-> HandlerT Auth (HandlerT master IO) TypedContent
registerHelper allowUsername dest = do
y <- lift getYesod
midentifier <- lookupPostParam "email"
identifier <-
case midentifier of
Nothing -> do
loginErrorMessageI dest Msg.NoIdentifierProvided
let eidentifier = case midentifier of
Nothing -> Left Msg.NoIdentifierProvided
Just x
| Just x' <- Text.Email.Validate.canonicalizeEmail (encodeUtf8 x) ->
return $ decodeUtf8With lenientDecode x'
| allowUsername -> return $ TS.strip x
| otherwise -> do
loginErrorMessageI dest Msg.InvalidEmailAddress
mecreds <- lift $ getEmailCreds identifier
(lid, verKey, email) <-
case mecreds of
Just (EmailCreds lid _ _ (Just key) email) -> return (lid, key, email)
Just (EmailCreds lid _ _ Nothing email) -> do
key <- liftIO $ randomKey y
lift $ setVerifyKey lid key
return (lid, key, email)
Nothing
| allowUsername -> do
setMessage $ toHtml $ "No record for that identifier in our database: " `TS.append` identifier
redirect dest
| otherwise -> do
key <- liftIO $ randomKey y
lid <- lift $ addUnverified identifier key
return (lid, key, identifier)
render <- getUrlRender
let verUrl = render $ verify (toPathPiece lid) verKey
lift $ sendVerifyEmail email verKey verUrl
lift $ defaultLayout $ do
setTitleI Msg.ConfirmationEmailSentTitle
[whamlet|<p>_{Msg.ConfirmationEmailSent identifier}|]
Right $ normalizeEmailAddress y $ decodeUtf8With lenientDecode x'
| allowUsername -> Right $ TS.strip x
| otherwise -> Left Msg.InvalidEmailAddress
postRegisterR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) Html
case eidentifier of
Left route -> loginErrorMessageI dest route
Right identifier -> do
mecreds <- lift $ getEmailCreds identifier
registerCreds <-
case mecreds of
Just (EmailCreds lid _ _ (Just key) email) -> return $ Just (lid, key, email)
Just (EmailCreds lid _ _ Nothing email) -> do
key <- liftIO $ randomKey y
lift $ setVerifyKey lid key
return $ Just (lid, key, email)
Nothing
| allowUsername -> return Nothing
| otherwise -> do
key <- liftIO $ randomKey y
lid <- lift $ addUnverified identifier key
return $ Just (lid, key, identifier)
case registerCreds of
Nothing -> loginErrorMessageI dest (Msg.IdentifierNotFound identifier)
Just (lid, verKey, email) -> do
render <- getUrlRender
let verUrl = render $ verify (toPathPiece lid) verKey
lift $ sendVerifyEmail email verKey verUrl
lift $ confirmationEmailSentResponse identifier
postRegisterR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) TypedContent
postRegisterR = registerHelper False registerR
getForgotPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) Html
getForgotPasswordR = do
getForgotPasswordR = forgotPasswordHandler
-- | Default implementation of 'forgotPasswordHandler'.
--
-- Since: 1.2.6
defaultForgotPasswordHandler :: YesodAuthEmail master => AuthHandler master Html
defaultForgotPasswordHandler = do
tp <- getRouteToParent
email <- newIdent
lift $ defaultLayout $ do
lift $ authLayout $ do
setTitleI Msg.PasswordResetTitle
[whamlet|
<p>_{Msg.PasswordResetPrompt}
@ -271,35 +357,43 @@ getForgotPasswordR = do
<button .btn>_{Msg.SendPasswordResetEmail}
|]
postForgotPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) Html
postForgotPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) TypedContent
postForgotPasswordR = registerHelper True forgotPasswordR
getVerifyR :: YesodAuthEmail site
=> AuthEmailId site
-> Text
-> HandlerT Auth (HandlerT site IO) Html
-> HandlerT Auth (HandlerT site IO) TypedContent
getVerifyR lid key = do
realKey <- lift $ getVerifyKey lid
memail <- lift $ getEmail lid
mr <- lift getMessageRender
case (realKey == Just key, memail) of
(True, Just email) -> do
muid <- lift $ verifyAccount lid
case muid of
Nothing -> return ()
Nothing -> invalidKey mr
Just uid -> do
lift $ setCreds False $ Creds "email-verify" email [("verifiedEmail", email)] -- FIXME uid?
lift $ setMessageI Msg.AddressVerified
lift $ setLoginLinkKey uid
redirect setpassR
_ -> return ()
lift $ defaultLayout $ do
setTitleI Msg.InvalidKey
let msgAv = Msg.AddressVerified
selectRep $ do
provideRep $ do
lift $ setMessageI msgAv
fmap asHtml $ redirect setpassR
provideJsonMessage $ mr msgAv
_ -> invalidKey mr
where
msgIk = Msg.InvalidKey
invalidKey mr = messageJson401 (mr msgIk) $ lift $ authLayout $ do
setTitleI msgIk
[whamlet|
$newline never
<p>_{Msg.InvalidKey}
<p>_{msgIk}
|]
postLoginR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) ()
postLoginR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) TypedContent
postLoginR = do
(identifier, pass) <- lift $ runInputPost $ (,)
<$> ireq textField "email"
@ -322,30 +416,40 @@ postLoginR = do
let isEmail = Text.Email.Validate.isValid $ encodeUtf8 identifier
case maid of
Just email ->
lift $ setCreds True $ Creds
lift $ setCredsRedirect $ Creds
(if isEmail then "email" else "username")
email
[("verifiedEmail", email)]
Nothing -> do
Nothing ->
loginErrorMessageI LoginR $
if isEmail
then Msg.InvalidEmailPass
else Msg.InvalidUsernamePass
getPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) Html
getPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) TypedContent
getPasswordR = do
maid <- lift maybeAuthId
case maid of
Nothing -> loginErrorMessageI LoginR Msg.BadSetPass
Just _ -> do
needOld <- maybe (return True) (lift . needOldPassword) maid
setPasswordHandler needOld
-- | Default implementation of 'setPasswordHandler'.
--
-- Since: 1.2.6
defaultSetPasswordHandler :: YesodAuthEmail master => Bool -> AuthHandler master TypedContent
defaultSetPasswordHandler needOld = do
tp <- getRouteToParent
pass0 <- newIdent
pass1 <- newIdent
pass2 <- newIdent
case maid of
Just _ -> return ()
Nothing -> loginErrorMessageI LoginR Msg.BadSetPass
tp <- getRouteToParent
needOld <- maybe (return True) (lift . needOldPassword) maid
lift $ defaultLayout $ do
setTitleI Msg.SetPassTitle
[whamlet|
mr <- lift getMessageRender
selectRep $ do
provideJsonMessage $ mr Msg.SetPass
provideRep $ lift $ authLayout $ do
setTitleI Msg.SetPassTitle
[whamlet|
$newline never
<h3>_{Msg.SetPass}
<form method="post" action="@{tp setpassR}">
@ -371,41 +475,52 @@ $newline never
<input type="submit" value=_{Msg.SetPassTitle}>
|]
postPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) ()
postPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) TypedContent
postPasswordR = do
maid <- lift maybeAuthId
aid <- case maid of
Nothing -> loginErrorMessageI LoginR Msg.BadSetPass
Just aid -> return aid
case maid of
Nothing -> loginErrorMessageI LoginR Msg.BadSetPass
Just aid -> do
tm <- getRouteToParent
needOld <- lift $ needOldPassword aid
when needOld $ do
current <- lift $ runInputPost $ ireq textField "current"
mrealpass <- lift $ getPassword aid
case mrealpass of
Nothing -> loginErrorMessage setpassR "You do not currently have a password set on your account"
Just realpass
| isValidPass current realpass -> return ()
| otherwise -> loginErrorMessage setpassR "Invalid current password, please try again"
needOld <- lift $ needOldPassword aid
if not needOld then confirmPassword aid tm else do
current <- lift $ runInputPost $ ireq textField "current"
mrealpass <- lift $ getPassword aid
case mrealpass of
Nothing ->
lift $ loginErrorMessage (tm setpassR) "You do not currently have a password set on your account"
Just realpass
| isValidPass current realpass -> confirmPassword aid tm
| otherwise ->
lift $ loginErrorMessage (tm setpassR) "Invalid current password, please try again"
(new, confirm) <- lift $ runInputPost $ (,)
<$> ireq textField "new"
<*> ireq textField "confirm"
when (new /= confirm) $
loginErrorMessageI setpassR Msg.PassMismatch
where
msgOk = Msg.PassUpdated
confirmPassword aid tm = do
(new, confirm) <- lift $ runInputPost $ (,)
<$> ireq textField "new"
<*> ireq textField "confirm"
isSecure <- lift $ checkPasswordSecurity aid new
case isSecure of
Left e -> loginErrorMessage setpassR e
Right () -> return ()
if new /= confirm
then loginErrorMessageI setpassR Msg.PassMismatch
else do
isSecure <- lift $ checkPasswordSecurity aid new
case isSecure of
Left e -> lift $ loginErrorMessage (tm setpassR) e
Right () -> do
salted <- liftIO $ saltPass new
y <- lift $ do
setPassword aid salted
deleteSession loginLinkKey
setMessageI msgOk
getYesod
salted <- liftIO $ saltPass new
lift $ do
y <- getYesod
setPassword aid salted
setMessageI Msg.PassUpdated
deleteSession loginLinkKey
redirect $ afterPasswordRoute y
mr <- lift getMessageRender
selectRep $ do
provideRep $
fmap asHtml $ lift $ redirect $ afterPasswordRoute y
provideJsonMessage (mr msgOk)
saltLength :: Int
saltLength = 5
@ -413,11 +528,12 @@ saltLength = 5
-- | Salt a password with a randomly generated salt.
saltPass :: Text -> IO Text
saltPass = fmap (decodeUtf8With lenientDecode)
. flip PS.makePassword 12
. flip PS.makePassword 14
. encodeUtf8
saltPass' :: String -> String -> String
saltPass' salt pass = salt ++ show (md5 $ TLE.encodeUtf8 $ TL.pack $ salt ++ pass)
saltPass' salt pass =
salt ++ T.unpack (TE.decodeUtf8 $ B16.encode $ H.hash $ TE.encodeUtf8 $ T.pack $ salt ++ pass)
isValidPass :: Text -- ^ cleartext password
-> SaltedPass -- ^ salted password

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

@ -54,7 +54,9 @@ authGoogleEmail =
, ("openid.ui.icon", "true")
] (authHttpManager master)
either
(\err -> loginErrorMessage LoginR $ T.pack $ show (err :: SomeException))
(\err -> do
tm <- getRouteToParent
lift $ loginErrorMessage (tm LoginR) $ T.pack $ show (err :: SomeException))
redirect
eres
dispatch "GET" ["complete", ""] = dispatch "GET" ["complete"] -- compatibility issues
@ -67,17 +69,19 @@ authGoogleEmail =
completeHelper posts
dispatch _ _ = notFound
completeHelper :: YesodAuth master => [(Text, Text)] -> AuthHandler master ()
completeHelper :: YesodAuth master => [(Text, Text)] -> AuthHandler master TypedContent
completeHelper gets' = do
master <- lift getYesod
eres <- lift $ try $ OpenId.authenticateClaimed gets' (authHttpManager master)
either onFailure onSuccess eres
tm <- getRouteToParent
either (onFailure tm) (onSuccess tm) eres
where
onFailure err = loginErrorMessage LoginR $ T.pack $ show (err :: SomeException)
onSuccess oir = do
onFailure tm err =
lift $ loginErrorMessage (tm LoginR) $ T.pack $ show (err :: SomeException)
onSuccess tm 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) -> lift $ setCreds True $ Creds pid email []
(_, False) -> loginErrorMessage LoginR "Only Google login is supported"
(Nothing, _) -> loginErrorMessage LoginR "No email address provided"
(Just email, True) -> lift $ setCredsRedirect $ Creds pid email []
(_, False) -> lift $ loginErrorMessage (tm LoginR) "Only Google login is supported"
(Nothing, _) -> lift $ loginErrorMessage (tm LoginR) "No email address provided"

202
yesod-auth/Yesod/Auth/GoogleEmail2.hs Normal file
View File

@ -0,0 +1,202 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
-- | Use an email address as an identifier via Google's login system.
--
-- Note that this is a replacement for "Yesod.Auth.GoogleEmail", which depends
-- on Google's now deprecated OpenID system. For more information, see
-- <https://developers.google.com/+/api/auth-migration>.
--
-- By using this plugin, you are trusting Google to validate an email address,
-- and requiring users to have a Google account. On the plus side, you get to
-- use email addresses as the identifier, many users have existing Google
-- accounts, the login system has been long tested (as opposed to BrowserID),
-- and it requires no credential managing or setup (as opposed to Email).
--
-- In order to use this plugin:
--
-- * Create an application on the Google Developer Console <https://console.developers.google.com/>
--
-- * Create OAuth credentials. The redirect URI will be <http://yourdomain/auth/page/googleemail2/complete>. (If you have your authentication subsite at a different root than \/auth\/, please adjust accordingly.)
--
-- * Enable the Google+ API.
--
-- Since 1.3.1
module Yesod.Auth.GoogleEmail2
( authGoogleEmail
, forwardUrl
) where
import Blaze.ByteString.Builder (fromByteString, toByteString)
import Control.Applicative ((<$>), (<*>))
import Control.Arrow (second)
import Control.Monad (liftM, unless)
import Data.Aeson.Parser (json')
import Data.Aeson.Types (FromJSON (parseJSON), parseEither,
withObject)
import Data.Conduit (($$+-))
import Data.Conduit.Attoparsec (sinkParser)
import Data.Monoid (mappend)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
import Network.HTTP.Client (parseUrl, requestHeaders,
responseBody, urlEncodedBody)
import Network.HTTP.Conduit (http)
import Network.HTTP.Types (renderQueryText)
import Network.Mail.Mime (randomString)
import System.Random (newStdGen)
import Yesod.Auth (Auth, AuthPlugin (AuthPlugin),
AuthRoute, Creds (Creds),
Route (PluginR), YesodAuth,
authHttpManager, setCredsRedirect)
import qualified Yesod.Auth.Message as Msg
import Yesod.Core (HandlerSite, MonadHandler,
getRouteToParent, getUrlRender,
getYesod, invalidArgs, lift,
lookupGetParam,
lookupSession, notFound, redirect,
setSession, whamlet, (.:),
TypedContent, HandlerT, liftIO)
pid :: Text
pid = "googleemail2"
forwardUrl :: AuthRoute
forwardUrl = PluginR pid ["forward"]
csrfKey :: Text
csrfKey = "_GOOGLE_CSRF_TOKEN"
getCsrfToken :: MonadHandler m => m (Maybe Text)
getCsrfToken = lookupSession csrfKey
getCreateCsrfToken :: MonadHandler m => m Text
getCreateCsrfToken = do
mtoken <- getCsrfToken
case mtoken of
Just token -> return token
Nothing -> do
stdgen <- liftIO newStdGen
let token = T.pack $ fst $ randomString 10 stdgen
setSession csrfKey token
return token
authGoogleEmail :: YesodAuth m
=> Text -- ^ client ID
-> Text -- ^ client secret
-> AuthPlugin m
authGoogleEmail clientID clientSecret =
AuthPlugin pid dispatch login
where
complete = PluginR pid ["complete"]
getDest :: MonadHandler m
=> (Route Auth -> Route (HandlerSite m))
-> m Text
getDest tm = do
csrf <- getCreateCsrfToken
render <- getUrlRender
let qs = map (second Just)
[ ("scope", "email")
, ("state", csrf)
, ("redirect_uri", render $ tm complete)
, ("response_type", "code")
, ("client_id", clientID)
, ("access_type", "offline")
]
return $ decodeUtf8
$ toByteString
$ fromByteString "https://accounts.google.com/o/oauth2/auth"
`mappend` renderQueryText True qs
login tm = do
url <- getDest tm
[whamlet|<a href=#{url}>_{Msg.LoginGoogle}|]
dispatch :: YesodAuth site
=> Text
-> [Text]
-> HandlerT Auth (HandlerT site IO) TypedContent
dispatch "GET" ["forward"] = do
tm <- getRouteToParent
lift (getDest tm) >>= redirect
dispatch "GET" ["complete"] = do
mstate <- lookupGetParam "state"
case mstate of
Nothing -> invalidArgs ["CSRF state from Google is missing"]
Just state -> do
mtoken <- getCsrfToken
unless (Just state == mtoken) $ invalidArgs ["Invalid CSRF token from Google"]
mcode <- lookupGetParam "code"
code <-
case mcode of
Nothing -> invalidArgs ["Missing code paramter"]
Just c -> return c
render <- getUrlRender
req' <- liftIO $ parseUrl "https://accounts.google.com/o/oauth2/token" -- FIXME don't hardcode, use: https://accounts.google.com/.well-known/openid-configuration
let req =
urlEncodedBody
[ ("code", encodeUtf8 code)
, ("client_id", encodeUtf8 clientID)
, ("client_secret", encodeUtf8 clientSecret)
, ("redirect_uri", encodeUtf8 $ render complete)
, ("grant_type", "authorization_code")
]
req'
{ requestHeaders = []
}
manager <- liftM authHttpManager $ lift getYesod
res <- http req manager
value <- responseBody res $$+- sinkParser json'
Tokens accessToken _idToken tokenType <-
case parseEither parseJSON value of
Left e -> error e
Right t -> return t
unless (tokenType == "Bearer") $ error $ "Unknown token type: " ++ show tokenType
req2' <- liftIO $ parseUrl "https://www.googleapis.com/plus/v1/people/me"
let req2 = req2'
{ requestHeaders =
[ ("Authorization", encodeUtf8 $ "Bearer " `mappend` accessToken)
]
}
res2 <- http req2 manager
value2 <- responseBody res2 $$+- sinkParser json'
Person emails <-
case parseEither parseJSON value2 of
Left e -> error e
Right x -> return x
email <-
case map emailValue $ filter (\e -> emailType e == "account") emails of
[e] -> return e
[] -> error "No account email"
x -> error $ "Too many account emails: " ++ show x
lift $ setCredsRedirect $ Creds pid email []
dispatch _ _ = notFound
data Tokens = Tokens Text Text Text
instance FromJSON Tokens where
parseJSON = withObject "Tokens" $ \o -> Tokens
<$> o .: "access_token"
<*> o .: "id_token"
<*> o .: "token_type"
data Person = Person [Email]
instance FromJSON Person where
parseJSON = withObject "Person" $ \o -> Person
<$> o .: "emails"
data Email = Email
{ emailValue :: Text
, emailType :: Text
}
deriving Show
instance FromJSON Email where
parseJSON = withObject "Email" $ \o -> Email
<$> o .: "value"
<*> o .: "type"

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

@ -1,268 +0,0 @@
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE CPP #-}
-------------------------------------------------------------------------------
-- |
-- Module : Yesod.Auth.HashDB
-- Copyright : (c) Patrick Brisbin 2010
-- License : as-is
--
-- Maintainer : pbrisbin@gmail.com
-- Stability : Stable
-- Portability : Portable
--
-- A yesod-auth AuthPlugin designed to look users up in Persist where
-- their user id's and a salted SHA1 hash of their password is stored.
--
-- Example usage:
--
-- > -- import the function
-- > import Auth.HashDB
-- >
-- > -- make sure you have an auth route
-- > mkYesodData "MyApp" [$parseRoutes|
-- > / RootR GET
-- > /auth AuthR Auth getAuth
-- > |]
-- >
-- >
-- > -- make your app an instance of YesodAuth using this plugin
-- > instance YesodAuth MyApp where
-- > type AuthId MyApp = UserId
-- >
-- > loginDest _ = RootR
-- > logoutDest _ = RootR
-- > getAuthId = getAuthIdHashDB AuthR (Just . UniqueUser)
-- > authPlugins = [authHashDB (Just . UniqueUser)]
-- >
-- >
-- > -- include the migration function in site startup
-- > withServer :: (Application -> IO a) -> IO a
-- > withServer f = withConnectionPool $ \p -> do
-- > runSqlPool (runMigration migrateUsers) p
-- > let h = DevSite p
--
-- Note that function which converts username to unique identifier must be same.
--
-- Your app must be an instance of YesodPersist. and the username,
-- salt and hashed-passwords should be added to the database.
--
-- > echo -n 'MySaltMyPassword' | sha1sum
--
-- can be used to get the hash from the commandline.
--
-------------------------------------------------------------------------------
module Yesod.Auth.HashDB
( HashDBUser(..)
, Unique (..)
, setPassword
-- * Authentification
, validateUser
, authHashDB
, getAuthIdHashDB
-- * Predefined data type
, User
, UserGeneric (..)
, UserId
, EntityField (..)
, migrateUsers
) where
import Yesod.Persist
import Yesod.Form
import Yesod.Auth
import Yesod.Core
import Text.Hamlet (hamlet)
import Control.Applicative ((<$>), (<*>))
import Control.Monad (replicateM,liftM)
import qualified Data.ByteString.Lazy.Char8 as BS (pack)
import Data.Digest.Pure.SHA (sha1, showDigest)
import Data.Text (Text, pack, unpack, append)
import Data.Maybe (fromMaybe)
import System.Random (randomRIO)
-- | Interface for data type which holds user info. It's just a
-- collection of getters and setters
class HashDBUser user where
-- | Retrieve password hash from user data
userPasswordHash :: user -> Maybe Text
-- | Retrieve salt for password
userPasswordSalt :: user -> Maybe Text
-- | Deprecated for the better named setSaltAndPasswordHash
setUserHashAndSalt :: Text -- ^ Salt
-> Text -- ^ Password hash
-> user -> user
setUserHashAndSalt = setSaltAndPasswordHash
-- | a callback for setPassword
setSaltAndPasswordHash :: Text -- ^ Salt
-> Text -- ^ Password hash
-> user -> user
setSaltAndPasswordHash = setUserHashAndSalt
-- | Generate random salt. Length of 8 is chosen arbitrarily
randomSalt :: MonadIO m => m Text
randomSalt = pack `liftM` liftIO (replicateM 8 (randomRIO ('0','z')))
-- | Calculate salted hash using SHA1.
saltedHash :: Text -- ^ Salt
-> Text -- ^ Password
-> Text
saltedHash salt =
pack . showDigest . sha1 . BS.pack . unpack . append salt
-- | Set password for user. This function should be used for setting
-- passwords. It generates random salt and calculates proper hashes.
setPassword :: (MonadIO m, HashDBUser user) => Text -> user -> m user
setPassword pwd u = do salt <- randomSalt
return $ setSaltAndPasswordHash salt (saltedHash salt pwd) u
----------------------------------------------------------------
-- Authentification
----------------------------------------------------------------
-- | Given a user ID and password in plaintext, validate them against
-- the database values.
validateUser :: ( YesodPersist yesod
, b ~ YesodPersistBackend yesod
, PersistMonadBackend (b (HandlerT yesod IO)) ~ PersistEntityBackend user
, PersistUnique (b (HandlerT yesod IO))
, PersistEntity user
, HashDBUser user
) =>
Unique user -- ^ User unique identifier
-> Text -- ^ Password in plaint-text
-> HandlerT yesod IO Bool
validateUser userID passwd = do
-- Checks that hash and password match
let validate u = do hash <- userPasswordHash u
salt <- userPasswordSalt u
return $ hash == saltedHash salt passwd
-- Get user data
user <- runDB $ getBy userID
return $ fromMaybe False $ validate . entityVal =<< user
login :: AuthRoute
login = PluginR "hashdb" ["login"]
-- | Handle the login form. First parameter is function which maps
-- username (whatever it might be) to unique user ID.
postLoginR :: ( YesodAuth y, YesodPersist y
, HashDBUser user, PersistEntity user
, b ~ YesodPersistBackend y
, PersistMonadBackend (b (HandlerT y IO)) ~ PersistEntityBackend user
, PersistUnique (b (HandlerT y IO))
)
=> (Text -> Maybe (Unique user))
-> HandlerT Auth (HandlerT y IO) ()
postLoginR uniq = do
(mu,mp) <- lift $ runInputPost $ (,)
<$> iopt textField "username"
<*> iopt textField "password"
isValid <- lift $ fromMaybe (return False)
(validateUser <$> (uniq =<< mu) <*> mp)
if isValid
then lift $ setCreds True $ Creds "hashdb" (fromMaybe "" mu) []
else loginErrorMessage LoginR "Invalid username/password"
-- | A drop in for the getAuthId method of your YesodAuth instance which
-- can be used if authHashDB is the only plugin in use.
getAuthIdHashDB :: ( YesodAuth master, YesodPersist master
, HashDBUser user, PersistEntity user
, Key user ~ AuthId master
, b ~ YesodPersistBackend master
, PersistMonadBackend (b (HandlerT master IO)) ~ PersistEntityBackend user
, PersistUnique (b (HandlerT master IO))
)
=> (AuthRoute -> Route master) -- ^ your site's Auth Route
-> (Text -> Maybe (Unique user)) -- ^ gets user ID
-> Creds master -- ^ the creds argument
-> HandlerT master IO (Maybe (AuthId master))
getAuthIdHashDB authR uniq creds = do
muid <- maybeAuthId
case muid of
-- user already authenticated
Just uid -> return $ Just uid
Nothing -> do
x <- case uniq (credsIdent creds) of
Nothing -> return Nothing
Just u -> runDB (getBy u)
case x of
-- user exists
Just (Entity uid _) -> return $ Just uid
Nothing -> loginErrorMessage (authR LoginR) "User not found"
-- | Prompt for username and password, validate that against a database
-- which holds the username and a hash of the password
authHashDB :: ( YesodAuth m, YesodPersist m
, HashDBUser user
, PersistEntity user
, b ~ YesodPersistBackend m
, PersistMonadBackend (b (HandlerT m IO)) ~ PersistEntityBackend user
, PersistUnique (b (HandlerT m IO)))
=> (Text -> Maybe (Unique user)) -> AuthPlugin m
authHashDB uniq = AuthPlugin "hashdb" dispatch $ \tm -> toWidget [hamlet|
$newline never
<div id="header">
<h1>Login
<div id="login">
<form method="post" action="@{tm login}">
<table>
<tr>
<th>Username:
<td>
<input id="x" name="username" autofocus="" required>
<tr>
<th>Password:
<td>
<input type="password" name="password" required>
<tr>
<td>&nbsp;
<td>
<input type="submit" value="Login">
<script>
if (!("autofocus" in document.createElement("input"))) {
document.getElementById("x").focus();
}
|]
where
dispatch "POST" ["login"] = postLoginR uniq >>= sendResponse
dispatch _ _ = notFound
----------------------------------------------------------------
-- Predefined datatype
----------------------------------------------------------------
-- | Generate data base instances for a valid user
share [mkPersist sqlSettings, mkMigrate "migrateUsers"]
[persistUpperCase|
User
username Text Eq
password Text
salt Text
UniqueUser username
|]
instance HashDBUser (UserGeneric backend) where
userPasswordHash = Just . userPassword
userPasswordSalt = Just . userSalt
setSaltAndPasswordHash s h u = u { userSalt = s
, userPassword = h
}

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

@ -14,6 +14,7 @@ module Yesod.Auth.Message
, finnishMessage
, chineseMessage
, spanishMessage
, czechMessage
) where
import Data.Monoid (mappend)
@ -25,6 +26,7 @@ data AuthMessage =
| LoginGoogle
| LoginYahoo
| Email
| IdentifierNotFound Text
| Password
| Register
| RegisterLong
@ -101,6 +103,7 @@ englishMessage ProvideIdentifier = "Email or Username"
englishMessage SendPasswordResetEmail = "Send password reset email"
englishMessage PasswordResetPrompt = "Enter your e-mail address or username below, and a password reset e-mail will be sent to you."
englishMessage InvalidUsernamePass = "Invalid username/password combination"
englishMessage (IdentifierNotFound ident) = "Login not found: " `mappend` ident
portugueseMessage :: AuthMessage -> Text
portugueseMessage NoOpenID = "Nenhum identificador OpenID encontrado"
@ -142,6 +145,8 @@ portugueseMessage ProvideIdentifier = "E-mail ou nome de usuário"
portugueseMessage SendPasswordResetEmail = "Enviar e-mail para resetar senha"
portugueseMessage PasswordResetPrompt = "Insira seu endereço de e-mail ou nome de usuário abaixo. Um e-mail para resetar sua senha será enviado para você."
portugueseMessage InvalidUsernamePass = "Nome de usuário ou senha inválidos"
-- TODO
portugueseMessage i@(IdentifierNotFound _) = englishMessage i
spanishMessage :: AuthMessage -> Text
spanishMessage NoOpenID = "No se encuentra el identificador OpenID"
@ -183,6 +188,8 @@ spanishMessage ProvideIdentifier = "Cuenta de correo o nombre de usuario"
spanishMessage SendPasswordResetEmail = "Correo de actualización de contraseña enviado"
spanishMessage PasswordResetPrompt = "Escriba su cuenta de correo o nombre de usuario, y una confirmación de actualización de contraseña será enviada a su cuenta de correo."
spanishMessage InvalidUsernamePass = "Combinación de nombre de usuario/contraseña invalida"
-- TODO
spanishMessage i@(IdentifierNotFound _) = englishMessage i
swedishMessage :: AuthMessage -> Text
swedishMessage NoOpenID = "Fann ej OpenID identifierare"
@ -225,6 +232,8 @@ swedishMessage SendPasswordResetEmail = "Skicka email för återställning av l
swedishMessage PasswordResetPrompt = "Skriv in din emailadress eller användarnamn nedan och " `mappend`
"ett email för återställning av lösenord kommmer att skickas till dig."
swedishMessage InvalidUsernamePass = "Ogiltig kombination av användarnamn och lösenord"
-- TODO
swedishMessage i@(IdentifierNotFound _) = englishMessage i
germanMessage :: AuthMessage -> Text
germanMessage NoOpenID = "Kein OpenID-Identifier gefunden"
@ -266,6 +275,8 @@ germanMessage ProvideIdentifier = "Email-Adresse oder Nutzername"
germanMessage SendPasswordResetEmail = "Email zusenden um Passwort zurückzusetzen"
germanMessage PasswordResetPrompt = "Nach Einhabe der Email-Adresse oder des Nutzernamen wird eine Email zugesendet mit welcher das Passwort zurückgesetzt werden kann."
germanMessage InvalidUsernamePass = "Ungültige Kombination aus Nutzername und Passwort"
-- TODO
germanMessage i@(IdentifierNotFound _) = englishMessage i
frenchMessage :: AuthMessage -> Text
frenchMessage NoOpenID = "Aucun fournisseur OpenID n'a été trouvé"
@ -300,13 +311,14 @@ 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"
frenchMessage NoIdentifierProvided = "No email/username provided"
frenchMessage InvalidEmailAddress = "Invalid email address provided"
frenchMessage PasswordResetTitle = "Password Reset"
frenchMessage ProvideIdentifier = "Email or Username"
frenchMessage SendPasswordResetEmail = "Send password reset email"
frenchMessage PasswordResetPrompt = "Enter your e-mail address or username below, and a password reset e-mail will be sent to you."
frenchMessage InvalidUsernamePass = "Invalid username/password combination"
frenchMessage NoIdentifierProvided = "Adresse électronique/nom d'utilisateur non spécifié"
frenchMessage InvalidEmailAddress = "Adresse électronique spécifiée invalide"
frenchMessage PasswordResetTitle = "Réinitialisation de mot de passe"
frenchMessage ProvideIdentifier = "Adresse électronique ou nom d'utilisateur"
frenchMessage SendPasswordResetEmail = "Envoie d'un message électronique pour Réinitialisation le mot de passe"
frenchMessage PasswordResetPrompt = "Entrez votre adresse électronique ou votre nom d'utilisateur ci-dessous, et un message électronique de réinitialisation de mot de passe vous sera envoyé."
frenchMessage InvalidUsernamePass = "Le couble nom d'utilisateur/mot de passe invalide"
frenchMessage (IdentifierNotFound ident) = "Nom d'utilisateur introuvable: " `mappend` ident
norwegianBokmålMessage :: AuthMessage -> Text
norwegianBokmålMessage NoOpenID = "Ingen OpenID-identifiserer funnet"
@ -348,6 +360,8 @@ norwegianBokmålMessage ProvideIdentifier = "Email or Username"
norwegianBokmålMessage SendPasswordResetEmail = "Send password reset email"
norwegianBokmålMessage PasswordResetPrompt = "Enter your e-mail address or username below, and a password reset e-mail will be sent to you."
norwegianBokmålMessage InvalidUsernamePass = "Invalid username/password combination"
-- TODO
norwegianBokmålMessage i@(IdentifierNotFound _) = englishMessage i
japaneseMessage :: AuthMessage -> Text
japaneseMessage NoOpenID = "OpenID識別子がありません"
@ -389,6 +403,8 @@ japaneseMessage ProvideIdentifier = "Email or Username"
japaneseMessage SendPasswordResetEmail = "Send password reset email"
japaneseMessage PasswordResetPrompt = "Enter your e-mail address or username below, and a password reset e-mail will be sent to you."
japaneseMessage InvalidUsernamePass = "Invalid username/password combination"
japaneseMessage (IdentifierNotFound ident) =
"「" `mappend` ident `mappend` "」は正しくないログインので、または未入力の項目があります。"
finnishMessage :: AuthMessage -> Text
finnishMessage NoOpenID = "OpenID-tunnistetta ei löydy"
@ -431,6 +447,8 @@ finnishMessage ProvideIdentifier = "Sähköpostiosoite tai käyttäjänimi"
finnishMessage SendPasswordResetEmail = "Lähetä uusi salasana sähköpostitse"
finnishMessage PasswordResetPrompt = "Anna sähköpostiosoitteesi tai käyttäjätunnuksesi alla, niin lähetämme uuden salasanan sähköpostitse."
finnishMessage InvalidUsernamePass = "Virheellinen käyttäjänimi tai salasana."
-- TODO
finnishMessage i@(IdentifierNotFound _) = englishMessage i
chineseMessage :: AuthMessage -> Text
chineseMessage NoOpenID = "无效的OpenID"
@ -472,5 +490,46 @@ chineseMessage ProvideIdentifier = "邮箱或用户名"
chineseMessage SendPasswordResetEmail = "发送密码重置邮件"
chineseMessage PasswordResetPrompt = "输入你的邮箱地址或用户名，你将收到一封密码重置邮件。"
chineseMessage InvalidUsernamePass = "无效的用户名/密码组合"
-- TODO
chineseMessage i@(IdentifierNotFound _) = englishMessage i
czechMessage :: AuthMessage -> Text
czechMessage NoOpenID = "Nebyl nalezen identifikátor OpenID"
czechMessage LoginOpenID = "Přihlásit přes OpenID"
czechMessage LoginGoogle = "Přihlásit přes Google"
czechMessage LoginYahoo = "Přihlásit přes Yahoo"
czechMessage Email = "E-mail"
czechMessage Password = "Heslo"
czechMessage Register = "Registrovat"
czechMessage RegisterLong = "Zaregistrovat nový účet"
czechMessage EnterEmail = "Níže zadejte svou e-mailovou adresu a bude vám poslán potvrzovací e-mail."
czechMessage ConfirmationEmailSentTitle = "Potvrzovací e-mail odeslán"
czechMessage (ConfirmationEmailSent email) =
"Potvrzovací e-mail byl odeslán na " `mappend` email `mappend` "."
czechMessage AddressVerified = "Adresa byla ověřena, prosím nastavte si nové heslo"
czechMessage InvalidKeyTitle = "Neplatný ověřovací klíč"
czechMessage InvalidKey = "Bohužel, ověřovací klíč je neplatný."
czechMessage InvalidEmailPass = "Neplatná kombinace e-mail/heslo"
czechMessage BadSetPass = "Pro nastavení hesla je vyžadováno přihlášení"
czechMessage SetPassTitle = "Nastavit heslo"
czechMessage SetPass = "Nastavit nové heslo"
czechMessage NewPass = "Nové heslo"
czechMessage ConfirmPass = "Potvrdit"
czechMessage PassMismatch = "Hesla si neodpovídají, zkuste to znovu"
czechMessage PassUpdated = "Heslo aktualizováno"
czechMessage Facebook = "Přihlásit přes Facebook"
czechMessage LoginViaEmail = "Přihlásit přes e-mail"
czechMessage InvalidLogin = "Neplatné přihlášení"
czechMessage NowLoggedIn = "Přihlášení proběhlo úspěšně"
czechMessage LoginTitle = "Přihlásit"
czechMessage PleaseProvideUsername = "Prosím, zadejte svoje uživatelské jméno"
czechMessage PleaseProvidePassword = "Prosím, zadejte svoje heslo"
czechMessage NoIdentifierProvided = "Nebyl poskytnut žádný e-mail nebo uživatelské jméno"
czechMessage InvalidEmailAddress = "Zadaná e-mailová adresa je neplatná"
czechMessage PasswordResetTitle = "Obnovení hesla"
czechMessage ProvideIdentifier = "E-mail nebo uživatelské jméno"
czechMessage SendPasswordResetEmail = "Poslat e-mail pro obnovení hesla"
czechMessage PasswordResetPrompt = "Zadejte svou e-mailovou adresu nebo uživatelské jméno a bude vám poslán email pro obnovení hesla."
czechMessage InvalidUsernamePass = "Neplatná kombinace uživatelského jména a hesla"
-- TODO
czechMessage i@(IdentifierNotFound _) = englishMessage i

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

@ -69,8 +69,10 @@ $newline never
master <- lift getYesod
eres <- lift $ try $ OpenId.getForwardUrl oid complete' Nothing extensionFields (authHttpManager master)
case eres of
Left err -> loginErrorMessage LoginR $ T.pack $
show (err :: SomeException)
Left err -> do
tm <- getRouteToParent
lift $ loginErrorMessage (tm LoginR) $ T.pack $
show (err :: SomeException)
Right x -> redirect x
Nothing -> loginErrorMessageI LoginR Msg.NoOpenID
dispatch "GET" ["complete", ""] = dispatch "GET" ["complete"] -- compatibility issues
@ -83,14 +85,16 @@ $newline never
completeHelper idType posts
dispatch _ _ = notFound
completeHelper :: IdentifierType -> [(Text, Text)] -> AuthHandler master ()
completeHelper :: IdentifierType -> [(Text, Text)] -> AuthHandler master TypedContent
completeHelper idType gets' = do
master <- lift getYesod
eres <- try $ OpenId.authenticateClaimed gets' (authHttpManager master)
either onFailure onSuccess eres
where
onFailure err = loginErrorMessage LoginR $ T.pack $
show (err :: SomeException)
onFailure err = do
tm <- getRouteToParent
lift $ loginErrorMessage (tm LoginR) $ T.pack $
show (err :: SomeException)
onSuccess oir = do
let claimed =
case OpenId.oirClaimed oir of
@ -104,7 +108,7 @@ completeHelper idType gets' = do
case idType of
OPLocal -> OpenId.oirOpLocal oir
Claimed -> fromMaybe (OpenId.oirOpLocal oir) $ OpenId.oirClaimed oir
lift $ setCreds True $ Creds "openid" i gets''
lift $ setCredsRedirect $ Creds "openid" i gets''
-- | The main identifier provided by the OpenID authentication plugin is the
-- \"OP-local identifier\". There is also sometimes a \"claimed\" identifier

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

@ -48,7 +48,7 @@ $newline never
$ maybe id (\x -> (:) ("displayName", x))
(fmap pack $ getDisplayName $ map (unpack *** unpack) extra)
[]
lift $ setCreds True creds
lift $ setCredsRedirect creds
dispatch _ _ = notFound
-- | Get some form of a display name.

429
yesod-auth/Yesod/PasswordStore.hs Executable file
View File

@ -0,0 +1,429 @@
{-# LANGUAGE OverloadedStrings, BangPatterns #-}
{-# LANGUAGE CPP #-}
-- |
-- Module : Crypto.PasswordStore
-- Copyright : (c) Peter Scott, 2011
-- License : BSD-style
--
-- Maintainer : pjscott@iastate.edu
-- Stability : experimental
-- Portability : portable
--
-- Securely store hashed, salted passwords. If you need to store and verify
-- passwords, there are many wrong ways to do it, most of them all too
-- common. Some people store users' passwords in plain text. Then, when an
-- attacker manages to get their hands on this file, they have the passwords for
-- every user's account. One step up, but still wrong, is to simply hash all
-- passwords with SHA1 or something. This is vulnerable to rainbow table and
-- dictionary attacks. One step up from that is to hash the password along with
-- a unique salt value. This is vulnerable to dictionary attacks, since guessing
-- a password is very fast. The right thing to do is to use a slow hash
-- function, to add some small but significant delay, that will be negligible
-- for legitimate users but prohibitively expensive for someone trying to guess
-- passwords by brute force. That is what this library does. It iterates a
-- SHA256 hash, with a random salt, a few thousand times. This scheme is known
-- as PBKDF1, and is generally considered secure; there is nothing innovative
-- happening here.
--
-- The API here is very simple. What you store are called /password hashes/.
-- They are strings (technically, ByteStrings) that look like this:
--
-- > "sha256|14|jEWU94phx4QzNyH94Qp4CQ==|5GEw+jxP/4WLgzt9VS3Ee3nhqBlDsrKiB+rq7JfMckU="
--
-- Each password hash shows the algorithm, the strength (more on that later),
-- the salt, and the hashed-and-salted password. You store these on your server,
-- in a database, for when you need to verify a password. You make a password
-- hash with the 'makePassword' function. Here's an example:
--
-- > >>> makePassword "hunter2" 14
-- > "sha256|14|Zo4LdZGrv/HYNAUG3q8WcA==|zKjbHZoTpuPLp1lh6ATolWGIKjhXvY4TysuKvqtNFyk="
--
-- This will hash the password @\"hunter2\"@, with strength 12, which is a good
-- default value. The strength here determines how long the hashing will
-- take. When doing the hashing, we iterate the SHA256 hash function
-- @2^strength@ times, so increasing the strength by 1 makes the hashing take
-- twice as long. When computers get faster, you can bump up the strength a
-- little bit to compensate. You can strengthen existing password hashes with
-- the 'strengthenPassword' function. Note that 'makePassword' needs to generate
-- random numbers, so its return type is 'IO' 'ByteString'. If you want to avoid
-- the 'IO' monad, you can generate your own salt and pass it to
-- 'makePasswordSalt'.
--
-- Your strength value should not be less than 12, and 14 is a good default
-- value at the time of this writing, in 2013.
--
-- Once you've got your password hashes, the second big thing you need to do
-- with them is verify passwords against them. When a user gives you a password,
-- you compare it with a password hash using the 'verifyPassword' function:
--
-- > >>> verifyPassword "wrong guess" passwordHash
-- > False
-- > >>> verifyPassword "hunter2" passwordHash
-- > True
--
-- These two functions are really all you need. If you want to make existing
-- password hashes stronger, you can use 'strengthenPassword'. Just pass it an
-- existing password hash and a new strength value, and it will return a new
-- password hash with that strength value, which will match the same password as
-- the old password hash.
--
-- Note that, as of version 2.4, you can also use PBKDF2, and specify the exact
-- iteration count. This does not have a significant effect on security, but can
-- be handy for compatibility with other code.
module Yesod.PasswordStore (
-- * Algorithms
pbkdf1, -- :: ByteString -> Salt -> Int -> ByteString
pbkdf2, -- :: ByteString -> Salt -> Int -> ByteString
-- * Registering and verifying passwords
makePassword, -- :: ByteString -> Int -> IO ByteString
makePasswordWith, -- :: (ByteString -> Salt -> Int -> ByteString) ->
-- ByteString -> Int -> IO ByteString
makePasswordSalt, -- :: ByteString -> ByteString -> Int -> ByteString
makePasswordSaltWith, -- :: (ByteString -> Salt -> Int -> ByteString) ->
-- ByteString -> Salt -> Int -> ByteString
verifyPassword, -- :: ByteString -> ByteString -> Bool
verifyPasswordWith, -- :: (ByteString -> Salt -> Int -> ByteString) ->
-- (Int -> Int) -> ByteString -> ByteString -> Bool
-- * Updating password hash strength
strengthenPassword, -- :: ByteString -> Int -> ByteString
passwordStrength, -- :: ByteString -> Int
-- * Utilities
Salt,
isPasswordFormatValid, -- :: ByteString -> Bool
genSaltIO, -- :: IO Salt
genSaltRandom, -- :: (RandomGen b) => b -> (Salt, b)
makeSalt, -- :: ByteString -> Salt
exportSalt, -- :: Salt -> ByteString
importSalt -- :: ByteString -> Salt
) where
import qualified Crypto.Hash as CH
import qualified Crypto.Hash.SHA256 as H
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BL
import qualified Data.Binary as Binary
import Control.Monad
import Control.Monad.ST
import Data.Byteable (toBytes)
import Data.STRef
import Data.Bits
import Data.ByteString.Char8 (ByteString)
import Data.ByteString.Base64 (encode, decodeLenient)
import System.IO
import System.Random
import Data.Maybe
import qualified Control.Exception
---------------------
-- Cryptographic base
---------------------
-- | PBKDF1 key-derivation function. Takes a password, a 'Salt', and a number of
-- iterations. The number of iterations should be at least 1000, and probably
-- more. 5000 is a reasonable number, computing almost instantaneously. This
-- will give a 32-byte 'ByteString' as output. Both the salt and this 32-byte
-- key should be stored in the password file. When a user wishes to authenticate
-- a password, just pass it and the salt to this function, and see if the output
-- matches.
pbkdf1 :: ByteString -> Salt -> Int -> ByteString
pbkdf1 password (SaltBS salt) iter = hashRounds first_hash (iter + 1)
where first_hash = H.finalize $ H.init `H.update` password `H.update` salt
-- | Hash a 'ByteString' for a given number of rounds. The number of rounds is 0
-- or more. If the number of rounds specified is 0, the ByteString will be
-- returned unmodified.
hashRounds :: ByteString -> Int -> ByteString
hashRounds (!bs) 0 = bs
hashRounds bs rounds = hashRounds (H.hash bs) (rounds - 1)
-- | Computes the hmacSHA256 of the given message, with the given 'Salt'.
hmacSHA256 :: ByteString
-- ^ The secret (the salt)
-> ByteString
-- ^ The clear-text message
-> ByteString
-- ^ The encoded message
hmacSHA256 secret msg =
toBytes (CH.hmacGetDigest (CH.hmac secret msg) :: CH.Digest CH.SHA256)
-- | PBKDF2 key-derivation function.
-- For details see @http://tools.ietf.org/html/rfc2898@.
-- @32@ is the most common digest size for @SHA256@, and is
-- what the algorithm internally uses.
-- @HMAC+SHA256@ is used as @PRF@, because @HMAC+SHA1@ is considered too weak.
pbkdf2 :: ByteString -> Salt -> Int -> ByteString
pbkdf2 password (SaltBS salt) c =
let hLen = 32
dkLen = hLen in go hLen dkLen
where
go hLen dkLen | dkLen > (2^32 - 1) * hLen = error "Derived key too long."
| otherwise =
let !l = ceiling ((fromIntegral dkLen / fromIntegral hLen) :: Double)
!r = dkLen - (l - 1) * hLen
chunks = [f i | i <- [1 .. l]]
in (B.concat . init $ chunks) `B.append` B.take r (last chunks)
-- The @f@ function, as defined in the spec.
-- It calls 'u' under the hood.
f :: Int -> ByteString
f i = let !u1 = hmacSHA256 password (salt `B.append` int i)
-- Using the ST Monad, for maximum performance.
in runST $ do
u <- newSTRef u1
accum <- newSTRef u1
forM_ [2 .. c] $ \_ -> do
modifySTRef' u (hmacSHA256 password)
currentU <- readSTRef u
modifySTRef' accum (`xor'` currentU)
readSTRef accum
-- int(i), as defined in the spec.
int :: Int -> ByteString
int i = let str = BL.unpack . Binary.encode $ i
in BS.pack $ drop (length str - 4) str
-- | A convenience function to XOR two 'ByteString' together.
xor' :: ByteString -> ByteString -> ByteString
xor' !b1 !b2 = BS.pack $ BS.zipWith xor b1 b2
-- | Generate a 'Salt' from 128 bits of data from @\/dev\/urandom@, with the
-- system RNG as a fallback. This is the function used to generate salts by
-- 'makePassword'.
genSaltIO :: IO Salt
genSaltIO =
Control.Exception.catch genSaltDevURandom def
where
def :: IOError -> IO Salt
def _ = genSaltSysRandom
-- | Generate a 'Salt' from @\/dev\/urandom@.
genSaltDevURandom :: IO Salt
genSaltDevURandom = withFile "/dev/urandom" ReadMode $ \h -> do
rawSalt <- B.hGet h 16
return $ makeSalt rawSalt
-- | Generate a 'Salt' from 'System.Random'.
genSaltSysRandom :: IO Salt
genSaltSysRandom = randomChars >>= return . makeSalt . B.pack
where randomChars = sequence $ replicate 16 $ randomRIO ('\NUL', '\255')
-----------------------
-- Password hash format
-----------------------
-- Format: "sha256|strength|salt|hash", where strength is an unsigned int, salt
-- is a base64-encoded 16-byte random number, and hash is a base64-encoded hash
-- value.
-- | Try to parse a password hash.
readPwHash :: ByteString -> Maybe (Int, Salt, ByteString)
readPwHash pw | length broken /= 4
|| algorithm /= "sha256"
|| B.length hash /= 44 = Nothing
| otherwise = case B.readInt strBS of
Just (strength, _) -> Just (strength, SaltBS salt, hash)
Nothing -> Nothing
where broken = B.split '|' pw
[algorithm, strBS, salt, hash] = broken
-- | Encode a password hash, from a @(strength, salt, hash)@ tuple, where
-- strength is an 'Int', and both @salt@ and @hash@ are base64-encoded
-- 'ByteString's.
writePwHash :: (Int, Salt, ByteString) -> ByteString
writePwHash (strength, SaltBS salt, hash) =
B.intercalate "|" ["sha256", B.pack (show strength), salt, hash]
-----------------
-- High level API
-----------------
-- | Hash a password with a given strength (14 is a good default). The output of
-- this function can be written directly to a password file or
-- database. Generates a salt using high-quality randomness from
-- @\/dev\/urandom@ or (if that is not available, for example on Windows)
-- 'System.Random', which is included in the hashed output.
makePassword :: ByteString -> Int -> IO ByteString
makePassword = makePasswordWith pbkdf1
-- | A generic version of 'makePassword', which allow the user
-- to choose the algorithm to use.
--
-- >>> makePasswordWith pbkdf1 "password" 14
--
makePasswordWith :: (ByteString -> Salt -> Int -> ByteString)
-- ^ The algorithm to use (e.g. pbkdf1)
-> ByteString
-- ^ The password to encrypt
-> Int
-- ^ log2 of the number of iterations
-> IO ByteString
makePasswordWith algorithm password strength = do
salt <- genSaltIO
return $ makePasswordSaltWith algorithm (2^) password salt strength
-- | A generic version of 'makePasswordSalt', meant to give the user
-- the maximum control over the generation parameters.
-- Note that, unlike 'makePasswordWith', this function takes the @raw@
-- number of iterations. This means the user will need to specify a
-- sensible value, typically @10000@ or @20000@.
makePasswordSaltWith :: (ByteString -> Salt -> Int -> ByteString)
-- ^ A function modeling an algorithm (e.g. 'pbkdf1')
-> (Int -> Int)
-- ^ A function to modify the strength
-> ByteString
-- ^ A password, given as clear text
-> Salt
-- ^ A hash 'Salt'
-> Int
-- ^ The password strength (e.g. @10000, 20000, etc.@)
-> ByteString
makePasswordSaltWith algorithm strengthModifier pwd salt strength = writePwHash (strength, salt, hash)
where hash = encode $ algorithm pwd salt (strengthModifier strength)
-- | Hash a password with a given strength (14 is a good default), using a given
-- salt. The output of this function can be written directly to a password file
-- or database. Example:
--
-- > >>> makePasswordSalt "hunter2" (makeSalt "72cd18b5ebfe6e96") 14
-- > "sha256|14|NzJjZDE4YjVlYmZlNmU5Ng==|yuiNrZW3KHX+pd0sWy9NTTsy5Yopmtx4UYscItSsoxc="
makePasswordSalt :: ByteString -> Salt -> Int -> ByteString
makePasswordSalt = makePasswordSaltWith pbkdf1 (2^)
-- | 'verifyPasswordWith' @algorithm userInput pwHash@ verifies
-- the password @userInput@ given by the user against the stored password
-- hash @pwHash@, with the hashing algorithm @algorithm@. Returns 'True' if the
-- given password is correct, and 'False' if it is not.
-- This function allows the programmer to specify the algorithm to use,
-- e.g. 'pbkdf1' or 'pbkdf2'.
-- Note: If you want to verify a password previously generated with
-- 'makePasswordSaltWith', but without modifying the number of iterations,
-- you can do:
--
-- > >>> verifyPasswordWith pbkdf2 id "hunter2" "sha256..."
-- > True
--
verifyPasswordWith :: (ByteString -> Salt -> Int -> ByteString)
-- ^ A function modeling an algorithm (e.g. pbkdf1)
-> (Int -> Int)
-- ^ A function to modify the strength
-> ByteString
-- ^ User password
-> ByteString
-- ^ The generated hash (e.g. sha256|14...)
-> Bool
verifyPasswordWith algorithm strengthModifier userInput pwHash =
case readPwHash pwHash of
Nothing -> False
Just (strength, salt, goodHash) ->
encode (algorithm userInput salt (strengthModifier strength)) == goodHash
-- | Like 'verifyPasswordWith', but uses 'pbkdf1' as algorithm.
verifyPassword :: ByteString -> ByteString -> Bool
verifyPassword = verifyPasswordWith pbkdf1 (2^)
-- | Try to strengthen a password hash, by hashing it some more
-- times. @'strengthenPassword' pwHash new_strength@ will return a new password
-- hash with strength at least @new_strength@. If the password hash already has
-- strength greater than or equal to @new_strength@, then it is returned
-- unmodified. If the password hash is invalid and does not parse, it will be
-- returned without comment.
--
-- This function can be used to periodically update your password database when
-- computers get faster, in order to keep up with Moore's law. This isn't hugely
-- important, but it's a good idea.
strengthenPassword :: ByteString -> Int -> ByteString
strengthenPassword pwHash newstr =
case readPwHash pwHash of
Nothing -> pwHash
Just (oldstr, salt, hashB64) ->
if oldstr < newstr then
writePwHash (newstr, salt, newHash)
else
pwHash
where newHash = encode $ hashRounds hash extraRounds
extraRounds = (2^newstr) - (2^oldstr)
hash = decodeLenient hashB64
-- | Return the strength of a password hash.
passwordStrength :: ByteString -> Int
passwordStrength pwHash = case readPwHash pwHash of
Nothing -> 0
Just (strength, _, _) -> strength
------------
-- Utilities
------------
-- | A salt is a unique random value which is stored as part of the password
-- hash. You can generate a salt with 'genSaltIO' or 'genSaltRandom', or if you
-- really know what you're doing, you can create them from your own ByteString
-- values with 'makeSalt'.
newtype Salt = SaltBS ByteString
deriving (Show, Eq, Ord)
-- | Create a 'Salt' from a 'ByteString'. The input must be at least 8
-- characters, and can contain arbitrary bytes. Most users will not need to use
-- this function.
makeSalt :: ByteString -> Salt
makeSalt = SaltBS . encode . check_length
where check_length salt | B.length salt < 8 =
error "Salt too short. Minimum length is 8 characters."
| otherwise = salt
-- | Convert a 'Salt' into a 'ByteString'. The resulting 'ByteString' will be
-- base64-encoded. Most users will not need to use this function.
exportSalt :: Salt -> ByteString
exportSalt (SaltBS bs) = bs
-- | Convert a raw 'ByteString' into a 'Salt'.
-- Use this function with caution, since using a weak salt will result in a
-- weak password.
importSalt :: ByteString -> Salt
importSalt = SaltBS
-- | Is the format of a password hash valid? Attempts to parse a given password
-- hash. Returns 'True' if it parses correctly, and 'False' otherwise.
isPasswordFormatValid :: ByteString -> Bool
isPasswordFormatValid = isJust . readPwHash
-- | Generate a 'Salt' with 128 bits of data taken from a given random number
-- generator. Returns the salt and the updated random number generator. This is
-- meant to be used with 'makePasswordSalt' by people who would prefer to either
-- use their own random number generator or avoid the 'IO' monad.
genSaltRandom :: (RandomGen b) => b -> (Salt, b)
genSaltRandom gen = (salt, newgen)
where rands _ 0 = []
rands g n = (a, g') : rands g' (n-1 :: Int)
where (a, g') = randomR ('\NUL', '\255') g
salt = makeSalt $ B.pack $ map fst (rands gen 16)
newgen = snd $ last (rands gen 16)
#if !MIN_VERSION_base(4, 6, 0)
-- | Strict version of 'modifySTRef'
modifySTRef' :: STRef s a -> (a -> a) -> ST s ()
modifySTRef' ref f = do
x <- readSTRef ref
let x' = f x
x' `seq` writeSTRef ref x'
#endif
#if MIN_VERSION_bytestring(0, 10, 0)
toStrict :: BL.ByteString -> BS.ByteString
toStrict = BL.toStrict
fromStrict :: BS.ByteString -> BL.ByteString
fromStrict = BL.fromStrict
#else
toStrict :: BL.ByteString -> BS.ByteString
toStrict = BS.concat . BL.toChunks
fromStrict :: BS.ByteString -> BL.ByteString
fromStrict = BL.fromChunks . return
#endif

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

@ -1,5 +1,5 @@
name: yesod-auth
version: 1.2.1
version: 1.3.1.1
license: MIT
license-file: LICENSE
author: Michael Snoyman, Patrick Brisbin
@ -10,9 +10,14 @@ stability: Stable
cabal-version: >= 1.6.0
build-type: Simple
homepage: http://www.yesodweb.com/
description: This package provides a pluggable mechanism for allowing users to authenticate with your site. It comes with a number of common plugins, such as OpenID, BrowserID (a.k.a., Mozilla Persona), and email. Other packages are available from Hackage as well. If you've written such an add-on, please notify me so that it can be added to this description.
.
* <http://hackage.haskell.org/package/yesod-auth-account>: An account authentication plugin for Yesod
description:
This package provides a pluggable mechanism for allowing users to authenticate with your site. It comes with a number of common plugins, such as OpenID, BrowserID (a.k.a., Mozilla Persona), and email. Other packages are available from Hackage as well. If you've written such an add-on, please notify me so that it can be added to this description.
.
* <http://hackage.haskell.org/package/yesod-auth-account>: An account authentication plugin for Yesod
.
* <http://hackage.haskell.org/package/yesod-auth-hashdb>: The HashDB module previously packaged in yesod-auth, now with stronger, but compatible, security.
.
* <https://github.com/ollieh/yesod-auth-bcrypt/>: An alternative to the HashDB module.
extra-source-files: persona_sign_in_blue.png
library
@ -22,24 +27,24 @@ library
, yesod-core >= 1.2 && < 1.3
, wai >= 1.4
, template-haskell
, pureMD5 >= 2.0
, base16-bytestring
, cryptohash
, random >= 1.0.0.2
, text >= 0.7
, mime-mail >= 0.3
, yesod-persistent >= 1.2
, hamlet >= 1.1 && < 1.2
, shakespeare-css >= 1.0 && < 1.1
, shakespeare-js >= 1.0.2 && < 1.2
, hamlet >= 1.1
, shakespeare
, shakespeare-css >= 1.0
, shakespeare-js >= 1.0.2
, containers
, unordered-containers
, yesod-form >= 1.3 && < 1.4
, transformers >= 0.2.2
, persistent >= 1.2 && < 1.3
, persistent-template >= 1.2 && < 1.3
, SHA >= 1.4.1.3
, persistent >= 1.2 && < 1.4
, persistent-template >= 1.2 && < 1.4
, http-conduit >= 1.5
, aeson >= 0.5
, pwstore-fast >= 2.2
, lifted-base >= 0.1
, blaze-html >= 0.5
, blaze-markup >= 0.5.1
@ -51,6 +56,14 @@ library
, resourcet
, safe
, time
, base64-bytestring
, byteable
, binary
, http-client
, blaze-builder
, conduit
, conduit-extra
, attoparsec-conduit
exposed-modules: Yesod.Auth
Yesod.Auth.BrowserId
@ -58,10 +71,11 @@ library
Yesod.Auth.Email
Yesod.Auth.OpenId
Yesod.Auth.Rpxnow
Yesod.Auth.HashDB
Yesod.Auth.Message
Yesod.Auth.GoogleEmail
Yesod.Auth.GoogleEmail2
other-modules: Yesod.Auth.Routes
Yesod.PasswordStore
ghc-options: -Wall
source-repository head

2
yesod-bin/AddHandler.hs
View File

@ -106,7 +106,7 @@ mkHandler name pattern methods = unlines
getTypes "" = []
getTypes ('/':rest) = getTypes rest
getTypes ('#':rest) =
getTypes (c:rest) | c `elem` "#*" =
typ : getTypes rest'
where
(typ, rest') = break (== '/') rest

117
yesod-bin/Devel.hs
View File

@ -1,14 +1,14 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
module Devel
( devel
, DevelOpts(..)
, DevelTermOpt(..)
, defaultDevelOpts
) where
import Paths_yesod_bin
import qualified Distribution.Compiler as D
import qualified Distribution.ModuleName as D
import qualified Distribution.PackageDescription as D
@ -24,7 +24,7 @@ import Control.Concurrent.MVar (MVar, newEmptyMVar,
takeMVar, tryPutMVar)
import qualified Control.Exception as Ex
import Control.Monad (forever, unless, void,
when)
when, forM)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.State (evalStateT, get)
import qualified Data.IORef as I
@ -64,20 +64,26 @@ import GhcBuild (buildPackage,
getBuildFlags, getPackageArgs)
import qualified Config as GHC
import Data.Conduit.Network (HostPreference (HostIPv4),
bindPort)
import Data.Streaming.Network (bindPortTCP)
import Network (withSocketsDo)
#if MIN_VERSION_http_conduit(2, 0, 0)
import Network.HTTP.Conduit (conduitManagerSettings, newManager)
import Data.Default.Class (def)
#else
import Network.HTTP.Conduit (def, newManager)
#endif
import Network.HTTP.ReverseProxy (ProxyDest (ProxyDest),
waiProxyToSettings, wpsTimeout, wpsOnExc)
#if MIN_VERSION_http_reverse_proxy(0, 2, 0)
import qualified Network.HTTP.ReverseProxy as ReverseProxy
#endif
import Network.HTTP.Types (status200)
import Network.HTTP.Types (status200, status503)
import Network.Socket (sClose)
import Network.Wai (responseLBS)
import Network.Wai (responseLBS, requestHeaders)
import Network.Wai.Parse (parseHttpAccept)
import Network.Wai.Handler.Warp (run)
import SrcLoc (Located)
import Data.FileEmbed (embedFile)
lockFile :: DevelOpts -> FilePath
lockFile _opts = "yesod-devel/devel-terminate"
@ -94,6 +100,8 @@ removeLock opts = do
removeFileIfExists (lockFile opts)
removeFileIfExists "dist/devel-terminate" -- for compatibility with old devel.hs
data DevelTermOpt = TerminateOnEnter | TerminateOnlyInterrupt
deriving (Show, Eq)
data DevelOpts = DevelOpts
{ isCabalDev :: Bool
, forceCabal :: Bool
@ -105,13 +113,14 @@ data DevelOpts = DevelOpts
, develPort :: Int
, proxyTimeout :: Int
, useReverseProxy :: Bool
, terminateWith :: DevelTermOpt
} deriving (Show, Eq)
getBuildDir :: DevelOpts -> String
getBuildDir opts = fromMaybe "dist" (buildDir opts)
defaultDevelOpts :: DevelOpts
defaultDevelOpts = DevelOpts False False False (-1) Nothing Nothing Nothing 3000 10 True
defaultDevelOpts = DevelOpts False False False (-1) Nothing Nothing Nothing 3000 10 True TerminateOnEnter
cabalProgram :: DevelOpts -> FilePath
cabalProgram opts | isCabalDev opts = "cabal-dev"
@ -121,8 +130,26 @@ cabalProgram opts | isCabalDev opts = "cabal-dev"
-- 3001, give an appropriate message to the user.
reverseProxy :: DevelOpts -> I.IORef Int -> IO ()
reverseProxy opts iappPort = do
#if MIN_VERSION_http_conduit(2, 0, 0)
manager <- newManager conduitManagerSettings
#else
manager <- newManager def
let loop = forever $ do
#endif
let refreshHtml = LB.fromChunks $ return $(embedFile "refreshing.html")
let onExc _ req
| maybe False (("application/json" `elem`) . parseHttpAccept)
(lookup "accept" $ requestHeaders req) =
return $ responseLBS status503
[ ("Retry-After", "1")
]
"{\"message\":\"Recompiling\"}"
| otherwise = return $ responseLBS status200
[ ("content-type", "text/html")
, ("Refresh", "1")
]
refreshHtml
let runProxy =
run (develPort opts) $ waiProxyToSettings
(const $ do
appPort <- liftIO $ I.readIORef iappPort
@ -134,31 +161,28 @@ reverseProxy opts iappPort = do
#endif
$ ProxyDest "127.0.0.1" appPort)
def
#if MIN_VERSION_wai(3, 0, 0)
{ wpsOnExc = \e req f -> onExc e req >>= f
#else
{ wpsOnExc = onExc
#endif
, wpsTimeout =
if proxyTimeout opts == 0
then Nothing
else Just (1000000 * proxyTimeout opts)
}
manager
putStrLn "Reverse proxy stopped, but it shouldn't"
threadDelay 1000000
putStrLn "Restarting reverse proxy"
loop `Ex.onException` exitFailure
loop runProxy `Ex.onException` exitFailure
where
onExc _ _ = do
refreshing <- liftIO $ getDataFileName "refreshing.html"
html <- liftIO $ LB.readFile refreshing
return $ responseLBS
status200
[ ("content-type", "text/html")
, ("Refresh", "1")
]
html
loop proxy = forever $ do
void proxy
putStrLn "Reverse proxy stopped, but it shouldn't"
threadDelay 1000000
putStrLn "Restarting reverse proxy"
checkPort :: Int -> IO Bool
checkPort p = do
es <- Ex.try $ bindPort p HostIPv4
es <- Ex.try $ bindPortTCP p "*4"
case es of
Left (_ :: Ex.IOException) -> return False
Right s -> do
@ -174,21 +198,31 @@ getPort _ p0 =
avail <- checkPort p
if avail then return p else loop (succ p)
unlessM :: Monad m => m Bool -> m () -> m ()
unlessM c a = c >>= \res -> unless res a
devel :: DevelOpts -> [String] -> IO ()
devel opts passThroughArgs = withSocketsDo $ withManager $ \manager -> do
avail <- checkPort $ develPort opts
unless avail $ error "devel port unavailable"
unlessM (checkPort $ develPort opts) $ error "devel port unavailable"
iappPort <- getPort opts 17834 >>= I.newIORef
when (useReverseProxy opts) $ void $ forkIO $ reverseProxy opts iappPort
checkDevelFile
writeLock opts
putStrLn "Yesod devel server. Press ENTER to quit"
_ <- forkIO $ do
let (terminator, after) = case terminateWith opts of
TerminateOnEnter ->
("Press ENTER", void getLine)
TerminateOnlyInterrupt -> -- run for one year
("Interrupt", threadDelay $ 1000 * 1000 * 60 * 60 * 24 * 365)
putStrLn $ "Yesod devel server. " ++ terminator ++ " to quit"
void $ forkIO $ do
filesModified <- newEmptyMVar
watchTree manager "." (const True) (\_ -> void (tryPutMVar filesModified ()))
void $ forkIO $
void $ watchTree manager "." (const True) (\_ -> void (tryPutMVar filesModified ()))
evalStateT (mainOuterLoop iappPort filesModified) Map.empty
_ <- getLine
after
writeLock opts
exitSuccess
where
@ -247,7 +281,10 @@ devel opts passThroughArgs = withSocketsDo $ withManager $ \manager -> do
liftIO $ I.writeIORef iappPort appPort
(_,_,_,ph) <- liftIO $ createProcess (proc "runghc" devArgs)
{ env = Just $ ("PORT", show appPort) : ("DISPLAY_PORT", show $ develPort opts) : env0
{ env = Just $ Map.toList
$ Map.insert "PORT" (show appPort)
$ Map.insert "DISPLAY_PORT" (show $ develPort opts)
$ Map.fromList env0
}
derefMap <- get
watchTid <- liftIO . forkIO . try_ $ flip evalStateT derefMap $ do
@ -278,8 +315,8 @@ runBuildHook Nothing = return ()
-}
configure :: DevelOpts -> [String] -> IO Bool
configure opts extraArgs =
checkExit =<< (createProcess $ proc (cabalProgram opts)
([ "configure"
checkExit =<< createProcess (proc (cabalProgram opts) $
[ "configure"
, "-flibrary-only"
, "-fdevel"
, "--disable-library-profiling"
@ -287,7 +324,7 @@ configure opts extraArgs =
, "--with-ghc=yesod-ghc-wrapper"
, "--with-ar=yesod-ar-wrapper"
, "--with-hc-pkg=ghc-pkg"
] ++ extraArgs)
] ++ extraArgs
)
removeFileIfExists :: FilePath -> IO ()
@ -302,7 +339,7 @@ mkRebuild ghcVer cabalFile opts (ldPath, arPath)
| GHC.cProjectVersion /= ghcVer =
failWith "Yesod has been compiled with a different GHC version, please reinstall"
| forceCabal opts = return (rebuildCabal opts)
| otherwise = do
| otherwise =
return $ do
ns <- mapM (cabalFile `isNewerThan`)
[ "yesod-devel/ghcargs.txt", "yesod-devel/arargs.txt", "yesod-devel/ldargs.txt" ]
@ -327,7 +364,7 @@ rebuildCabal opts = do
| otherwise = [ "build", "-v0" ]
try_ :: forall a. IO a -> IO ()
try_ x = (Ex.try x :: IO (Either Ex.SomeException a)) >> return ()
try_ x = void (Ex.try x :: IO (Either Ex.SomeException a))
type FileList = Map.Map FilePath EpochTime
@ -335,7 +372,7 @@ getFileList :: [FilePath] -> [FilePath] -> IO FileList
getFileList hsSourceDirs extraFiles = do
(files, deps) <- getDeps hsSourceDirs
let files' = extraFiles ++ files ++ map fst (Map.toList deps)
fmap Map.fromList $ flip mapM files' $ \f -> do
fmap Map.fromList $ forM files' $ \f -> do
efs <- Ex.try $ getFileStatus f
return $ case efs of
Left (_ :: Ex.SomeException) -> (f, 0)
@ -389,7 +426,7 @@ failWith msg = do
exitFailure
checkFileList :: FileList -> D.Library -> [FilePath]
checkFileList fl lib = filter isUnlisted . filter isSrcFile $ sourceFiles
checkFileList fl lib = filter (not . isSetup) . filter isUnlisted . filter isSrcFile $ sourceFiles
where
al = allModules lib
-- a file is only a possible 'module file' if all path pieces start with a capital letter
@ -399,6 +436,12 @@ checkFileList fl lib = filter isUnlisted . filter isSrcFile $ sourceFiles
isUnlisted file = not (toModuleName file `Set.member` al)
toModuleName = L.intercalate "." . filter (/=".") . splitDirectories . dropExtension
isSetup "Setup.hs" = True
isSetup "./Setup.hs" = True
isSetup "Setup.lhs" = True
isSetup "./Setup.lhs" = True
isSetup _ = False
allModules :: D.Library -> Set.Set String
allModules lib = Set.fromList $ map toString $ D.exposedModules lib ++ (D.otherModules . D.libBuildInfo) lib
where

24
yesod-bin/GhcBuild.hs
View File

@ -39,10 +39,14 @@ import GHC.Paths (libdir)
import HscTypes (HscEnv (..), emptyHomePackageTable)
import qualified Module
import MonadUtils (liftIO)
import Panic (ghcError, panic)
import Panic (throwGhcException, panic)
import SrcLoc (Located, mkGeneralLocated)
import qualified StaticFlags
#if __GLASGOW_HASKELL__ >= 707
import DynFlags (ldInputs)
#else
import StaticFlags (v_Ld_inputs)
#endif
import System.FilePath (normalise, (</>))
import Util (consIORef, looksLikeModuleName)
@ -147,7 +151,9 @@ buildPackage' argv2 ld ar = do
haskellish (f,Nothing) =
looksLikeModuleName f || isHaskellSrcFilename f || '.' `notElem` f
haskellish (_,Just phase) =
#if MIN_VERSION_ghc(7,4,0)
#if MIN_VERSION_ghc(7,8,3)
phase `notElem` [As True, As False, Cc, Cobjc, Cobjcpp, CmmCpp, Cmm, StopLn]
#elif MIN_VERSION_ghc(7,4,0)
phase `notElem` [As, Cc, Cobjc, Cobjcpp, CmmCpp, Cmm, StopLn]
#else
phase `notElem` [As, Cc, CmmCpp, Cmm, StopLn]
@ -162,7 +168,15 @@ buildPackage' argv2 ld ar = do
o_files <- mapM (\x -> compileFile hsc_env StopLn x)
#endif
non_hs_srcs
#if __GLASGOW_HASKELL__ >= 707
let dflags4 = dflags3
{ ldInputs = map (DF.FileOption "") (reverse o_files)
++ ldInputs dflags3
}
GHC.setSessionDynFlags dflags4
#else
liftIO $ mapM_ (consIORef v_Ld_inputs) (reverse o_files)
#endif
targets <- mapM (uncurry GHC.guessTarget) hs_srcs
GHC.setTargets targets
ok_flag <- GHC.load GHC.LoadAllTargets
@ -234,7 +248,7 @@ parseModeFlags args = do
Nothing -> doMakeMode
Just (m, _) -> m
errs = errs1 ++ map (mkGeneralLocated "on the commandline") errs2
when (not (null errs)) $ ghcError $ errorsToGhcException errs
when (not (null errs)) $ throwGhcException $ errorsToGhcException errs
return (mode, flags' ++ leftover, warns)
type ModeM = CmdLineP (Maybe (Mode, String), [String], [Located String])
@ -289,7 +303,11 @@ mode_flags =
, Flag "E" (PassFlag (setMode (stopBeforeMode anyHsc)))
, Flag "C" (PassFlag (\f -> do setMode (stopBeforeMode HCc) f
addFlag "-fvia-C" f))
#if MIN_VERSION_ghc(7,8,3)
, Flag "S" (PassFlag (setMode (stopBeforeMode (As True))))
#else
, Flag "S" (PassFlag (setMode (stopBeforeMode As)))
#endif
, Flag "-make" (PassFlag (setMode doMakeMode))
, Flag "-interactive" (PassFlag (setMode doInteractiveMode))
, Flag "-abi-hash" (PassFlag (setMode doAbiHashMode))

38
yesod-bin/HsFile.hs Normal file
View File

@ -0,0 +1,38 @@
{-# LANGUAGE OverloadedStrings #-}
module HsFile (mkHsFile) where
import Text.ProjectTemplate (createTemplate)
import Data.Conduit
( ($$), (=$), ConduitM, awaitForever, yield, Source )
import Control.Monad.Trans.Resource (ResourceT, runResourceT)
import qualified Data.Conduit.List as CL
import Prelude hiding (FilePath)
import Filesystem.Path ( FilePath )
import Filesystem.Path.CurrentOS ( encodeString )
import qualified Filesystem as F
import qualified Data.ByteString as BS
import Control.Monad.IO.Class (liftIO)
traverse :: FilePath -> Source (ResourceT IO) FilePath
traverse dir = do
liftIO (F.listDirectory dir) >>= mapM_ go
where
go fp = do
isFile' <- liftIO $ F.isFile fp
if isFile'
then yield fp
else do
isDir <- liftIO $ F.isDirectory fp
if isDir
then traverse fp
else return ()
mkHsFile :: IO ()
mkHsFile = runResourceT $ traverse "."
$$ readIt
=$ createTemplate
=$ awaitForever (liftIO . BS.putStr)
-- Reads a filepath from upstream and dumps a pair of (filepath, filecontents)
readIt :: ConduitM FilePath (FilePath, ResourceT IO BS.ByteString) (ResourceT IO) ()
readIt = CL.map $ \i -> (i, liftIO $ BS.readFile $ encodeString i)

5
yesod-bin/Keter.hs
View File

@ -62,7 +62,10 @@ keter cabal noBuild = do
L.writeFile fp $ compress $ Tar.write archive
case Map.lookup "copy-to" value of
Just (String s) -> run "scp" [fp, T.unpack s]
Just (String s) ->
case parseMaybe (.: "copy-to-port") value of
Just i -> run "scp" ["-P" ++ show (i :: Int), fp, T.unpack s]
Nothing -> run "scp" [fp, T.unpack s]
_ -> return ()
try' :: IO a -> IO (Either SomeException a)

19
yesod-bin/Options.hs
View File

@ -11,7 +11,7 @@ import Data.Char (isAlphaNum, isSpace, toLower)
import Data.List (foldl')
import Data.List.Split (splitOn)
import qualified Data.Map as M
import Data.Maybe (catMaybes)
import Data.Maybe (mapMaybe)
import Data.Monoid
import Options.Applicative
import Options.Applicative.Types
@ -52,10 +52,10 @@ updateA env key upd a =
-- | really simple key/value file reader: x.y = z -> (["x","y"],"z")
configLines :: String -> [([String], String)]
configLines = catMaybes . map (mkLine . takeWhile (/='#')) . lines
configLines = mapMaybe (mkLine . takeWhile (/='#')) . lines
where
trim = let f = reverse . dropWhile isSpace in f . f
mkLine l | (k, ('=':v)) <- break (=='=') l = Just (splitOn "." (trim k), trim v)
mkLine l | (k, '=':v) <- break (=='=') l = Just (splitOn "." (trim k), trim v)
| otherwise = Nothing
-- | inject the environment into the parser
@ -71,16 +71,27 @@ injectDefaultP env path p@(OptP o)
in parseri { infoParser = injectDefaultP env (path ++ [normalizeName cmd]) (infoParser parseri) }
in OptP (Option (CmdReader cmds (`M.lookup` cmdMap)) props)
| (Option (OptReader names (CReader _ rdr) _) _) <- o =
p <|> either (const empty) pure (msum $ map (rdr <=< (maybe (Left $ ErrorMsg "Missing environment variable") Right . getEnvValue env path)) names)
p <|> either' (const empty) pure (msum $ map (rdr <=< (maybe (left $ ErrorMsg "Missing environment variable") right . getEnvValue env path)) names)
| (Option (FlagReader names a) _) <- o =
p <|> if any ((==Just "1") . getEnvValue env path) names then pure a else empty
| otherwise = p
where
#if MIN_VERSION_optparse_applicative(0,6,0)
right= ReadM . Right
left = ReadM . Left
either' f g (ReadM x) = either f g x
#else
right = Right
left = Left
either' = either
#endif
injectDefaultP env path (MultP p1 p2) =
MultP (injectDefaultP env path p1) (injectDefaultP env path p2)
injectDefaultP env path (AltP p1 p2) =
AltP (injectDefaultP env path p1) (injectDefaultP env path p2)
injectDefaultP _env _path b@(BindP {}) = b
getEnvValue :: M.Map [String] String -> [String] -> OptName -> Maybe String
getEnvValue env path (OptLong l) = M.lookup (path ++ [normalizeName l]) env
getEnvValue _ _ _ = Nothing

25
yesod-bin/Scaffolding/Scaffolder.hs
View File

@ -4,7 +4,8 @@ module Scaffolding.Scaffolder (scaffold) where
import Control.Arrow ((&&&))
import qualified Data.ByteString.Char8 as S
import Data.Conduit (runResourceT, yield, ($$), ($$+-))
import Data.Conduit (yield, ($$), ($$+-))
import Control.Monad.Trans.Resource (runResourceT)
import Data.FileEmbed (embedFile)
import Data.String (fromString)
import qualified Data.Text as T
@ -14,6 +15,9 @@ import Text.ProjectTemplate (unpackTemplate, receiveFS)
import System.IO
import Text.Shakespeare.Text (renderTextUrl, textFile)
import Network.HTTP.Conduit (withManager, http, parseUrl, responseBody)
import Data.Maybe (isJust)
import Distribution.Text (simpleParse)
import Distribution.Package (PackageName)
prompt :: (String -> Maybe a) -> IO a
prompt f = do
@ -58,20 +62,15 @@ backendBS Mysql = $(embedFile "hsfiles/mysql.hsfiles")
backendBS MongoDB = $(embedFile "hsfiles/mongo.hsfiles")
backendBS Simple = $(embedFile "hsfiles/simple.hsfiles")
-- | Is the character valid for a project name?
validPN :: Char -> Bool
validPN c
| 'A' <= c && c <= 'Z' = True
| 'a' <= c && c <= 'z' = True
| '0' <= c && c <= '9' = True
validPN '-' = True
validPN _ = False
validPackageName :: String -> Bool
validPackageName s = isJust (simpleParse s :: Maybe PackageName)
scaffold :: IO ()
scaffold = do
scaffold :: Bool -- ^ bare directory instead of a new subdirectory?
-> IO ()
scaffold isBare = do
puts $ renderTextUrl undefined $(textFile "input/welcome.cg")
project <- prompt $ \s ->
if all validPN s && not (null s) && s /= "test"
if validPackageName s && s /= "test"
then Just s
else Nothing
let dir = project
@ -90,7 +89,7 @@ scaffold = do
putStrLn "That's it! I'm creating your files now..."
let sink = unpackTemplate
(receiveFS $ fromString project)
(receiveFS $ if isBare then "." else fromString project)
(T.replace "PROJECTNAME" (T.pack project))
case ebackend of
Left req -> withManager $ \m -> do

6152
yesod-bin/hsfiles/mongo.hsfiles
View File

File diff suppressed because it is too large Load Diff

6149
yesod-bin/hsfiles/mysql.hsfiles
View File

File diff suppressed because it is too large Load Diff

6155
yesod-bin/hsfiles/postgres-fay.hsfiles
View File

File diff suppressed because it is too large Load Diff

6149
yesod-bin/hsfiles/postgres.hsfiles
View File

File diff suppressed because it is too large Load Diff

6136
yesod-bin/hsfiles/simple.hsfiles
View File

File diff suppressed because it is too large Load Diff

6149
yesod-bin/hsfiles/sqlite.hsfiles
View File

File diff suppressed because it is too large Load Diff

7
yesod-bin/input/done.cg
View File

@ -24,9 +24,4 @@ Take part in the community: http://yesodweb.com/page/community
Start your project:
cd PROJECTNAME && cabal install && yesod devel
or if you use cabal-dev:
cd PROJECTNAME && cabal-dev install && yesod --dev devel
cd PROJECTNAME && cabal sandbox init && cabal install --enable-tests . yesod-platform yesod-bin --max-backjumps=-1 --reorder-goals && yesod devel

92
yesod-bin/main.hs
View File

@ -1,5 +1,5 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE RecordWildCards #-}
import Control.Monad (unless)
import Data.Monoid
@ -9,14 +9,19 @@ import System.Exit (ExitCode (ExitSuccess), exitWith)
import System.Process (rawSystem)
import AddHandler (addHandler)
import Devel (DevelOpts (..), devel)
import Devel (DevelOpts (..), devel, DevelTermOpt(..))
import Keter (keter)
import Options (injectDefaults)
import qualified Paths_yesod_bin
import Scaffolding.Scaffolder
#if MIN_VERSION_optparse_applicative(0,6,0)
import Options.Applicative.Types (ReadM (ReadM))
#else
import Options.Applicative.Builder.Internal (Mod, OptionFields)
#endif
import HsFile (mkHsFile)
#ifndef WINDOWS
import Build (touch)
@ -42,7 +47,8 @@ data Options = Options
}
deriving (Show, Eq)
data Command = Init
data Command = Init { _initBare :: Bool }
| HsFiles
| Configure
| Build { buildExtraArgs :: [String] }
| Touch
@ -56,6 +62,7 @@ data Command = Init
, _develPort :: Int
, _proxyTimeout :: Int
, _noReverseProxy :: Bool
, _interruptOnly :: Bool
}
| Test
| AddHandler
@ -71,36 +78,46 @@ cabalCommand mopt
main :: IO ()
main = do
o <- execParser =<< injectDefaults "yesod" [ ("yesod.devel.extracabalarg" , \o args -> o { optCommand =
case optCommand o of
d@Devel{} -> d { develExtraArgs = args }
c -> c
})
, ("yesod.devel.ignore" , \o args -> o { optCommand =
case optCommand o of
d@Devel{} -> d { develIgnore = args }
c -> c
})
, ("yesod.build.extracabalarg" , \o args -> o { optCommand =
case optCommand o of
b@Build{} -> b { buildExtraArgs = args }
c -> c
})
] optParser'
let cabal xs = rawSystem' (cabalCommand o) xs
o <- execParser =<< injectDefaults "yesod"
[ ("yesod.devel.extracabalarg" , \o args -> o { optCommand =
case optCommand o of
d@Devel{} -> d { develExtraArgs = args }
c -> c
})
, ("yesod.devel.ignore" , \o args -> o { optCommand =
case optCommand o of
d@Devel{} -> d { develIgnore = args }
c -> c
})
, ("yesod.build.extracabalarg" , \o args -> o { optCommand =
case optCommand o of
b@Build{} -> b { buildExtraArgs = args }
c -> c
})
] optParser'
let cabal = rawSystem' (cabalCommand o)
case optCommand o of
Init -> scaffold
Configure -> cabal ["configure"]
Build es -> touch' >> cabal ("build":es)
Touch -> touch'
Devel da s f r b _ig es p t nrp -> devel (DevelOpts (optCabalPgm o == CabalDev) da (optVerbose o) r s f b p t (not nrp)) es
Keter noRebuild -> keter (cabalCommand o) noRebuild
Version -> do putStrLn ("yesod-bin version: " ++ showVersion Paths_yesod_bin.version)
AddHandler -> addHandler
Test -> do touch'
cabal ["configure", "--enable-tests", "-flibrary-only"]
cabal ["build"]
cabal ["test"]
Init bare -> scaffold bare
HsFiles -> mkHsFile
Configure -> cabal ["configure"]
Build es -> touch' >> cabal ("build":es)
Touch -> touch'
Keter noRebuild -> keter (cabalCommand o) noRebuild
Version -> putStrLn ("yesod-bin version: " ++ showVersion Paths_yesod_bin.version)
AddHandler -> addHandler
Test -> cabalTest cabal
Devel{..} -> devel (DevelOpts
(optCabalPgm o == CabalDev) _develDisableApi (optVerbose o)
_develRescan _develSuccessHook _develFailHook
_develBuildDir _develPort _proxyTimeout
(not _noReverseProxy)
(if _interruptOnly then TerminateOnlyInterrupt else TerminateOnEnter )
) develExtraArgs
where
cabalTest cabal = do touch'
_ <- cabal ["configure", "--enable-tests", "-flibrary-only"]
_ <- cabal ["build"]
cabal ["test"]
optParser' :: ParserInfo Options
optParser' = info (helper <*> optParser) ( fullDesc <> header "Yesod Web Framework command line utility" )
@ -109,8 +126,11 @@ optParser :: Parser Options
optParser = Options
<$> flag Cabal CabalDev ( long "dev" <> short 'd' <> help "use cabal-dev" )
<*> switch ( long "verbose" <> short 'v' <> help "More verbose output" )
<*> subparser ( command "init" (info (pure Init)
<*> subparser ( command "init"
(info (Init <$> (switch (long "bare" <> help "Create files in current folder")))
(progDesc "Scaffold a new site"))
<> command "hsfiles" (info (pure HsFiles)
(progDesc "Create a hsfiles file for the current folder"))
<> command "configure" (info (pure Configure)
(progDesc "Configure a project for building"))
<> command "build" (info (Build <$> extraCabalArgs)
@ -153,6 +173,8 @@ develOptions = Devel <$> switch ( long "disable-api" <> short 'd'
<> help "Devel server timeout before returning 'not ready' message (in seconds, 0 for none)" )
<*> switch ( long "disable-reverse-proxy" <> short 'n'
<> help "Disable reverse proxy" )
<*> switch ( long "interrupt-only" <> short 'c'
<> help "Disable exiting when enter is pressed")
extraCabalArgs :: Parser [String]
extraCabalArgs = many (strOption ( long "extra-cabal-arg" <> short 'e' <> metavar "ARG"
@ -164,7 +186,11 @@ optStr :: Mod OptionFields (Maybe String) -> Parser (Maybe String)
optStr m =
nullOption $ value Nothing <> reader (success . str) <> m
where
#if MIN_VERSION_optparse_applicative(0,6,0)
success = ReadM . Right
#else
success = Right
#endif
-- | Like @rawSystem@, but exits if it receives a non-success result.
rawSystem' :: String -> [String] -> IO ()

18
yesod-bin/refreshing.html
View File

@ -58,7 +58,8 @@
<h1>The application isn’t built</h1>
<h2>We’ll keep trying to refresh every second</h2>
<div class="msgs">
<p>Meanwhile, here are some motivational messages:</p>
<script> document.getElementsByClassName("msgs")[0].style.display = "none"; </script>
<p>Meanwhile, here is a motivational message:</p>
<ul>
<li>You are a beautiful person making a beautiful web site.</li>
<li>Keep going, you’ve nearly fixed the bug!</li>
@ -66,7 +67,20 @@
<li>Get a glass of water, keep hydrated.</li>
</ul>
</div>
<footer><small><script>document.write(new Date())</script></small></footer>
<script>
var msg = document.getElementsByClassName("msgs")[0];
var lis = Array.prototype.slice.call(msg.querySelectorAll("li"));
lis.forEach(function(li){ li.style.display = "none"; });
lis[Math.floor(Math.random() * lis.length)].style.display = "block";
msg.style.display = "block";
</script>
<footer>
<small>
<script>
document.write(new Date())
</script>
</small>
</footer>
</div>
</body>
</html>

28
yesod-bin/yesod-bin.cabal
View File

@ -1,5 +1,5 @@
name: yesod-bin
version: 1.2.2
version: 1.2.11
license: MIT
license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com>
@ -34,6 +34,7 @@ executable yesod-ld-wrapper
build-depends:
base >= 4 && < 5
, Cabal
executable yesod-ar-wrapper
main-is: ghcwrapper.hs
cpp-options: -DARCMD
@ -44,15 +45,17 @@ executable yesod-ar-wrapper
executable yesod
if os(windows)
cpp-options: -DWINDOWS
build-depends: base >= 4.3 && < 5
, ghc >= 7.0.3 && < 7.8
, ghc >= 7.0.3
, ghc-paths >= 0.1
, parsec >= 2.1 && < 4
, text >= 0.11
, shakespeare-text >= 1.0 && < 1.1
, shakespeare >= 1.0.2 && < 1.1
, shakespeare-js >= 1.0.2 && < 1.2
, shakespeare-css >= 1.0.2 && < 1.1
, shakespeare
, shakespeare-text >= 1.0
, shakespeare >= 1.0.2 && < 2.1
, shakespeare-js >= 1.0.2
, shakespeare-css >= 1.0.2
, bytestring >= 0.9.1.4
, time >= 1.1.4
, template-haskell
@ -72,11 +75,12 @@ executable yesod
, unordered-containers
, yaml >= 0.8 && < 0.9
, optparse-applicative >= 0.5
, fsnotify >= 0.0 && < 0.1
, fsnotify >= 0.0 && < 0.2
, split >= 0.2 && < 0.3
, file-embed
, conduit >= 0.5 && < 1.1
, resourcet >= 0.3 && < 0.5
, conduit >= 0.5 && < 1.2
, conduit-extra
, resourcet >= 0.3 && < 1.2
, base64-bytestring
, lifted-base
, http-reverse-proxy >= 0.1.1
@ -87,8 +91,11 @@ executable yesod
, transformers
, warp >= 1.3.7.5
, wai >= 1.4
, wai-extra
, data-default-class
, streaming-commons
ghc-options: -Wall -threaded
ghc-options: -Wall -threaded -rtsopts
main-is: main.hs
other-modules: Scaffolding.Scaffolder
Devel
@ -98,6 +105,7 @@ executable yesod
AddHandler
Paths_yesod_bin
Options
HsFile
source-repository head
type: git

2
yesod-core/README
View File

@ -1 +1 @@
Learn more at http://docs.yesodweb.com/
Learn more at http://www.yesodweb.com/

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

@ -24,6 +24,8 @@ module Yesod.Core
, widgetToPageContent
-- * Defaults
, defaultErrorHandler
, defaultYesodMiddleware
, authorizationCheck
-- * Data types
, AuthResult (..)
, unauthorizedI

6
yesod-core/Yesod/Core/Class/Handler.hs
View File

@ -41,7 +41,7 @@ replaceToParent hd = hd { handlerToParent = const () }
instance MonadResourceBase m => MonadHandler (HandlerT site m) where
type HandlerSite (HandlerT site m) = site
liftHandlerT (HandlerT f) = HandlerT $ liftIO . f . replaceToParent
{-# RULES "liftHandlerT (HandlerT site IO)" forall action. liftHandlerT action = id #-}
{-# RULES "liftHandlerT (HandlerT site IO)" liftHandlerT = id #-}
instance MonadResourceBase m => MonadHandler (WidgetT site m) where
type HandlerSite (WidgetT site m) = site
@ -61,7 +61,9 @@ GOX(Monoid w, RWST r w s)
GOX(Monoid w, Strict.RWST r w s)
GO(Strict.StateT s)
GOX(Monoid w, Strict.WriterT w)
#if !MIN_VERSION_resourcet(1,1,0)
GO(ExceptionT)
#endif
GO(Pipe l i o u)
GO(ConduitM i o)
#undef GO
@ -85,7 +87,9 @@ GOX(Monoid w, RWST r w s)
GOX(Monoid w, Strict.RWST r w s)
GO(Strict.StateT s)
GOX(Monoid w, Strict.WriterT w)
#if !MIN_VERSION_resourcet(1,1,0)
GO(ExceptionT)
#endif
GO(Pipe l i o u)
GO(ConduitM i o)
#undef GO

48
yesod-core/Yesod/Core/Class/Yesod.hs
View File

@ -2,6 +2,7 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE CPP #-}
module Yesod.Core.Class.Yesod where
import Control.Monad.Logger (logErrorS)
@ -39,10 +40,16 @@ import Data.Default (def)
import Network.Wai.Parse (lbsBackEnd,
tempFileBackEnd)
import System.IO (stdout)
#if MIN_VERSION_fast_logger(2, 0, 0)
import Network.Wai.Logger (ZonedDate, clockDateCacher)
import System.Log.FastLogger
import qualified GHC.IO.FD
#else
import System.Log.FastLogger.Date (ZonedDate)
import System.Log.FastLogger (LogStr (..), Logger,
loggerDate, loggerPutStr,
mkLogger)
import System.Log.FastLogger.Date (ZonedDate)
#endif
import Text.Blaze (customAttribute, textTag,
toValue, (!))
import Text.Blaze (preEscapedToMarkup)
@ -209,7 +216,18 @@ class RenderRoute site => Yesod site where
--
-- Default: Sends to stdout and automatically flushes on each write.
makeLogger :: site -> IO Logger
#if MIN_VERSION_fast_logger(2, 0, 0)
makeLogger _ = do
#if MIN_VERSION_fast_logger(2, 1, 0)
loggerSet <- newLoggerSet defaultBufSize Nothing
#else
loggerSet <- newLoggerSet defaultBufSize GHC.IO.FD.stdout
#endif
(getter, _) <- clockDateCacher
return $! Logger loggerSet getter
#else
makeLogger _ = mkLogger True stdout
#endif
-- | Send a message to the @Logger@ provided by @getLogger@.
--
@ -498,7 +516,7 @@ defaultErrorHandler (BadMethod m) = selectRep $ do
<h1>Method Not Supported
<p>Method <code>#{S8.unpack m}</code> not supported
|]
provideRep $ return $ object ["message" .= ("Bad method" :: Text), "method" .= m]
provideRep $ return $ object ["message" .= ("Bad method" :: Text), "method" .= TE.decodeUtf8With TEE.lenientDecode m]
asyncHelper :: (url -> [x] -> Text)
-> [Script (url)]
@ -523,6 +541,30 @@ asyncHelper render scripts jscript jsLoc =
Nothing -> Nothing
Just j -> Just $ jelper j
#if MIN_VERSION_fast_logger(2, 0, 0)
formatLogMessage :: IO ZonedDate
-> Loc
-> LogSource
-> LogLevel
-> LogStr -- ^ message
-> IO LogStr
formatLogMessage getdate loc src level msg = do
now <- getdate
return $
toLogStr now `mappend`
" [" `mappend`
(case level of
LevelOther t -> toLogStr t
_ -> toLogStr $ drop 5 $ show level) `mappend`
(if T.null src
then mempty
else "#" `mappend` toLogStr src) `mappend`
"] " `mappend`
msg `mappend`
" @(" `mappend`
toLogStr (fileLocationToString loc) `mappend`
")\n"
#else
formatLogMessage :: IO ZonedDate
-> Loc
-> LogSource
@ -548,7 +590,7 @@ formatLogMessage getdate loc src level msg = do
, LS $ fileLocationToString loc
, LB ")\n"
]
#endif
-- | Customize the cookies used by the session backend. You may
-- use this function on your definition of 'makeSessionBackend'.

21
yesod-core/Yesod/Core/Content.hs
View File

@ -60,7 +60,8 @@ import Data.Monoid (mempty)
import Text.Hamlet (Html)
import Text.Blaze.Html.Renderer.Utf8 (renderHtmlBuilder)
import Data.Conduit (Source, ResourceT, Flush (Chunk), ResumableSource, mapOutput)
import Data.Conduit (Source, Flush (Chunk), ResumableSource, mapOutput)
import Control.Monad.Trans.Resource (ResourceT)
import Data.Conduit.Internal (ResumableSource (ResumableSource))
import qualified Data.Aeson as J
@ -68,6 +69,8 @@ import Data.Aeson.Encode (fromValue)
import qualified Blaze.ByteString.Builder.Char.Utf8 as Blaze
import Data.Text.Lazy.Builder (toLazyText)
import Yesod.Core.Types
import Text.Lucius (Css, renderCss)
import Text.Julius (Javascript, unJavascript)
-- | Zero-length enumerator.
emptyContent :: Content
@ -107,6 +110,11 @@ instance ToContent (ContentType, Content) where
instance ToContent TypedContent where
toContent (TypedContent _ c) = c
instance ToContent Css where
toContent = toContent . renderCss
instance ToContent Javascript where
toContent = toContent . toLazyText . unJavascript
instance ToFlushBuilder builder => ToContent (Source (ResourceT IO) builder) where
toContent src = ContentSource $ mapOutput toFlushBuilder src
instance ToFlushBuilder builder => ToContent (ResumableSource (ResourceT IO) builder) where
@ -244,6 +252,12 @@ instance HasContentType Text where
instance HasContentType T.Text where
getContentType _ = typePlain
instance HasContentType Css where
getContentType _ = typeCss
instance HasContentType Javascript where
getContentType _ = typeJavascript
-- | Any type which can be converted to 'TypedContent'.
--
-- Since 1.2.0
@ -276,3 +290,8 @@ instance ToTypedContent a => ToTypedContent (DontFullyEvaluate a) where
toTypedContent (DontFullyEvaluate a) =
let TypedContent ct c = toTypedContent a
in TypedContent ct (ContentDontEvaluate c)
instance ToTypedContent Css where
toTypedContent = TypedContent typeCss . toContent
instance ToTypedContent Javascript where
toTypedContent = TypedContent typeJavascript . toContent

72
yesod-core/Yesod/Core/Dispatch.hs
View File

@ -3,6 +3,7 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE CPP #-}
module Yesod.Core.Dispatch
( -- * Quasi-quoted routing
parseRoutes
@ -26,6 +27,7 @@ module Yesod.Core.Dispatch
, warpDebug
, warpEnv
, mkDefaultMiddlewares
, defaultMiddlewaresNoLogging
-- * WAI subsites
, WaiSubsite (..)
) where
@ -40,7 +42,7 @@ import qualified Network.Wai as W
import Data.ByteString.Lazy.Char8 ()
import Data.Text (Text)
import Data.Text (Text, pack)
import Data.Monoid (mappend)
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
@ -63,6 +65,7 @@ import Network.Wai.Middleware.MethodOverride
import qualified Network.Wai.Handler.Warp
import System.Log.FastLogger
import Control.Monad.Logger
import Control.Monad (when)
import qualified Paths_yesod_core
import Data.Version (showVersion)
@ -89,8 +92,13 @@ toWaiAppYre yre req =
where
site = yreSite yre
sendRedirect :: Yesod master => master -> [Text] -> W.Application
#if MIN_VERSION_wai(3, 0, 0)
sendRedirect y segments' env sendResponse =
sendResponse $ W.responseLBS status301
#else
sendRedirect y segments' env =
return $ W.responseLBS status301
#endif
[ ("Content-Type", "text/plain")
, ("Location", Blaze.ByteString.Builder.toByteString dest')
] "Redirecting"
@ -117,6 +125,10 @@ toWaiAppYre yre req =
toWaiApp :: YesodDispatch site => site -> IO W.Application
toWaiApp site = do
logger <- makeLogger site
toWaiAppLogger logger site
toWaiAppLogger :: YesodDispatch site => Logger -> site -> IO W.Application
toWaiAppLogger logger site = do
sb <- makeSessionBackend site
let yre = YesodRunnerEnv
{ yreLogger = logger
@ -143,17 +155,37 @@ toWaiApp site = do
--
-- Since 1.2.0
warp :: YesodDispatch site => Int -> site -> IO ()
warp port site = toWaiApp site >>= Network.Wai.Handler.Warp.runSettings
Network.Wai.Handler.Warp.defaultSettings
{ Network.Wai.Handler.Warp.settingsPort = port
, Network.Wai.Handler.Warp.settingsServerName = S8.pack $ concat
[ "Warp/"
, Network.Wai.Handler.Warp.warpVersion
, " + Yesod/"
, showVersion Paths_yesod_core.version
, " (core)"
]
}
warp port site = do
logger <- makeLogger site
toWaiAppLogger logger site >>= Network.Wai.Handler.Warp.runSettings
Network.Wai.Handler.Warp.defaultSettings
{ Network.Wai.Handler.Warp.settingsPort = port
{- FIXME
, Network.Wai.Handler.Warp.settingsServerName = S8.pack $ concat
[ "Warp/"
, Network.Wai.Handler.Warp.warpVersion
, " + Yesod/"
, showVersion Paths_yesod_core.version
, " (core)"
]
-}
, Network.Wai.Handler.Warp.settingsOnException = const $ \e ->
when (shouldLog' e) $
messageLoggerSource
site
logger
$(qLocation >>= liftLoc)
"yesod-core"
LevelError
(toLogStr $ "Exception from Warp: " ++ show e)
}
where
shouldLog' =
#if MIN_VERSION_warp(2,1,3)
Network.Wai.Handler.Warp.defaultShouldDisplayException
#else
const True
#endif
-- | A default set of middlewares.
--
@ -161,14 +193,20 @@ warp port site = toWaiApp site >>= Network.Wai.Handler.Warp.runSettings
mkDefaultMiddlewares :: Logger -> IO W.Middleware
mkDefaultMiddlewares logger = do
logWare <- mkRequestLogger def
#if MIN_VERSION_fast_logger(2, 0, 0)
{ destination = Network.Wai.Middleware.RequestLogger.Logger $ loggerSet logger
#else
{ destination = Logger logger
#endif
, outputFormat = Apache FromSocket
}
return $ logWare
. acceptOverride
. autohead
. gzip def
. methodOverride
return $ logWare . defaultMiddlewaresNoLogging
-- | All of the default middlewares, excluding logging.
--
-- Since 1.2.12
defaultMiddlewaresNoLogging :: W.Middleware
defaultMiddlewaresNoLogging = acceptOverride . autohead . gzip def . methodOverride
-- | Deprecated synonym for 'warp'.
warpDebug :: YesodDispatch site => Int -> site -> IO ()

197
yesod-core/Yesod/Core/Handler.hs
View File

@ -1,3 +1,4 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleInstances #-}
@ -8,6 +9,7 @@
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE DeriveDataTypeable #-}
---------------------------------------------------------
--
-- Module : Yesod.Handler
@ -73,6 +75,7 @@ module Yesod.Core.Handler
, redirect
, redirectWith
, redirectToPost
, Fragment(..)
-- ** Errors
, notFound
, badMethod
@ -88,6 +91,13 @@ module Yesod.Core.Handler
, sendResponseStatus
, sendResponseCreated
, sendWaiResponse
, sendWaiApplication
#if MIN_VERSION_wai(2, 1, 0)
, sendRawResponse
#endif
#if MIN_VERSION_wai(3, 0, 0)
, sendRawResponseNoConduit
#endif
-- * Different representations
-- $representations
, selectRep
@ -133,6 +143,7 @@ module Yesod.Core.Handler
, newIdent
-- * Lifting
, handlerToIO
, forkHandler
-- * i18n
, getMessageRender
-- * Per-request caching
@ -145,18 +156,17 @@ import Yesod.Core.Internal.Request (langKey, mkFileInfoFile,
mkFileInfoLBS, mkFileInfoSource)
import Control.Applicative ((<$>), (<|>))
import Control.Exception (evaluate)
import Control.Exception (evaluate, SomeException)
import Control.Exception.Lifted (handle)
import Control.Monad (liftM)
import Control.Monad (liftM, void)
import qualified Control.Monad.Trans.Writer as Writer
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Trans.Resource (MonadResource, liftResourceT)
import qualified Network.HTTP.Types as H
import qualified Network.Wai as W
import Control.Monad.Trans.Class (lift)
import Data.Conduit (transPipe, Flush (Flush), yield, Producer)
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8With, encodeUtf8)
@ -169,10 +179,8 @@ import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L
import qualified Data.Map as Map
import Data.Conduit (Source)
import Control.Arrow ((***))
import qualified Data.ByteString.Char8 as S8
import Data.Maybe (mapMaybe)
import Data.Monoid (Endo (..), mappend, mempty)
import Data.Text (Text)
import qualified Network.Wai.Parse as NWP
@ -182,18 +190,37 @@ import Yesod.Core.Content (ToTypedContent (..), simpleConte
import Yesod.Core.Internal.Util (formatRFC1123)
import Text.Blaze.Html (preEscapedToMarkup, toHtml)
import Control.Monad.Trans.Resource (ResourceT, runResourceT, withInternalState)
import Data.Dynamic (fromDynamic, toDyn)
import qualified Data.IORef.Lifted as I
import Data.Maybe (listToMaybe)
import Data.Maybe (listToMaybe, mapMaybe)
import Data.Typeable (Typeable, typeOf)
import Web.PathPieces (PathPiece(..))
import Yesod.Core.Class.Handler
import Yesod.Core.Types
import Yesod.Routes.Class (Route)
import Control.Failure (failure)
import Control.Exception (throwIO)
import Blaze.ByteString.Builder (Builder)
import Safe (headMay)
import Data.CaseInsensitive (CI)
import qualified Data.Conduit.List as CL
import Control.Monad (unless)
import Control.Monad.Trans.Resource (MonadResource, InternalState, runResourceT, withInternalState, getInternalState, liftResourceT, resourceForkIO
#if MIN_VERSION_wai(2, 0, 0)
#else
, ResourceT
#endif
)
#if MIN_VERSION_wai(2, 0, 0)
import qualified System.PosixCompat.Files as PC
#endif
#if MIN_VERSION_wai(2, 1, 0)
import Control.Monad.Trans.Control (control, MonadBaseControl)
#endif
import Data.Conduit (Source, transPipe, Flush (Flush), yield, Producer
#if MIN_VERSION_wai(2, 1, 0)
, Sink
#endif
)
get :: MonadHandler m => m GHState
get = liftHandlerT $ HandlerT $ I.readIORef . handlerState
@ -208,7 +235,7 @@ tell :: MonadHandler m => Endo [Header] -> m ()
tell hs = modify $ \g -> g { ghsHeaders = ghsHeaders g `mappend` hs }
handlerError :: MonadHandler m => HandlerContents -> m a
handlerError = liftHandlerT . failure
handlerError = liftIO . throwIO
hcError :: MonadHandler m => ErrorResponse -> m a
hcError = handlerError . HCError
@ -229,21 +256,41 @@ runRequestBody = do
Just rbc -> return rbc
Nothing -> do
rr <- waiRequest
#if MIN_VERSION_wai_extra(2, 0, 1)
internalState <- liftResourceT getInternalState
rbc <- liftIO $ rbHelper upload rr internalState
#elif MIN_VERSION_wai(2, 0, 0)
rbc <- liftIO $ rbHelper upload rr
#else
rbc <- liftResourceT $ rbHelper upload rr
#endif
put x { ghsRBC = Just rbc }
return rbc
#if MIN_VERSION_wai(2, 0, 0)
rbHelper :: FileUpload -> W.Request -> InternalState -> IO RequestBodyContents
rbHelper upload req internalState =
#else
rbHelper :: FileUpload -> W.Request -> ResourceT IO RequestBodyContents
rbHelper upload =
rbHelper upload req =
#endif
case upload of
FileUploadMemory s -> rbHelper' s mkFileInfoLBS
FileUploadDisk s -> rbHelper' s mkFileInfoFile
FileUploadSource s -> rbHelper' s mkFileInfoSource
FileUploadMemory s -> rbHelper' s mkFileInfoLBS req
#if MIN_VERSION_wai_extra(2, 0, 1)
FileUploadDisk s -> rbHelper' (s internalState) mkFileInfoFile req
#else
FileUploadDisk s -> rbHelper' s mkFileInfoFile req
#endif
FileUploadSource s -> rbHelper' s mkFileInfoSource req
rbHelper' :: NWP.BackEnd x
-> (Text -> Text -> x -> FileInfo)
-> W.Request
#if MIN_VERSION_wai(2, 0, 0)
-> IO ([(Text, Text)], [(Text, FileInfo)])
#else
-> ResourceT IO ([(Text, Text)], [(Text, FileInfo)])
#endif
rbHelper' backend mkFI req =
(map fix1 *** mapMaybe fix2) <$> (NWP.parseRequestBody backend req)
where
@ -327,7 +374,11 @@ handlerToIO =
where
oldReq = handlerRequest oldHandlerData
oldWaiReq = reqWaiRequest oldReq
#if MIN_VERSION_wai(3, 0, 0)
newWaiReq = oldWaiReq { W.requestBody = return mempty
#else
newWaiReq = oldWaiReq { W.requestBody = mempty
#endif
, W.requestBodyLength = W.KnownLength 0
}
oldEnv = handlerEnv oldHandlerData
@ -358,6 +409,18 @@ handlerToIO =
}
liftIO (f newHandlerData)
-- | forkIO for a Handler (run an action in the background)
--
-- Uses 'handlerToIO', liftResourceT, and resourceForkIO
-- for correctness and efficiency
--
-- Since 1.2.8
forkHandler :: (SomeException -> HandlerT site IO ()) -- ^ error handler
-> HandlerT site IO ()
-> HandlerT site IO ()
forkHandler onErr handler = do
yesRunner <- handlerToIO
void $ liftResourceT $ resourceForkIO $ yesRunner $ handle onErr handler
-- | Redirect to the given route.
-- HTTP status code 303 for HTTP 1.1 clients and 302 for HTTP 1.0
@ -486,8 +549,17 @@ sendFilePart :: MonadHandler m
-> Integer -- ^ offset
-> Integer -- ^ count
-> m a
sendFilePart ct fp off count =
sendFilePart ct fp off count = do
#if MIN_VERSION_wai(2, 0, 0)
fs <- liftIO $ PC.getFileStatus fp
handlerError $ HCSendFile ct fp $ Just W.FilePart
{ W.filePartOffset = off
, W.filePartByteCount = count
, W.filePartFileSize = fromIntegral $ PC.fileSize fs
}
#else
handlerError $ HCSendFile ct fp $ Just $ W.FilePart off count
#endif
-- | Bypass remaining handler code and output the given content with a 200
-- status code.
@ -514,6 +586,61 @@ sendResponseCreated url = do
sendWaiResponse :: MonadHandler m => W.Response -> m b
sendWaiResponse = handlerError . HCWai
-- | Switch over to handling the current request with a WAI @Application@.
--
-- Since 1.2.17
sendWaiApplication :: MonadHandler m => W.Application -> m b
sendWaiApplication = handlerError . HCWaiApp
#if MIN_VERSION_wai(3, 0, 0)
-- | Send a raw response without conduit. This is used for cases such as
-- WebSockets. Requires WAI 3.0 or later, and a web server which supports raw
-- responses (e.g., Warp).
--
-- Since 1.2.16
sendRawResponseNoConduit
:: (MonadHandler m, MonadBaseControl IO m)
=> (IO S8.ByteString -> (S8.ByteString -> IO ()) -> m ())
-> m a
sendRawResponseNoConduit raw = control $ \runInIO ->
runInIO $ sendWaiResponse $ flip W.responseRaw fallback
$ \src sink -> runInIO (raw src sink) >> return ()
where
fallback = W.responseLBS H.status500 [("Content-Type", "text/plain")]
"sendRawResponse: backend does not support raw responses"
#endif
#if MIN_VERSION_wai(2, 1, 0)
-- | Send a raw response. This is used for cases such as WebSockets. Requires
-- WAI 2.1 or later, and a web server which supports raw responses (e.g.,
-- Warp).
--
-- Since 1.2.7
sendRawResponse :: (MonadHandler m, MonadBaseControl IO m)
=> (Source IO S8.ByteString -> Sink S8.ByteString IO () -> m ())
-> m a
#if MIN_VERSION_wai(3, 0, 0)
sendRawResponse raw = control $ \runInIO ->
runInIO $ sendWaiResponse $ flip W.responseRaw fallback
$ \src sink -> runInIO (raw (src' src) (CL.mapM_ sink)) >> return ()
where
fallback = W.responseLBS H.status500 [("Content-Type", "text/plain")]
"sendRawResponse: backend does not support raw responses"
src' src = do
bs <- liftIO src
unless (S.null bs) $ do
yield bs
src' src
#else
sendRawResponse raw = control $ \runInIO ->
runInIO $ sendWaiResponse $ flip W.responseRaw fallback
$ \src sink -> runInIO (raw src sink) >> return ()
where
fallback = W.responseLBS H.status500 [("Content-Type", "text/plain")]
"sendRawResponse: backend does not support raw responses"
#endif
#endif
-- | Return a 404 not found page. Also denotes no handler available.
notFound :: MonadHandler m => m a
notFound = hcError NotFound
@ -607,7 +734,12 @@ cacheSeconds i = setHeader "Cache-Control" $ T.concat
-- | Set the Expires header to some date in 2037. In other words, this content
-- is never (realistically) expired.
neverExpires :: MonadHandler m => m ()
neverExpires = setHeader "Expires" "Thu, 31 Dec 2037 23:55:55 GMT"
neverExpires = do
setHeader "Expires" "Thu, 31 Dec 2037 23:55:55 GMT"
cacheSeconds oneYear
where
oneYear :: Int
oneYear = 60 * 60 * 24 * 365
-- | Set an Expires header in the past, meaning this content should not be
-- cached.
@ -677,6 +809,18 @@ instance (key ~ Text, val ~ Text) => RedirectUrl master (Route master, [(key, va
instance (key ~ Text, val ~ Text) => RedirectUrl master (Route master, Map.Map key val) where
toTextUrl (url, params) = toTextUrl (url, Map.toList params)
-- | Add a fragment identifier to a route to be used when
-- redirecting. For example:
--
-- > redirect (NewsfeedR :#: storyId)
--
-- Since 1.2.9.
data Fragment a b = a :#: b deriving (Show, Typeable)
instance (RedirectUrl master a, PathPiece b) => RedirectUrl master (Fragment a b) where
toTextUrl (a :#: b) = (\ua -> T.concat [ua, "#", toPathPiece b]) <$> toTextUrl a
-- | Lookup for session data.
lookupSession :: MonadHandler m => Text -> m (Maybe Text)
lookupSession = (liftM . fmap) (decodeUtf8With lenientDecode) . lookupSessionBS
@ -697,7 +841,7 @@ newIdent = do
x <- get
let i' = ghsIdent x + 1
put x { ghsIdent = i' }
return $ T.pack $ 'h' : show i'
return $ T.pack $ "hident" ++ show i'
-- | Redirect to a POST resource.
--
@ -916,7 +1060,7 @@ selectRep w = do
]) reps
-- match on the type for sub-type wildcards.
-- If the accept is text/* it should match a provided text/html
-- If the accept is text/ * it should match a provided text/html
mainTypeMap = Map.fromList $ reverse $ map
(\v@(ProvidedRep ct _) -> (fst $ contentTypeTypes ct, v)) reps
@ -972,7 +1116,22 @@ provideRepType ct handler =
rawRequestBody :: MonadHandler m => Source m S.ByteString
rawRequestBody = do
req <- lift waiRequest
transPipe liftResourceT $ W.requestBody req
#if MIN_VERSION_wai(3, 0, 0)
let loop = do
bs <- liftIO $ W.requestBody req
unless (S.null bs) $ do
yield bs
loop
loop
#else
transPipe
#if MIN_VERSION_wai(2, 0, 0)
liftIO
#else
liftResourceT
#endif
(W.requestBody req)
#endif
-- | Stream the data from the file. Since Yesod 1.2, this has been generalized
-- to work in any @MonadResource@.

49
yesod-core/Yesod/Core/Internal/Request.hs
View File

@ -40,14 +40,32 @@ import Data.Conduit.List (sourceList)
import Data.Conduit.Binary (sourceFile, sinkFile)
import Data.Word (Word64)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Resource (runResourceT, ResourceT)
import Control.Exception (throwIO)
import Yesod.Core.Types
import qualified Data.Map as Map
import Data.IORef
-- | Impose a limit on the size of the request body.
limitRequestBody :: Word64 -> W.Request -> W.Request
limitRequestBody :: Word64 -> W.Request -> IO W.Request
#if MIN_VERSION_wai(3, 0, 0)
limitRequestBody maxLen req = do
ref <- newIORef maxLen
return req
{ W.requestBody = do
bs <- W.requestBody req
remaining <- readIORef ref
let len = fromIntegral $ S8.length bs
remaining' = remaining - len
if remaining < len
then throwIO $ HCWai tooLargeResponse
else do
writeIORef ref remaining'
return bs
}
#else
limitRequestBody maxLen req =
req { W.requestBody = W.requestBody req $= limit maxLen }
return req { W.requestBody = W.requestBody req $= limit maxLen }
where
tooLarge = liftIO $ throwIO $ HCWai tooLargeResponse
@ -62,6 +80,7 @@ limitRequestBody maxLen req =
else do
yield bs
limit $ remaining - len
#endif
tooLargeResponse :: W.Response
tooLargeResponse = W.responseLBS
@ -74,7 +93,7 @@ parseWaiRequest :: RandomGen g
-> SessionMap
-> Bool
-> Maybe Word64 -- ^ max body size
-> (Either YesodRequest (g -> YesodRequest))
-> (Either (IO YesodRequest) (g -> IO YesodRequest))
parseWaiRequest env session useToken mmaxBodySize =
-- In most cases, we won't need to generate any random values. Therefore,
-- we split our results: if we need a random generator, return a Right
@ -84,17 +103,19 @@ parseWaiRequest env session useToken mmaxBodySize =
Left token -> Left $ mkRequest token
Right mkToken -> Right $ mkRequest . mkToken
where
mkRequest token' = YesodRequest
{ reqGetParams = gets
, reqCookies = cookies
, reqWaiRequest = maybe id limitRequestBody mmaxBodySize env
, reqLangs = langs''
, reqToken = token'
, reqSession = if useToken
then Map.delete tokenKey session
else session
, reqAccept = httpAccept env
}
mkRequest token' = do
envLimited <- maybe return limitRequestBody mmaxBodySize env
return YesodRequest
{ reqGetParams = gets
, reqCookies = cookies
, reqWaiRequest = envLimited
, reqLangs = langs''
, reqToken = token'
, reqSession = if useToken
then Map.delete tokenKey session
else session
, reqAccept = httpAccept env
}
gets = textQueryString env
reqCookie = lookup "Cookie" $ W.requestHeaders env
cookies = maybe [] parseCookiesText reqCookie

114
yesod-core/Yesod/Core/Internal/Response.hs
View File

@ -1,3 +1,4 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE RankNTypes #-}
@ -12,6 +13,13 @@ import qualified Data.ByteString.Char8 as S8
import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI
import Network.Wai
#if MIN_VERSION_wai(2, 0, 0)
import Data.Conduit (transPipe)
import Control.Monad.Trans.Resource (runInternalState, getInternalState, runResourceT, InternalState, closeInternalState)
import Control.Monad.Trans.Class (lift)
import Network.Wai.Internal
import Control.Exception (finally)
#endif
import Prelude hiding (catch)
import Web.Cookie (renderSetCookie)
import Yesod.Core.Content
@ -25,14 +33,20 @@ import qualified Data.ByteString.Lazy as L
import qualified Data.Map as Map
import Yesod.Core.Internal.Request (tokenKey)
import Data.Text.Encoding (encodeUtf8)
import Data.Conduit (Flush (..), ($$))
import qualified Data.Conduit.List as CL
yarToResponse :: Monad m
=> YesodResponse
-> (SessionMap -> m [Header]) -- ^ save session
#if MIN_VERSION_wai(3, 0, 0)
yarToResponse :: YesodResponse
-> (SessionMap -> IO [Header]) -- ^ save session
-> YesodRequest
-> m Response
yarToResponse (YRWai a) _ _ = return a
yarToResponse (YRPlain s' hs ct c newSess) saveSession yreq = do
-> Request
-> InternalState
-> (Response -> IO ResponseReceived)
-> IO ResponseReceived
yarToResponse (YRWai a) _ _ _ _ sendResponse = sendResponse a
yarToResponse (YRWaiApp app) _ _ req _ sendResponse = app req sendResponse
yarToResponse (YRPlain s' hs ct c newSess) saveSession yreq req is sendResponse = do
extraHeaders <- do
let nsToken = maybe
newSess
@ -43,6 +57,88 @@ yarToResponse (YRPlain s' hs ct c newSess) saveSession yreq = do
let finalHeaders = extraHeaders ++ map headerToPair hs
finalHeaders' len = ("Content-Length", S8.pack $ show len)
: finalHeaders
let go (ContentBuilder b mlen) = do
let hs' = maybe finalHeaders finalHeaders' mlen
sendResponse $ ResponseBuilder s hs' b
go (ContentFile fp p) = do
sendResponse $ ResponseFile s finalHeaders fp p
go (ContentSource body) = sendResponse $ responseStream s finalHeaders
$ \sendChunk flush -> do
transPipe (flip runInternalState is) body
$$ CL.mapM_ (\mchunk ->
case mchunk of
Flush -> flush
Chunk builder -> sendChunk builder)
go (ContentDontEvaluate c') = go c'
go c
where
s
| s' == defaultStatus = H.status200
| otherwise = s'
#else
yarToResponse :: YesodResponse
-> (SessionMap -> IO [Header]) -- ^ save session
-> YesodRequest
-> Request
#if MIN_VERSION_wai(2, 0, 0)
-> InternalState
#endif
-> IO Response
#if MIN_VERSION_wai(2, 0, 0)
yarToResponse (YRWaiApp app) _ _ req _ = app req
yarToResponse (YRWai a) _ _ _ is =
case a of
ResponseSource s hs w -> return $ ResponseSource s hs $ \f ->
w f `finally` closeInternalState is
ResponseBuilder{} -> do
closeInternalState is
return a
ResponseFile{} -> do
closeInternalState is
return a
#if MIN_VERSION_wai(2, 1, 0)
-- Ignore the fallback provided, in case it refers to a ResourceT state
-- in a ResponseSource.
ResponseRaw raw _ -> return $ ResponseRaw
(\f -> raw f `finally` closeInternalState is)
(responseLBS H.status500 [("Content-Type", "text/plain")]
"yarToResponse: backend does not support raw responses")
#endif
#else
yarToResponse (YRWai a) _ _ _ = return a
#endif
yarToResponse (YRPlain s' hs ct c newSess) saveSession yreq req
#if MIN_VERSION_wai(2, 0, 0)
is
#endif
= do
extraHeaders <- do
let nsToken = maybe
newSess
(\n -> Map.insert tokenKey (encodeUtf8 n) newSess)
(reqToken yreq)
sessionHeaders <- saveSession nsToken
return $ ("Content-Type", ct) : map headerToPair sessionHeaders
let finalHeaders = extraHeaders ++ map headerToPair hs
finalHeaders' len = ("Content-Length", S8.pack $ show len)
: finalHeaders
#if MIN_VERSION_wai(2, 0, 0)
let go (ContentBuilder b mlen) = do
let hs' = maybe finalHeaders finalHeaders' mlen
closeInternalState is
return $ ResponseBuilder s hs' b
go (ContentFile fp p) = do
closeInternalState is
return $ ResponseFile s finalHeaders fp p
go (ContentSource body) = return $ ResponseSource s finalHeaders $ \f ->
f (transPipe (flip runInternalState is) body) `finally`
closeInternalState is
go (ContentDontEvaluate c') = go c'
go c
#else
let go (ContentBuilder b mlen) =
let hs' = maybe finalHeaders finalHeaders' mlen
in ResponseBuilder s hs' b
@ -50,10 +146,12 @@ yarToResponse (YRPlain s' hs ct c newSess) saveSession yreq = do
go (ContentSource body) = ResponseSource s finalHeaders body
go (ContentDontEvaluate c') = go c'
return $ go c
#endif
where
s
| s' == defaultStatus = H.status200
| otherwise = s'
#endif
-- | Indicates that the user provided no specific status code to be used, and
-- therefore the default status code should be used. For normal responses, this
@ -87,7 +185,9 @@ headerToPair (Header key value) = (CI.mk key, value)
evaluateContent :: Content -> IO (Either ErrorResponse Content)
evaluateContent (ContentBuilder b mlen) = handle f $ do
let lbs = toLazyByteString b
L.length lbs `seq` return (Right $ ContentBuilder (fromLazyByteString lbs) mlen)
len = L.length lbs
mlen' = maybe (Just $ fromIntegral len) Just mlen
len `seq` return (Right $ ContentBuilder (fromLazyByteString lbs) mlen')
where
f :: SomeException -> IO (Either ErrorResponse Content)
f = return . Left . InternalError . T.pack . show

93
yesod-core/Yesod/Core/Internal/Run.hs
View File

@ -1,3 +1,4 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE RankNTypes #-}
@ -9,13 +10,15 @@ module Yesod.Core.Internal.Run where
import Yesod.Core.Internal.Response
import Blaze.ByteString.Builder (toByteString)
import Control.Applicative ((<$>))
import Control.Exception (fromException)
import Control.Exception (fromException, bracketOnError, evaluate)
import qualified Control.Exception as E
import Control.Exception.Lifted (catch)
import Control.Monad (mplus)
import Control.Monad.IO.Class (MonadIO)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Logger (LogLevel (LevelError), LogSource,
liftLoc)
import Control.Monad.Trans.Resource (runResourceT, withInternalState, runInternalState)
import Control.Monad.Trans.Resource (runResourceT, withInternalState, runInternalState, createInternalState, closeInternalState)
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
import qualified Data.IORef as I
@ -31,8 +34,13 @@ import Data.Text.Encoding.Error (lenientDecode)
import Language.Haskell.TH.Syntax (Loc, qLocation)
import qualified Network.HTTP.Types as H
import Network.Wai
#if MIN_VERSION_wai(2, 0, 0)
import Network.Wai.Internal
#endif
import Prelude hiding (catch)
#if !MIN_VERSION_fast_logger(2, 0, 0)
import System.Log.FastLogger (Logger)
#endif
import System.Log.FastLogger (LogStr, toLogStr)
import System.Random (newStdGen)
import Yesod.Core.Content
@ -41,6 +49,19 @@ import Yesod.Core.Types
import Yesod.Core.Internal.Request (parseWaiRequest,
tooLargeResponse)
import Yesod.Routes.Class (Route, renderRoute)
import Control.DeepSeq (($!!), NFData)
import Control.Monad (liftM)
returnDeepSessionMap :: Monad m => SessionMap -> m SessionMap
#if MIN_VERSION_bytestring(0, 10, 0)
returnDeepSessionMap sm = return $!! sm
#else
returnDeepSessionMap sm = fmap unWrappedBS `liftM` (return $!! fmap WrappedBS sm)
-- | Work around missing NFData instance for bytestring 0.9.
newtype WrappedBS = WrappedBS { unWrappedBS :: S8.ByteString }
instance NFData WrappedBS
#endif
-- | Function used internally by Yesod in the process of converting a
-- 'HandlerT' into an 'Application'. Should not be needed by users.
@ -71,29 +92,43 @@ runHandler rhe@RunHandlerEnv {..} handler yreq = withInternalState $ \resState -
(\e -> return $ Left $ maybe (HCError $ toErrorHandler e) id
$ fromException e)
state <- liftIO $ I.readIORef istate
let finalSession = ghsSession state
let headers = ghsHeaders state
let contents = either id (HCContent defaultStatus . toTypedContent) contents'
(finalSession, mcontents1) <- (do
finalSession <- returnDeepSessionMap (ghsSession state)
return (finalSession, Nothing)) `E.catch` \e -> return
(Map.empty, Just $! HCError $! InternalError $! T.pack $! show (e :: E.SomeException))
(headers, mcontents2) <- (do
headers <- return $!! appEndo (ghsHeaders state) []
return (headers, Nothing)) `E.catch` \e -> return
([], Just $! HCError $! InternalError $! T.pack $! show (e :: E.SomeException))
let contents =
case mcontents1 `mplus` mcontents2 of
Just x -> x
Nothing -> either id (HCContent defaultStatus . toTypedContent) contents'
let handleError e = flip runInternalState resState $ do
yar <- rheOnError e yreq
{ reqSession = finalSession
}
case yar of
YRPlain status' hs ct c sess ->
let hs' = appEndo headers hs
let hs' = headers ++ hs
status
| status' == defaultStatus = getStatus e
| otherwise = status'
in return $ YRPlain status hs' ct c sess
YRWai _ -> return yar
let sendFile' ct fp p =
return $ YRPlain H.status200 (appEndo headers []) ct (ContentFile fp p) finalSession
case contents of
return $ YRPlain H.status200 headers ct (ContentFile fp p) finalSession
contents1 <- evaluate contents `E.catch` \e -> return
(HCError $! InternalError $! T.pack $! show (e :: E.SomeException))
case contents1 of
HCContent status (TypedContent ct c) -> do
ec' <- liftIO $ evaluateContent c
case ec' of
Left e -> handleError e
Right c' -> return $ YRPlain status (appEndo headers []) ct c' finalSession
Right c' -> return $ YRPlain status headers ct c' finalSession
HCError e -> handleError e
HCRedirect status loc -> do
let disable_caching x =
@ -101,7 +136,7 @@ runHandler rhe@RunHandlerEnv {..} handler yreq = withInternalState $ \resState -
: Header "Expires" "Thu, 01 Jan 1970 05:05:05 GMT"
: x
hs = (if status /= H.movedPermanently301 then disable_caching else id)
$ Header "Location" (encodeUtf8 loc) : appEndo headers []
$ Header "Location" (encodeUtf8 loc) : headers
return $ YRPlain
status hs typePlain emptyContent
finalSession
@ -109,7 +144,7 @@ runHandler rhe@RunHandlerEnv {..} handler yreq = withInternalState $ \resState -
(sendFile' ct fp p)
(handleError . toErrorHandler)
HCCreated loc -> do
let hs = Header "Location" (encodeUtf8 loc) : appEndo headers []
let hs = Header "Location" (encodeUtf8 loc) : headers
return $ YRPlain
H.status201
hs
@ -117,6 +152,7 @@ runHandler rhe@RunHandlerEnv {..} handler yreq = withInternalState $ \resState -
emptyContent
finalSession
HCWai r -> return $ YRWai r
HCWaiApp a -> return $ YRWaiApp a
safeEh :: (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
-> ErrorResponse
@ -179,20 +215,27 @@ runFakeHandler fakeSessionMap logger site handler = liftIO $ do
typePlain
(toContent ("runFakeHandler: errHandler" :: S8.ByteString))
(reqSession req)
fakeWaiRequest =
Request
fakeWaiRequest = Request
{ requestMethod = "POST"
, httpVersion = H.http11
, rawPathInfo = "/runFakeHandler/pathInfo"
, rawQueryString = ""
#if MIN_VERSION_wai(2, 0, 0)
, requestHeaderHost = Nothing
#else
, serverName = "runFakeHandler-serverName"
, serverPort = 80
#endif
, requestHeaders = []
, isSecure = False
, remoteHost = error "runFakeHandler-remoteHost"
, pathInfo = ["runFakeHandler", "pathInfo"]
, queryString = []
#if MIN_VERSION_wai(3, 0, 0)
, requestBody = return mempty
#else
, requestBody = mempty
#endif
, vault = mempty
, requestBodyLength = KnownLength 0
}
@ -215,8 +258,13 @@ yesodRunner :: (ToTypedContent res, Yesod site)
-> YesodRunnerEnv site
-> Maybe (Route site)
-> Application
#if MIN_VERSION_wai(3, 0, 0)
yesodRunner handler' YesodRunnerEnv {..} route req sendResponse
| Just maxLen <- mmaxLen, KnownLength len <- requestBodyLength req, maxLen < len = sendResponse tooLargeResponse
#else
yesodRunner handler' YesodRunnerEnv {..} route req
| Just maxLen <- mmaxLen, KnownLength len <- requestBodyLength req, maxLen < len = return tooLargeResponse
#endif
| otherwise = do
let dontSaveSession _ = return []
(session, saveSession) <- liftIO $ do
@ -243,8 +291,25 @@ yesodRunner handler' YesodRunnerEnv {..} route req
rhe = rheSafe
{ rheOnError = runHandler rheSafe . errorHandler
}
#if MIN_VERSION_wai(3, 0, 0)
E.bracket createInternalState closeInternalState $ \is -> do
yreq' <- yreq
yar <- runInternalState (runHandler rhe handler yreq') is
yarToResponse yar saveSession yreq' req is sendResponse
#else
#if MIN_VERSION_wai(2, 0, 0)
bracketOnError createInternalState closeInternalState $ \is -> do
yreq' <- yreq
yar <- runInternalState (runHandler rhe handler yreq') is
liftIO $ yarToResponse yar saveSession yreq' req is
#else
yar <- runHandler rhe handler yreq
liftIO $ yarToResponse yar saveSession yreq
liftIO $ yarToResponse yar saveSession yreq req
#endif
#endif
where
mmaxLen = maximumContentLength yreSite route
handler = yesodMiddleware handler'

20
yesod-core/Yesod/Core/Json.hs
View File

@ -1,4 +1,5 @@
{-# LANGUAGE TypeSynonymInstances, OverloadedStrings #-}
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Yesod.Core.Json
( -- * Convert from a JSON value
@ -10,6 +11,7 @@ module Yesod.Core.Json
-- * Convert to a JSON value
, parseJsonBody
, parseJsonBody_
, requireJsonBody
-- * Produce JSON values
, J.Value (..)
@ -27,6 +29,7 @@ module Yesod.Core.Json
import Yesod.Core.Handler (HandlerT, getRequest, invalidArgs, redirect, selectRep, provideRep, rawRequestBody, ProvidedRep)
import Control.Monad.Trans.Writer (Writer)
import Control.Monad.Trans.Resource (runExceptionT)
import Data.Monoid (Endo)
import Yesod.Core.Content (TypedContent)
import Yesod.Core.Types (reqAccept)
@ -41,6 +44,7 @@ import Data.Conduit.Attoparsec (sinkParser)
import Data.Text (pack)
import qualified Data.Vector as V
import Data.Conduit
import Data.Conduit.Lift
import qualified Data.ByteString.Char8 as B8
import Data.Maybe (listToMaybe)
import Control.Monad (liftM)
@ -84,10 +88,18 @@ provideJson = provideRep . return . J.toJSON
-- If you want the raw JSON value, just ask for a @'J.Result'
-- 'J.Value'@.
--
-- Note that this function will consume the request body. As such, calling it
-- twice will result in a parse error on the second call, since the request
-- body will no longer be available.
--
-- /Since: 0.3.0/
parseJsonBody :: (MonadHandler m, J.FromJSON a) => m (J.Result a)
parseJsonBody = do
#if MIN_VERSION_resourcet(1,1,0)
eValue <- rawRequestBody $$ runCatchC (sinkParser JP.value')
#else
eValue <- runExceptionT $ rawRequestBody $$ sinkParser JP.value'
#endif
return $ case eValue of
Left e -> J.Error $ show e
Right value -> J.fromJSON value
@ -95,7 +107,13 @@ parseJsonBody = do
-- | Same as 'parseJsonBody', but return an invalid args response on a parse
-- error.
parseJsonBody_ :: (MonadHandler m, J.FromJSON a) => m a
parseJsonBody_ = do
parseJsonBody_ = requireJsonBody
{-# DEPRECATED parseJsonBody_ "Use requireJsonBody instead" #-}
-- | Same as 'parseJsonBody', but return an invalid args response on a parse
-- error.
requireJsonBody :: (MonadHandler m, J.FromJSON a) => m a
requireJsonBody = do
ra <- parseJsonBody
case ra of
J.Error s -> invalidArgs [pack s]

108
yesod-core/Yesod/Core/Types.hs
View File

@ -5,6 +5,7 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE CPP #-}
module Yesod.Core.Types where
import qualified Blaze.ByteString.Builder as BBuilder
@ -15,16 +16,21 @@ import Control.Arrow (first)
import Control.Exception (Exception)
import Control.Monad (liftM, ap)
import Control.Monad.Base (MonadBase (liftBase))
import Control.Monad.Catch (MonadCatch (..))
#if MIN_VERSION_exceptions(0,6,0)
import Control.Monad.Catch (MonadMask (..))
#endif
import Control.Monad.IO.Class (MonadIO (liftIO))
import Control.Monad.Logger (LogLevel, LogSource,
MonadLogger (..))
import Control.Monad.Trans.Control (MonadBaseControl (..))
import Control.Monad.Trans.Resource (MonadResource (..), InternalState, runInternalState)
import Control.Monad.Trans.Resource (MonadResource (..), InternalState, runInternalState, MonadThrow (..), monadThrow, ResourceT)
#if !MIN_VERSION_resourcet(1,1,0)
import Control.Monad.Trans.Resource (MonadUnsafeIO (..))
#endif
import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy as L
import Data.Conduit (Flush, MonadThrow (..),
MonadUnsafeIO (..),
ResourceT, Source)
import Data.Conduit (Flush, Source)
import Data.Dynamic (Dynamic)
import Data.IORef (IORef)
import Data.Map (Map, unionWith)
@ -46,7 +52,12 @@ import Network.Wai (FilePart,
RequestBodyLength)
import qualified Network.Wai as W
import qualified Network.Wai.Parse as NWP
#if MIN_VERSION_fast_logger(2, 0, 0)
import System.Log.FastLogger (LogStr, LoggerSet, toLogStr, pushLogStr)
import Network.Wai.Logger (DateCacheGetter)
#else
import System.Log.FastLogger (LogStr, Logger, toLogStr)
#endif
import Text.Blaze.Html (Html)
import Text.Hamlet (HtmlUrl)
import Text.Julius (JavascriptUrl)
@ -54,6 +65,9 @@ import Web.Cookie (SetCookie)
import Yesod.Core.Internal.Util (getTime, putTime)
import Control.Monad.Trans.Class (MonadTrans (..))
import Yesod.Routes.Class (RenderRoute (..), ParseRoute (..))
import Control.Monad.Reader (MonadReader (..))
import Prelude hiding (catch)
import Control.DeepSeq (NFData (rnf))
-- Sessions
type SessionMap = Map Text ByteString
@ -112,6 +126,7 @@ data YesodRequest = YesodRequest
-- or a higher-level data structure which Yesod will turn into a @Response@.
data YesodResponse
= YRWai !W.Response
| YRWaiApp !W.Application
| YRPlain !H.Status ![Header] !ContentType !Content !SessionMap
-- | A tuple containing both the POST parameters and submitted files.
@ -128,7 +143,11 @@ data FileInfo = FileInfo
}
data FileUpload = FileUploadMemory !(NWP.BackEnd L.ByteString)
#if MIN_VERSION_wai_extra(2, 0, 1)
| FileUploadDisk !(InternalState -> NWP.BackEnd FilePath)
#else
| FileUploadDisk !(NWP.BackEnd FilePath)
#endif
| FileUploadSource !(NWP.BackEnd (Source (ResourceT IO) ByteString))
-- | How to determine the root of the application for constructing URLs.
@ -298,6 +317,14 @@ data Header =
| Header ByteString ByteString
deriving (Eq, Show)
-- FIXME In the next major version bump, let's just add strictness annotations
-- to Header (and probably everywhere else). We can also add strictness
-- annotations to SetCookie in the cookie package.
instance NFData Header where
rnf (AddCookie x) = rnf x
rnf (DeleteCookie x y) = x `seq` y `seq` ()
rnf (Header x y) = x `seq` y `seq` ()
data Location url = Local url | Remote Text
deriving (Show, Eq)
@ -346,6 +373,7 @@ data HandlerContents =
| HCRedirect H.Status Text
| HCCreated Text
| HCWai W.Response
| HCWaiApp W.Application
deriving Typeable
instance Show HandlerContents where
@ -355,6 +383,7 @@ instance Show HandlerContents where
show (HCRedirect s t) = "HCRedirect " ++ show (s, t)
show (HCCreated t) = "HCCreated " ++ show t
show (HCWai _) = "HCWai"
show (HCWaiApp _) = "HCWaiApp"
instance Exception HandlerContents
-- Instances for WidgetT
@ -375,17 +404,54 @@ instance MonadBase b m => MonadBase b (WidgetT site m) where
liftBase = WidgetT . const . liftBase . fmap (, mempty)
instance MonadBaseControl b m => MonadBaseControl b (WidgetT site m) where
data StM (WidgetT site m) a = StW (StM m (a, GWData (Route site)))
liftBaseWith f = WidgetT $ \reader ->
liftBaseWith f = WidgetT $ \reader' ->
liftBaseWith $ \runInBase ->
liftM (\x -> (x, mempty))
(f $ liftM StW . runInBase . flip unWidgetT reader)
(f $ liftM StW . runInBase . flip unWidgetT reader')
restoreM (StW base) = WidgetT $ const $ restoreM base
instance Monad m => MonadReader site (WidgetT site m) where
ask = WidgetT $ \hd -> return (rheSite $ handlerEnv hd, mempty)
local f (WidgetT g) = WidgetT $ \hd -> g hd
{ handlerEnv = (handlerEnv hd)
{ rheSite = f $ rheSite $ handlerEnv hd
}
}
instance MonadTrans (WidgetT site) where
lift = WidgetT . const . liftM (, mempty)
instance MonadThrow m => MonadThrow (WidgetT site m) where
#if MIN_VERSION_resourcet(1,1,0)
throwM = lift . throwM
instance MonadCatch m => MonadCatch (HandlerT site m) where
catch (HandlerT m) c = HandlerT $ \r -> m r `catch` \e -> unHandlerT (c e) r
#if MIN_VERSION_exceptions(0,6,0)
instance MonadMask m => MonadMask (HandlerT site m) where
#endif
mask a = HandlerT $ \e -> mask $ \u -> unHandlerT (a $ q u) e
where q u (HandlerT b) = HandlerT (u . b)
uninterruptibleMask a =
HandlerT $ \e -> uninterruptibleMask $ \u -> unHandlerT (a $ q u) e
where q u (HandlerT b) = HandlerT (u . b)
instance MonadCatch m => MonadCatch (WidgetT site m) where
catch (WidgetT m) c = WidgetT $ \r -> m r `catch` \e -> unWidgetT (c e) r
#if MIN_VERSION_exceptions(0,6,0)
instance MonadMask m => MonadMask (WidgetT site m) where
#endif
mask a = WidgetT $ \e -> mask $ \u -> unWidgetT (a $ q u) e
where q u (WidgetT b) = WidgetT (u . b)
uninterruptibleMask a =
WidgetT $ \e -> uninterruptibleMask $ \u -> unWidgetT (a $ q u) e
where q u (WidgetT b) = WidgetT (u . b)
#else
monadThrow = lift . monadThrow
#endif
#if MIN_VERSION_resourcet(1,1,0)
instance (Applicative m, MonadIO m, MonadBase IO m, MonadThrow m) => MonadResource (WidgetT site m) where
#else
instance (Applicative m, MonadIO m, MonadUnsafeIO m, MonadThrow m) => MonadResource (WidgetT site m) where
#endif
liftResourceT f = WidgetT $ \hd -> liftIO $ fmap (, mempty) $ runInternalState f (handlerResource hd)
instance MonadIO m => MonadLogger (WidgetT site m) where
@ -408,6 +474,13 @@ instance MonadIO m => MonadIO (HandlerT site m) where
liftIO = lift . liftIO
instance MonadBase b m => MonadBase b (HandlerT site m) where
liftBase = lift . liftBase
instance Monad m => MonadReader site (HandlerT site m) where
ask = HandlerT $ return . rheSite . handlerEnv
local f (HandlerT g) = HandlerT $ \hd -> g hd
{ handlerEnv = (handlerEnv hd)
{ rheSite = f $ rheSite $ handlerEnv hd
}
}
-- | Note: although we provide a @MonadBaseControl@ instance, @lifted-base@'s
-- @fork@ function is incompatible with the underlying @ResourceT@ system.
-- Instead, if you must fork a separate thread, you should use
@ -418,14 +491,23 @@ instance MonadBase b m => MonadBase b (HandlerT site m) where
-- after cleanup. Please contact the maintainers.\"
instance MonadBaseControl b m => MonadBaseControl b (HandlerT site m) where
data StM (HandlerT site m) a = StH (StM m a)
liftBaseWith f = HandlerT $ \reader ->
liftBaseWith f = HandlerT $ \reader' ->
liftBaseWith $ \runInBase ->
f $ liftM StH . runInBase . (\(HandlerT r) -> r reader)
f $ liftM StH . runInBase . (\(HandlerT r) -> r reader')
restoreM (StH base) = HandlerT $ const $ restoreM base
instance MonadThrow m => MonadThrow (HandlerT site m) where
#if MIN_VERSION_resourcet(1,1,0)
throwM = lift . monadThrow
#else
monadThrow = lift . monadThrow
#endif
#if MIN_VERSION_resourcet(1,1,0)
instance (MonadIO m, MonadBase IO m, MonadThrow m) => MonadResource (HandlerT site m) where
#else
instance (MonadIO m, MonadUnsafeIO m, MonadThrow m) => MonadResource (HandlerT site m) where
#endif
liftResourceT f = HandlerT $ \hd -> liftIO $ runInternalState f (handlerResource hd)
instance MonadIO m => MonadLogger (HandlerT site m) where
@ -445,3 +527,13 @@ instance RenderRoute WaiSubsite where
renderRoute (WaiSubsiteRoute ps qs) = (ps, qs)
instance ParseRoute WaiSubsite where
parseRoute (x, y) = Just $ WaiSubsiteRoute x y
#if MIN_VERSION_fast_logger(2, 0, 0)
data Logger = Logger
{ loggerSet :: !LoggerSet
, loggerDate :: !DateCacheGetter
}
loggerPutStr :: Logger -> LogStr -> IO ()
loggerPutStr (Logger ls _) = pushLogStr ls
#endif

19
yesod-core/Yesod/Core/Widget.hs
View File

@ -47,6 +47,7 @@ module Yesod.Core.Widget
, handlerToWidget
-- * Internal
, whamletFileWithSettings
, asWidgetT
) where
import Data.Monoid
@ -82,10 +83,16 @@ instance render ~ RY site => ToWidget site (render -> Html) where
toWidget x = tell $ GWData (Body x) mempty mempty mempty mempty mempty mempty
instance render ~ RY site => ToWidget site (render -> Css) where
toWidget x = toWidget $ CssBuilder . fromLazyText . renderCss . x
instance ToWidget site Css where
toWidget x = toWidget $ CssBuilder . fromLazyText . renderCss . const x
instance render ~ RY site => ToWidget site (render -> CssBuilder) where
toWidget x = tell $ GWData mempty mempty mempty mempty (Map.singleton Nothing $ unCssBuilder . x) mempty mempty
instance ToWidget site CssBuilder where
toWidget x = tell $ GWData mempty mempty mempty mempty (Map.singleton Nothing $ unCssBuilder . const x) mempty mempty
instance render ~ RY site => ToWidget site (render -> Javascript) where
toWidget x = tell $ GWData mempty mempty mempty mempty mempty (Just x) mempty
instance ToWidget site Javascript where
toWidget x = tell $ GWData mempty mempty mempty mempty mempty (Just $ const x) mempty
instance (site' ~ site, IO ~ m, a ~ ()) => ToWidget site' (WidgetT site m a) where
toWidget = liftWidgetT
instance ToWidget site Html where
@ -104,8 +111,12 @@ class ToWidgetMedia site a where
-> m ()
instance render ~ RY site => ToWidgetMedia site (render -> Css) where
toWidgetMedia media x = toWidgetMedia media $ CssBuilder . fromLazyText . renderCss . x
instance ToWidgetMedia site Css where
toWidgetMedia media x = toWidgetMedia media $ CssBuilder . fromLazyText . renderCss . const x
instance render ~ RY site => ToWidgetMedia site (render -> CssBuilder) where
toWidgetMedia media x = tell $ GWData mempty mempty mempty mempty (Map.singleton (Just media) $ unCssBuilder . x) mempty mempty
instance ToWidgetMedia site CssBuilder where
toWidgetMedia media x = tell $ GWData mempty mempty mempty mempty (Map.singleton (Just media) $ unCssBuilder . const x) mempty mempty
class ToWidgetBody site a where
toWidgetBody :: (MonadWidget m, HandlerSite m ~ site) => a -> m ()
@ -114,6 +125,8 @@ instance render ~ RY site => ToWidgetBody site (render -> Html) where
toWidgetBody = toWidget
instance render ~ RY site => ToWidgetBody site (render -> Javascript) where
toWidgetBody j = toWidget $ \r -> H.script $ preEscapedLazyText $ renderJavascriptUrl r j
instance ToWidgetBody site Javascript where
toWidgetBody j = toWidget $ \_ -> H.script $ preEscapedLazyText $ renderJavascript j
instance ToWidgetBody site Html where
toWidgetBody = toWidget
@ -124,10 +137,16 @@ instance render ~ RY site => ToWidgetHead site (render -> Html) where
toWidgetHead = tell . GWData mempty mempty mempty mempty mempty mempty . Head
instance render ~ RY site => ToWidgetHead site (render -> Css) where
toWidgetHead = toWidget
instance ToWidgetHead site Css where
toWidgetHead = toWidget
instance render ~ RY site => ToWidgetHead site (render -> CssBuilder) where
toWidgetHead = toWidget
instance ToWidgetHead site CssBuilder where
toWidgetHead = toWidget
instance render ~ RY site => ToWidgetHead site (render -> Javascript) where
toWidgetHead j = toWidgetHead $ \r -> H.script $ preEscapedLazyText $ renderJavascriptUrl r j
instance ToWidgetHead site Javascript where
toWidgetHead j = toWidgetHead $ \_ -> H.script $ preEscapedLazyText $ renderJavascript j
instance ToWidgetHead site Html where
toWidgetHead = toWidgetHead . const

59
yesod-core/widget-benchmark.hs → yesod-core/bench/widget.hs
View File

@ -1,3 +1,4 @@
{-# LANGUAGE OverloadedStrings #-}
-- | BigTable benchmark implemented using Hamlet.
--
{-# LANGUAGE QuasiQuotes #-}
@ -7,19 +8,22 @@ import Criterion.Main
import Text.Hamlet
import Numeric (showInt)
import qualified Data.ByteString.Lazy as L
import qualified Text.Blaze.Renderer.Utf8 as Utf8
import qualified Text.Blaze.Html.Renderer.Utf8 as Utf8
import Data.Monoid (mconcat)
import Text.Blaze.Html5 (table, tr, td)
import Yesod.Widget
import Text.Blaze.Html (toHtml)
import Yesod.Core.Widget
import Control.Monad.Trans.Writer
import Control.Monad.Trans.RWS
import Data.Functor.Identity
import Yesod.Internal
import Yesod.Core.Types
import Data.Monoid
import Data.IORef
main = defaultMain
[ bench "bigTable html" $ nf bigTableHtml bigTableData
, bench "bigTable hamlet" $ nf bigTableHamlet bigTableData
, bench "bigTable widget" $ nf bigTableWidget bigTableData
, bench "bigTable widget" $ nfIO (bigTableWidget bigTableData)
, bench "bigTable blaze" $ nf bigTableBlaze bigTableData
]
where
@ -30,50 +34,35 @@ main = defaultMain
bigTableData = replicate rows [1..10]
{-# NOINLINE bigTableData #-}
bigTableHtml rows = L.length $ renderHtml [$hamlet|
<table
bigTableHtml rows = L.length $ Utf8.renderHtml $ ($ id) [hamlet|
<table>
$forall row <- rows
<tr
<tr>
$forall cell <- row
<td>#{show cell}
|]
bigTableHamlet rows = L.length $ renderHamlet id [$hamlet|
<table
bigTableHamlet rows = L.length $ Utf8.renderHtml $ ($ id) [hamlet|
<table>
$forall row <- rows
<tr
<tr>
$forall cell <- row
<td>#{show cell}
|]
bigTableWidget rows = L.length $ renderHtml $ (run [$hamlet|
<table
bigTableWidget rows = fmap (L.length . Utf8.renderHtml . ($ render)) (run [whamlet|
<table>
$forall row <- rows
<tr
<tr>
$forall cell <- row
<td>#{show cell}
|]) (\_ _ -> "foo")
|])
where
run (GWidget w) =
let (_, _, GWData (Body x) _ _ _ _ _ _) = runRWS w () 0
in x
{-
run (GWidget w) = runIdentity $ do
w' <- flip evalStateT 0
$ runWriterT $ runWriterT $ runWriterT $ runWriterT
$ runWriterT $ runWriterT $ runWriterT w
let ((((((((),
Body body),
_),
_),
_),
_),
_),
_) = w'
render _ _ = "foo"
run (WidgetT w) = do
(_, GWData { gwdBody = Body x }) <- w undefined
return x
return body
-}
bigTableBlaze t = L.length $ renderHtml $ table $ mconcat $ map row t
bigTableBlaze t = L.length $ Utf8.renderHtml $ table $ mconcat $ map row t
where
row r = tr $ mconcat $ map (td . string . show) r
row r = tr $ mconcat $ map (td . toHtml . show) r

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

@ -1,3 +1,4 @@
{-# LANGUAGE CPP #-}
module YesodCoreTest (specs) where
import YesodCoreTest.CleanPath
@ -14,6 +15,9 @@ import qualified YesodCoreTest.Redirect as Redirect
import qualified YesodCoreTest.JsLoader as JsLoader
import qualified YesodCoreTest.RequestBodySize as RequestBodySize
import qualified YesodCoreTest.Json as Json
#if MIN_VERSION_wai(2, 1, 0)
import qualified YesodCoreTest.RawResponse as RawResponse
#endif
import qualified YesodCoreTest.Streaming as Streaming
import qualified YesodCoreTest.Reps as Reps
import qualified YesodCoreTest.Auth as Auth
@ -37,6 +41,9 @@ specs = do
JsLoader.specs
RequestBodySize.specs
Json.specs
#if MIN_VERSION_wai(2, 1, 0)
RawResponse.specs
#endif
Streaming.specs
Reps.specs
Auth.specs

2
yesod-core/test/YesodCoreTest/Auth.hs
View File

@ -8,6 +8,7 @@ import Network.Wai
import qualified Data.ByteString.Char8 as S8
import qualified Data.Text as T
import Data.List (isSuffixOf)
import qualified Network.HTTP.Types as H
data App = App
@ -51,6 +52,7 @@ test method path f = it (method ++ " " ++ path) $ do
, requestHeaders =
if not $ isSuffixOf "json" path then [] else
[("Accept", S8.pack "application/json")]
, httpVersion = H.http11
}
f sres

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

@ -1,6 +1,7 @@
{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE CPP #-}
module YesodCoreTest.CleanPath (cleanPathTest, Widget) where
import Test.Hspec
@ -32,7 +33,11 @@ instance ParseRoute Subsite where
parseRoute (x, _) = Just $ SubsiteRoute x
instance YesodSubDispatch Subsite master where
#if MIN_VERSION_wai(3, 0, 0)
yesodSubDispatch _ req f = f $ responseLBS
#else
yesodSubDispatch _ req = return $ responseLBS
#endif
status200
[ ("Content-Type", "SUBSITE")
] $ L8.pack $ show (pathInfo req)

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

@ -13,6 +13,11 @@ import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Char8 as S8
import Control.Exception (SomeException, try)
import Network.HTTP.Types (mkStatus)
import Blaze.ByteString.Builder (Builder, fromByteString, toLazyByteString)
import Data.Monoid (mconcat)
import Data.Text (Text, pack)
import Control.Monad (forM_)
import qualified Control.Exception.Lifted as E
data App = App
@ -24,6 +29,14 @@ mkYesod "App" [parseRoutes|
/error-in-body ErrorInBodyR GET
/error-in-body-noeval ErrorInBodyNoEvalR GET
/override-status OverrideStatusR GET
/error/#Int ErrorR GET
-- https://github.com/yesodweb/yesod/issues/658
/builder BuilderR GET
/file-bad-len FileBadLenR GET
/file-bad-name FileBadNameR GET
/good-builder GoodBuilderR GET
|]
overrideStatus = mkStatus 15 "OVERRIDE"
@ -74,6 +87,33 @@ getErrorInBodyNoEvalR = fmap DontFullyEvaluate getErrorInBodyR
getOverrideStatusR :: Handler ()
getOverrideStatusR = invalidArgs ["OVERRIDE"]
getBuilderR :: Handler TypedContent
getBuilderR = return $ TypedContent "ignored" $ ContentBuilder (error "builder-3.14159") Nothing
getFileBadLenR :: Handler TypedContent
getFileBadLenR = return $ TypedContent "ignored" $ ContentFile "yesod-core.cabal" (error "filebadlen")
getFileBadNameR :: Handler TypedContent
getFileBadNameR = return $ TypedContent "ignored" $ ContentFile (error "filebadname") Nothing
goodBuilderContent :: Builder
goodBuilderContent = mconcat $ replicate 100 $ fromByteString "This is a test\n"
getGoodBuilderR :: Handler TypedContent
getGoodBuilderR = return $ TypedContent "text/plain" $ toContent goodBuilderContent
getErrorR :: Int -> Handler ()
getErrorR 1 = setSession undefined "foo"
getErrorR 2 = setSession "foo" undefined
getErrorR 3 = deleteSession undefined
getErrorR 4 = addHeader undefined "foo"
getErrorR 5 = addHeader "foo" undefined
getErrorR 6 = expiresAt undefined
getErrorR 7 = setLanguage undefined
getErrorR 8 = cacheSeconds undefined
getErrorR 9 = setUltDest (undefined :: Text)
getErrorR 10 = setMessage undefined
errorHandlingTest :: Spec
errorHandlingTest = describe "Test.ErrorHandling" $ do
it "says not found" caseNotFound
@ -82,8 +122,13 @@ errorHandlingTest = describe "Test.ErrorHandling" $ do
it "error in body == 500" caseErrorInBody
it "error in body, no eval == 200" caseErrorInBodyNoEval
it "can override status code" caseOverrideStatus
it "builder" caseBuilder
it "file with bad len" caseFileBadLen
it "file with bad name" caseFileBadName
it "builder includes content-length" caseGoodBuilder
forM_ [1..10] $ \i -> it ("error case " ++ show i) (caseError i)
runner :: Session () -> IO ()
runner :: Session a -> IO a
runner f = toWaiApp App >>= runSession f
caseNotFound :: IO ()
@ -130,13 +175,45 @@ caseErrorInBody = runner $ do
caseErrorInBodyNoEval :: IO ()
caseErrorInBodyNoEval = do
eres <- try $ runner $ do
_ <- request defaultRequest { pathInfo = ["error-in-body-noeval"] }
return ()
request defaultRequest { pathInfo = ["error-in-body-noeval"] }
case eres of
Left (_ :: SomeException) -> return ()
Right _ -> error "Expected an exception"
Right x -> error $ "Expected an exception, got: " ++ show x
caseOverrideStatus :: IO ()
caseOverrideStatus = runner $ do
res <- request defaultRequest { pathInfo = ["override-status"] }
assertStatus 15 res
caseBuilder :: IO ()
caseBuilder = runner $ do
res <- request defaultRequest { pathInfo = ["builder"] }
assertStatus 500 res
assertBodyContains "builder-3.14159" res
caseFileBadLen :: IO ()
caseFileBadLen = runner $ do
res <- request defaultRequest { pathInfo = ["file-bad-len"] }
assertStatus 500 res
assertBodyContains "filebadlen" res
caseFileBadName :: IO ()
caseFileBadName = runner $ do
res <- request defaultRequest { pathInfo = ["file-bad-name"] }
assertStatus 500 res
assertBodyContains "filebadname" res
caseGoodBuilder :: IO ()
caseGoodBuilder = runner $ do
res <- request defaultRequest { pathInfo = ["good-builder"] }
assertStatus 200 res
let lbs = toLazyByteString goodBuilderContent
assertBody lbs res
assertHeader "content-length" (S8.pack $ show $ L.length lbs) res
caseError :: Int -> IO ()
caseError i = runner $ do
res <- request defaultRequest { pathInfo = ["error", pack $ show i] }
assertStatus 500 res `E.catch` \e -> do
liftIO $ print res
E.throwIO (e :: E.SomeException)

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

@ -12,6 +12,7 @@ import Data.Monoid (mempty)
import Data.Map (singleton)
import Yesod.Core
import Data.Word (Word64)
import System.IO.Unsafe (unsafePerformIO)
randomStringSpecs :: Spec
randomStringSpecs = describe "Yesod.Internal.Request.randomString" $ do
@ -36,7 +37,7 @@ parseWaiRequest' :: Request
-> Bool
-> Word64
-> YesodRequest
parseWaiRequest' a b c d =
parseWaiRequest' a b c d = unsafePerformIO $ -- ugly hack, just to ease migration, should be removed
case parseWaiRequest a b c (Just d) of
Left yreq -> yreq
Right needGen -> needGen g

2
yesod-core/test/YesodCoreTest/Json.hs
View File

@ -19,7 +19,7 @@ instance Yesod App
getHomeR :: Handler RepPlain
getHomeR = do
val <- parseJsonBody_
val <- requireJsonBody
case Map.lookup ("foo" :: Text) val of
Nothing -> invalidArgs ["foo not found"]
Just foo -> return $ RepPlain $ toContent (foo :: Text)

110
yesod-core/test/YesodCoreTest/RawResponse.hs Normal file
View File

@ -0,0 +1,110 @@
{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, TypeFamilies, MultiParamTypeClasses, ScopedTypeVariables #-}
module YesodCoreTest.RawResponse (specs, Widget) where
import Yesod.Core
import Test.Hspec
import qualified Data.Map as Map
import Network.Wai.Test
import Network.Wai (responseStream)
import Data.Text (Text)
import Data.ByteString.Lazy (ByteString)
import qualified Data.Conduit.List as CL
import qualified Data.ByteString.Char8 as S8
import Data.Conduit
import qualified Data.Conduit.Binary as CB
import Data.Char (toUpper)
import Control.Exception (try, IOException)
import Data.Conduit.Network
import Network.Socket (sClose)
import Control.Concurrent (threadDelay)
import Control.Concurrent.Async (withAsync)
import Control.Monad.Trans.Resource (register)
import Data.IORef
import Data.Streaming.Network (bindPortTCP)
import Network.HTTP.Types (status200)
import Blaze.ByteString.Builder (fromByteString)
data App = App
mkYesod "App" [parseRoutes|
/ HomeR GET
/wai-stream WaiStreamR GET
/wai-app-stream WaiAppStreamR GET
|]
instance Yesod App
getHomeR :: Handler ()
getHomeR = do
ref <- liftIO $ newIORef 0
_ <- register $ writeIORef ref 1
sendRawResponse $ \src sink -> liftIO $ do
val <- readIORef ref
yield (S8.pack $ show val) $$ sink
src $$ CL.map (S8.map toUpper) =$ sink
getWaiStreamR :: Handler ()
getWaiStreamR = sendWaiResponse $ responseStream status200 [] $ \send flush -> do
flush
send $ fromByteString "hello"
flush
send $ fromByteString " world"
getWaiAppStreamR :: Handler ()
getWaiAppStreamR = sendWaiApplication $ \_ f -> f $ responseStream status200 [] $ \send flush -> do
flush
send $ fromByteString "hello"
flush
send $ fromByteString " world"
getFreePort :: IO Int
getFreePort = do
loop 43124
where
loop port = do
esocket <- try $ bindPortTCP port "*"
case esocket of
Left (_ :: IOException) -> loop (succ port)
Right socket -> do
sClose socket
return port
specs :: Spec
specs = do
describe "RawResponse" $ do
it "works" $ do
port <- getFreePort
withAsync (warp port App) $ \_ -> do
threadDelay 100000
runTCPClient (clientSettings port "127.0.0.1") $ \ad -> do
yield "GET / HTTP/1.1\r\n\r\nhello" $$ appSink ad
(appSource ad $$ CB.take 6) >>= (`shouldBe` "0HELLO")
yield "WORLd" $$ appSink ad
(appSource ad $$ await) >>= (`shouldBe` Just "WORLD")
let body req = do
port <- getFreePort
withAsync (warp port App) $ \_ -> do
threadDelay 100000
runTCPClient (clientSettings port "127.0.0.1") $ \ad -> do
yield req $$ appSink ad
appSource ad $$ CB.lines =$ do
let loop = do
x <- await
case x of
Nothing -> return ()
Just "\r" -> return ()
_ -> loop
loop
Just "0005\r" <- await
Just "hello\r" <- await
Just "0006\r" <- await
Just " world\r" <- await
return ()
it "sendWaiResponse + responseStream" $ do
body "GET /wai-stream HTTP/1.1\r\n\r\n"
it "sendWaiApplication + responseStream" $ do
body "GET /wai-app-stream HTTP/1.1\r\n\r\n"

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

@ -7,7 +7,7 @@ import qualified Network.HTTP.Types as H
data Y = Y
mkYesod "Y" [parseRoutes|
/ RootR GET
/ RootR GET POST
/r301 R301 GET
/r303 R303 GET
/r307 R307 GET
@ -20,6 +20,9 @@ app = yesod Y
getRootR :: Handler ()
getRootR = return ()
postRootR :: Handler ()
postRootR = return ()
getR301, getR303, getR307, getRRegular :: Handler ()
getR301 = redirectWith H.status301 RootR
getR303 = redirectWith H.status303 RootR
@ -28,6 +31,11 @@ getRRegular = redirect RootR
specs :: Spec
specs = describe "Redirect" $ do
it "no redirect" $ app $ do
res <- request defaultRequest { pathInfo = [], requestMethod = "POST" }
assertStatus 200 res
assertBodyContains "" res
it "301 redirect" $ app $ do
res <- request defaultRequest { pathInfo = ["r301"] }
assertStatus 301 res
@ -45,7 +53,8 @@ specs = describe "Redirect" $ do
it "303 redirect for regular, HTTP 1.1" $ app $ do
res <- request defaultRequest {
pathInfo = ["rregular"]
pathInfo = ["rregular"],
httpVersion = H.http11
}
assertStatus 303 res
assertBodyContains "" res

4
yesod-core/test/YesodCoreTest/RequestBodySize.hs
View File

@ -83,8 +83,8 @@ specs :: Spec
specs = describe "Test.RequestBodySize" $ do
caseHelper "lookupPostParam- large" "post" "foobarbaz=bin" 413 413
caseHelper "lookupPostParam- small" "post" "foo=bin" 200 200
caseHelper "consume- large" "consume" "this is longer than 10" 413 413
caseHelper "consume- small" "consume" "smaller" 200 200
caseHelper "total consume- large" "consume" "this is longer than 10" 413 413
caseHelper "total consume- small" "consume" "smaller" 200 200
caseHelper "partial consume- large" "partial-consume" "this is longer than 10" 200 413
caseHelper "partial consume- small" "partial-consume" "smaller" 200 200
caseHelper "unused- large" "unused" "this is longer than 10" 200 413

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

@ -1,4 +1,4 @@
{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies, MultiParamTypeClasses, OverloadedStrings #-}
{-# LANGUAGE CPP, QuasiQuotes, TemplateHaskell, TypeFamilies, MultiParamTypeClasses, OverloadedStrings #-}
module YesodCoreTest.WaiSubsite (specs, Widget) where
import YesodCoreTest.YesodTest
@ -6,7 +6,11 @@ import Yesod.Core
import qualified Network.HTTP.Types as H
myApp :: Application
#if MIN_VERSION_wai(3, 0, 0)
myApp _ f = f $ responseLBS H.status200 [("Content-type", "text/plain")] "WAI"
#else
myApp _ = return $ responseLBS H.status200 [("Content-type", "text/plain")] "WAI"
#endif
getApp :: a -> WaiSubsite
getApp _ = WaiSubsite myApp

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

@ -1,5 +1,5 @@
name: yesod-core
version: 1.2.4
version: 1.2.17
license: MIT
license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com>
@ -26,28 +26,28 @@ library
build-depends: base >= 4.3 && < 5
, time >= 1.1.4
, yesod-routes >= 1.2 && < 1.3
, wai >= 1.4 && < 1.5
, wai-extra >= 1.3 && < 1.4
, wai >= 1.4
, wai-extra >= 1.3
, bytestring >= 0.9.1.4
, text >= 0.7 && < 0.12
, text >= 0.7
, template-haskell
, path-pieces >= 0.1.2 && < 0.2
, hamlet >= 1.1 && < 1.2
, shakespeare >= 1.0 && < 1.1
, shakespeare-js >= 1.0.2 && < 1.2
, shakespeare-css >= 1.0 && < 1.1
, shakespeare-i18n >= 1.0 && < 1.1
, hamlet >= 1.1
, shakespeare >= 1.0 && < 2.1
, shakespeare-js >= 1.0.2
, shakespeare-css >= 1.0
, shakespeare-i18n >= 1.0
, blaze-builder >= 0.2.1.4 && < 0.4
, transformers >= 0.2.2 && < 0.4
, transformers >= 0.2.2
, mtl
, clientsession >= 0.9 && < 0.10
, random >= 1.0.0.2 && < 1.1
, cereal >= 0.3 && < 0.4
, cereal >= 0.3
, old-locale >= 1.0.0.2 && < 1.1
, failure >= 0.2 && < 0.3
, containers >= 0.2
, monad-control >= 0.3 && < 0.4
, transformers-base >= 0.4
, cookie >= 0.4 && < 0.5
, cookie >= 0.4.1 && < 0.5
, http-types >= 0.7
, case-insensitive >= 0.2
, parsec >= 2 && < 3.2
@ -55,9 +55,10 @@ library
, vector >= 0.9 && < 0.11
, aeson >= 0.5
, fast-logger >= 0.2
, wai-logger >= 0.2
, monad-logger >= 0.3.1 && < 0.4
, conduit >= 0.5
, resourcet >= 0.4.6 && < 0.5
, conduit >= 1.0.11
, resourcet >= 0.4.9 && < 1.2
, lifted-base >= 0.1.2
, attoparsec-conduit
, blaze-html >= 0.5
@ -65,6 +66,10 @@ library
, data-default
, safe
, warp >= 1.3.8
, unix-compat
, conduit-extra
, exceptions
, deepseq
exposed-modules: Yesod.Core
Yesod.Core.Content
@ -91,6 +96,9 @@ library
-- This looks like a GHC bug
extensions: MultiParamTypeClasses
-- Workaround for: http://ghc.haskell.org/trac/ghc/ticket/8443
extensions: TemplateHaskell
test-suite tests
type: exitcode-stdio-1.0
main-is: test.hs
@ -100,7 +108,7 @@ test-suite tests
build-depends: base
,hspec >= 1.3
,wai-test >= 1.3.0.5
,wai
,wai >= 3.0
,yesod-core
,bytestring
,hamlet
@ -117,7 +125,29 @@ test-suite tests
, containers
, lifted-base
, resourcet
, network-conduit
, network
, async
, conduit-extra
, shakespeare
, streaming-commons
, wai-extra
ghc-options: -Wall
extensions: TemplateHaskell
benchmark widgets
type: exitcode-stdio-1.0
hs-source-dirs: bench
build-depends: base
, criterion
, bytestring
, text
, hamlet
, transformers
, yesod-core
, blaze-html
main-is: widget.hs
ghc-options: -Wall -O2
source-repository head
type: git

13
yesod-eventsource/Yesod/EventSource.hs
View File

@ -46,7 +46,18 @@ repEventSource :: (EventSourcePolyfill -> C.Source (HandlerT site IO) ES.ServerE
-> HandlerT site IO TypedContent
repEventSource src =
prepareForEventSource >>=
respondEventStream . ES.sourceToSource . src
respondEventStream . sourceToSource . src
-- | Convert a ServerEvent source into a Builder source of serialized
-- events.
sourceToSource :: Monad m => C.Source m ES.ServerEvent -> C.Source m (C.Flush Builder)
sourceToSource src =
src C.$= C.awaitForever eventToFlushBuilder
where
eventToFlushBuilder event =
case ES.eventToBuilder event of
Nothing -> return ()
Just x -> C.yield (C.Chunk x) >> C.yield C.Flush
-- | Return a Server-Sent Event stream given a 'HandlerT' action

9
yesod-eventsource/yesod-eventsource.cabal
View File

@ -1,5 +1,5 @@
name: yesod-eventsource
version: 1.1
version: 1.1.1
license: MIT
license-file: LICENSE
author: Felipe Lessa <felipe.lessa@gmail.com>
@ -29,9 +29,10 @@ description:
library
build-depends: base >= 4 && < 5
, yesod-core == 1.2.*
, conduit >= 0.5 && < 1.1
, wai >= 1.3 && < 1.5
, wai-eventsource >= 1.3 && < 1.4
, conduit >= 0.5 && < 1.2
, wai >= 1.3
, wai-eventsource >= 1.3
, wai-extra
, blaze-builder
, transformers
exposed-modules: Yesod.EventSource

262
yesod-form/Yesod/Form/Bootstrap3.hs Normal file
View File

@ -0,0 +1,262 @@
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE OverloadedStrings #-}
-- | Helper functions for creating forms when using Bootstrap v3.
module Yesod.Form.Bootstrap3
( -- * Rendering forms
renderBootstrap3
, BootstrapFormLayout(..)
, BootstrapGridOptions(..)
-- * Field settings
, bfs
, withPlaceholder
, withAutofocus
, withLargeInput
, withSmallInput
-- * Submit button
, bootstrapSubmit
, mbootstrapSubmit
, BootstrapSubmit(..)
) where
import Control.Arrow (second)
import Control.Monad (liftM)
import Data.Text (Text)
import Data.String (IsString(..))
import Yesod.Core
import qualified Data.Text as T
import Yesod.Form.Types
import Yesod.Form.Functions
-- | Create a new 'FieldSettings' with the classes that are
-- required by Bootstrap v3.
--
-- Since: yesod-form 1.3.8
bfs :: RenderMessage site msg => msg -> FieldSettings site
bfs msg =
FieldSettings (SomeMessage msg) Nothing Nothing Nothing [("class", "form-control")]
-- | Add a placeholder attribute to a field. If you need i18n
-- for the placeholder, currently you\'ll need to do a hack and
-- use 'getMessageRender' manually.
--
-- Since: yesod-form 1.3.8
withPlaceholder :: Text -> FieldSettings site -> FieldSettings site
withPlaceholder placeholder fs = fs { fsAttrs = newAttrs }
where newAttrs = ("placeholder", placeholder) : fsAttrs fs
-- | Add an autofocus attribute to a field.
--
-- Since: yesod-form 1.3.8
withAutofocus :: FieldSettings site -> FieldSettings site
withAutofocus fs = fs { fsAttrs = newAttrs }
where newAttrs = ("autofocus", "autofocus") : fsAttrs fs
-- | Add the @input-lg@ CSS class to a field.
--
-- Since: yesod-form 1.3.8
withLargeInput :: FieldSettings site -> FieldSettings site
withLargeInput fs = fs { fsAttrs = newAttrs }
where newAttrs = addClass "input-lg" (fsAttrs fs)
-- | Add the @input-sm@ CSS class to a field.
--
-- Since: yesod-form 1.3.8
withSmallInput :: FieldSettings site -> FieldSettings site
withSmallInput fs = fs { fsAttrs = newAttrs }
where newAttrs = addClass "input-sm" (fsAttrs fs)
addClass :: Text -> [(Text, Text)] -> [(Text, Text)]
addClass klass [] = [("class", klass)]
addClass klass (("class", old):rest) = ("class", T.concat [old, " ", klass]) : rest
addClass klass (other :rest) = other : addClass klass rest
-- | How many bootstrap grid columns should be taken (see
-- 'BootstrapFormLayout').
--
-- Since: yesod-form 1.3.8
data BootstrapGridOptions =
ColXs !Int
| ColSm !Int
| ColMd !Int
| ColLg !Int
deriving (Eq, Ord, Show)
toColumn :: BootstrapGridOptions -> String
toColumn (ColXs 0) = ""
toColumn (ColSm 0) = ""
toColumn (ColMd 0) = ""
toColumn (ColLg 0) = ""
toColumn (ColXs columns) = "col-xs-" ++ show columns
toColumn (ColSm columns) = "col-sm-" ++ show columns
toColumn (ColMd columns) = "col-md-" ++ show columns
toColumn (ColLg columns) = "col-lg-" ++ show columns
toOffset :: BootstrapGridOptions -> String
toOffset (ColXs 0) = ""
toOffset (ColSm 0) = ""
toOffset (ColMd 0) = ""
toOffset (ColLg 0) = ""
toOffset (ColXs columns) = "col-xs-offset-" ++ show columns
toOffset (ColSm columns) = "col-sm-offset-" ++ show columns
toOffset (ColMd columns) = "col-md-offset-" ++ show columns
toOffset (ColLg columns) = "col-lg-offset-" ++ show columns
addGO :: BootstrapGridOptions -> BootstrapGridOptions -> BootstrapGridOptions
addGO (ColXs a) (ColXs b) = ColXs (a+b)
addGO (ColSm a) (ColSm b) = ColSm (a+b)
addGO (ColMd a) (ColMd b) = ColMd (a+b)
addGO (ColLg a) (ColLg b) = ColLg (a+b)
addGO a b | a > b = addGO b a
addGO (ColXs a) other = addGO (ColSm a) other
addGO (ColSm a) other = addGO (ColMd a) other
addGO (ColMd a) other = addGO (ColLg a) other
addGO (ColLg _) _ = error "Yesod.Form.Bootstrap.addGO: never here"
-- | The layout used for the bootstrap form.
--
-- Since: yesod-form 1.3.8
data BootstrapFormLayout =
BootstrapBasicForm
| BootstrapInlineForm
| BootstrapHorizontalForm
{ bflLabelOffset :: !BootstrapGridOptions
, bflLabelSize :: !BootstrapGridOptions
, bflInputOffset :: !BootstrapGridOptions
, bflInputSize :: !BootstrapGridOptions
}
deriving (Show)
-- | Render the given form using Bootstrap v3 conventions.
--
-- Sample Hamlet for 'BootstrapHorizontalForm':
--
-- > <form .form-horizontal role=form method=post action=@{ActionR} enctype=#{formEnctype}>
-- > ^{formWidget}
-- > ^{bootstrapSubmit MsgSubmit}
--
-- Since: yesod-form 1.3.8
renderBootstrap3 :: Monad m => BootstrapFormLayout -> FormRender m a
renderBootstrap3 formLayout aform fragment = do
(res, views') <- aFormToForm aform
let views = views' []
has (Just _) = True
has Nothing = False
widget = [whamlet|
$newline never
#{fragment}
$forall view <- views
<div .form-group :fvRequired view:.required :not $ fvRequired view:.optional :has $ fvErrors view:.has-error>
$case formLayout
$of BootstrapBasicForm
$if fvId view /= bootstrapSubmitId
<label for=#{fvId view}>#{fvLabel view}
^{fvInput view}
^{helpWidget view}
$of BootstrapInlineForm
$if fvId view /= bootstrapSubmitId
<label .sr-only for=#{fvId view}>#{fvLabel view}
^{fvInput view}
^{helpWidget view}
$of BootstrapHorizontalForm labelOffset labelSize inputOffset inputSize
$if fvId view /= bootstrapSubmitId
<label .control-label .#{toOffset labelOffset} .#{toColumn labelSize} for=#{fvId view}>#{fvLabel view}
<div .#{toOffset inputOffset} .#{toColumn inputSize}>
^{fvInput view}
^{helpWidget view}
$else
<div .#{toOffset (addGO inputOffset (addGO labelOffset labelSize))} .#{toColumn inputSize}>
^{fvInput view}
^{helpWidget view}
|]
return (res, widget)
-- | (Internal) Render a help widget for tooltips and errors.
helpWidget :: FieldView site -> WidgetT site IO ()
helpWidget view = [whamlet|
$maybe tt <- fvTooltip view
<span .help-block>#{tt}
$maybe err <- fvErrors view
<span .help-block>#{err}
|]
-- | How the 'bootstrapSubmit' button should be rendered.
--
-- Since: yesod-form 1.3.8
data BootstrapSubmit msg =
BootstrapSubmit
{ bsValue :: msg
-- ^ The text of the submit button.
, bsClasses :: Text
-- ^ Classes added to the @<button>@.
, bsAttrs :: [(Text, Text)]
-- ^ Attributes added to the @<button>@.
} deriving (Show)
instance IsString msg => IsString (BootstrapSubmit msg) where
fromString msg = BootstrapSubmit (fromString msg) " btn-default " []
-- | A Bootstrap v3 submit button disguised as a field for
-- convenience. For example, if your form currently is:
--
-- > Person <$> areq textField "Name" Nothing
-- > <*> areq textField "Surname" Nothing
--
-- Then just change it to:
--
-- > Person <$> areq textField "Name" Nothing
-- > <*> areq textField "Surname" Nothing
-- > <* bootstrapSubmit "Register"
--
-- (Note that @<*@ is not a typo.)
--
-- Alternatively, you may also just create the submit button
-- manually as well in order to have more control over its
-- layout.
--
-- Since: yesod-form 1.3.8
bootstrapSubmit
:: (RenderMessage site msg, HandlerSite m ~ site, MonadHandler m)
=> BootstrapSubmit msg -> AForm m ()
bootstrapSubmit = formToAForm . liftM (second return) . mbootstrapSubmit
-- | Same as 'bootstrapSubmit' but for monadic forms. This isn't
-- as useful since you're not going to use 'renderBootstrap3'
-- anyway.
--
-- Since: yesod-form 1.3.8
mbootstrapSubmit
:: (RenderMessage site msg, HandlerSite m ~ site, MonadHandler m)
=> BootstrapSubmit msg -> MForm m (FormResult (), FieldView site)
mbootstrapSubmit (BootstrapSubmit msg classes attrs) =
let res = FormSuccess ()
widget = [whamlet|<button class="btn #{classes}" type=submit *{attrs}>_{msg}|]
fv = FieldView { fvLabel = ""
, fvTooltip = Nothing
, fvId = bootstrapSubmitId
, fvInput = widget
, fvErrors = Nothing
, fvRequired = False }
in return (res, fv)
-- | A royal hack. Magic id used to identify whether a field
-- should have no label. A valid HTML4 id which is probably not
-- going to clash with any other id should someone use
-- 'bootstrapSubmit' outside 'renderBootstrap3'.
bootstrapSubmitId :: Text
bootstrapSubmitId = "b:ootstrap___unique__:::::::::::::::::submit-id"

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

@ -18,6 +18,7 @@ module Yesod.Form.Fields
, timeField
, htmlField
, emailField
, multiEmailField
, searchField
, AutoFocus
, urlField
@ -36,12 +37,15 @@ module Yesod.Form.Fields
, selectFieldList
, radioField
, radioFieldList
, checkboxesFieldList
, checkboxesField
, multiSelectField
, multiSelectFieldList
, Option (..)
, OptionList (..)
, mkOptionList
, optionsPersist
, optionsPersistKey
, optionsPairs
, optionsEnum
) where
@ -61,10 +65,11 @@ import qualified Text.Email.Validate as Email
import Data.Text.Encoding (encodeUtf8, decodeUtf8With)
import Data.Text.Encoding.Error (lenientDecode)
import Network.URI (parseURI)
import Database.Persist.Sql (PersistField, PersistFieldSql)
import Database.Persist (Entity (..))
import Database.Persist.Sql (PersistField, PersistFieldSql (..))
import Database.Persist (Entity (..), SqlType (SqlString))
import Text.HTML.SanitizeXSS (sanitizeBalance)
import Control.Monad (when, unless)
import Data.Either (partitionEithers)
import Data.Maybe (listToMaybe, fromMaybe)
import qualified Blaze.ByteString.Builder.Html.Utf8 as B
@ -75,17 +80,22 @@ import Database.Persist (PersistMonadBackend, PersistEntityBackend)
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)
import Data.Text as T ( Text, append, concat, cons, head
, intercalate, isPrefixOf, null, unpack, pack, splitOn
)
import qualified Data.Text as T (drop, dropWhile)
import qualified Data.Text.Read
import qualified Data.Map as Map
import Yesod.Persist (selectList, runDB, Filter, SelectOpt, Key, YesodPersist, PersistEntity, PersistQuery, YesodDB)
import Yesod.Persist (selectList, runDB, Filter, SelectOpt, Key, YesodPersist, PersistEntity, PersistQuery)
import Control.Arrow ((&&&))
import Control.Applicative ((<$>), (<|>))
import Data.Attoparsec.Text (Parser, char, string, digit, skipSpace, endOfInput, parseOnly)
import Yesod.Persist.Core
defaultFormMessage :: FormMessage -> Text
defaultFormMessage = englishFormMessage
@ -99,7 +109,7 @@ intField = Field
, fieldView = \theId name attrs val isReq -> toWidget [hamlet|
$newline never
<input id="#{theId}" name="#{name}" *{attrs} type="number" :isReq:required="" value="#{showVal val}">
<input id="#{theId}" name="#{name}" *{attrs} type="number" step=1 :isReq:required="" value="#{showVal val}">
|]
, fieldEnctype = UrlEncoded
}
@ -110,13 +120,13 @@ $newline never
doubleField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Double
doubleField = Field
{ fieldParse = parseHelper $ \s ->
case Data.Text.Read.double s of
case Data.Text.Read.double (prependZero 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}">
<input id="#{theId}" name="#{name}" *{attrs} type="number" step=any :isReq:required="" value="#{showVal val}">
|]
, fieldEnctype = UrlEncoded
}
@ -163,7 +173,9 @@ $newline never
-- | A newtype wrapper around a 'Text' that converts newlines to HTML
-- br-tags.
newtype Textarea = Textarea { unTextarea :: Text }
deriving (Show, Read, Eq, PersistField, PersistFieldSql, Ord)
deriving (Show, Read, Eq, PersistField, Ord, ToJSON, FromJSON)
instance PersistFieldSql Textarea where
sqlType _ = SqlString
instance ToHtml Textarea where
toHtml =
unsafeByteString
@ -295,12 +307,37 @@ $newline never
, fieldEnctype = UrlEncoded
}
-- |
--
-- Since 1.3.7
multiEmailField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m [Text]
multiEmailField = Field
{ fieldParse = parseHelper $
\s ->
let addrs = map validate $ splitOn "," s
in case partitionEithers addrs of
([], good) -> Right good
(bad, _) -> Left $ MsgInvalidEmail $ cat bad
, fieldView = \theId name attrs val isReq -> toWidget [hamlet|
$newline never
<input id="#{theId}" name="#{name}" *{attrs} type="email" multiple :isReq:required="" value="#{either id cat val}">
|]
, fieldEnctype = UrlEncoded
}
where
-- report offending address along with error
validate a = case Email.validate $ encodeUtf8 a of
Left e -> Left $ T.concat [a, " (", pack e, ")"]
Right r -> Right $ emailToText r
cat = intercalate ", "
emailToText = decodeUtf8With lenientDecode . Email.toByteString
type AutoFocus = Bool
searchField :: Monad m => RenderMessage (HandlerSite m) FormMessage => AutoFocus -> Field m Text
searchField autoFocus = Field
{ fieldParse = parseHelper Right
, fieldView = \theId name attrs val isReq -> do
[whamlet|\
[whamlet|
$newline never
<input id="#{theId}" name="#{name}" *{attrs} type="search" :isReq:required="" :autoFocus:autofocus="" value="#{either id id val}">
|]
@ -385,6 +422,28 @@ radioFieldList :: (Eq a, RenderMessage site FormMessage, RenderMessage site msg)
-> Field (HandlerT site IO) a
radioFieldList = radioField . optionsPairs
checkboxesFieldList :: (Eq a, RenderMessage site FormMessage, RenderMessage site msg) => [(msg, a)]
-> Field (HandlerT site IO) [a]
checkboxesFieldList = checkboxesField . optionsPairs
checkboxesField :: (Eq a, RenderMessage site FormMessage)
=> HandlerT site IO (OptionList a)
-> Field (HandlerT site IO) [a]
checkboxesField ioptlist = (multiSelectField ioptlist)
{ fieldView =
\theId name attrs val isReq -> do
opts <- fmap olOptions $ handlerToWidget ioptlist
let optselected (Left _) _ = False
optselected (Right vals) opt = (optionInternalValue opt) `elem` vals
[whamlet|
<span ##{theId}>
$forall opt <- opts
<label>
<input type=checkbox name=#{name} value=#{optionExternalValue opt} *{attrs} :optselected val opt:checked>
#{optionDisplay opt}
|]
}
radioField :: (Eq a, RenderMessage site FormMessage)
=> HandlerT site IO (OptionList a)
-> Field (HandlerT site IO) a
@ -434,6 +493,8 @@ $newline never
"yes" -> Right $ Just True
"on" -> Right $ Just True
"no" -> Right $ Just False
"true" -> Right $ Just True
"false" -> Right $ Just False
t -> Left $ SomeMessage $ MsgInvalidBool t
showVal = either (\_ -> False)
@ -495,9 +556,9 @@ optionsEnum :: (MonadHandler m, Show a, Enum a, Bounded a) => m (OptionList a)
optionsEnum = optionsPairs $ map (\x -> (pack $ show x, x)) [minBound..maxBound]
optionsPersist :: ( YesodPersist site, PersistEntity a
, PersistQuery (YesodDB site)
, PersistQuery (YesodPersistBackend site (HandlerT site IO))
, PathPiece (Key a)
, PersistEntityBackend a ~ PersistMonadBackend (YesodDB site)
, PersistEntityBackend a ~ PersistMonadBackend (YesodPersistBackend site (HandlerT site IO))
, RenderMessage site msg
)
=> [Filter a]
@ -513,6 +574,31 @@ optionsPersist filts ords toDisplay = fmap mkOptionList $ do
, optionExternalValue = toPathPiece key
}) pairs
-- | An alternative to 'optionsPersist' which returns just the @Key@ instead of
-- the entire @Entity@.
--
-- Since 1.3.2
optionsPersistKey
:: (YesodPersist site
, PersistEntity a
, PersistQuery (YesodPersistBackend site (HandlerT site IO))
, PathPiece (Key a)
, RenderMessage site msg
, PersistEntityBackend a ~ PersistMonadBackend (YesodPersistBackend site (HandlerT site IO)))
=> [Filter a]
-> [SelectOpt a]
-> (a -> msg)
-> HandlerT site IO (OptionList (Key a))
optionsPersistKey filts ords toDisplay = fmap mkOptionList $ do
mr <- getMessageRender
pairs <- runDB $ selectList filts ords
return $ map (\(Entity key value) -> Option
{ optionDisplay = mr (toDisplay value)
, optionInternalValue = key
, optionExternalValue = toPathPiece key
}) pairs
selectFieldHelper
:: (Eq a, RenderMessage site FormMessage)
=> (Text -> Text -> [(Text, Text)] -> WidgetT site IO () -> WidgetT site IO ())
@ -531,7 +617,7 @@ selectFieldHelper outside onOpt inside opts' = Field
flip mapM_ opts $ \opt -> inside
theId
name
attrs
((if isReq then (("required", "required"):) else id) attrs)
(optionExternalValue opt)
((render opts val) == optionExternalValue opt)
(optionDisplay opt)
@ -628,3 +714,19 @@ $newline never
incrInts :: Ints -> Ints
incrInts (IntSingle i) = IntSingle $ i + 1
incrInts (IntCons i is) = (i + 1) `IntCons` is
-- | Adds a '0' to some text so that it may be recognized as a double.
-- The read ftn does not recognize ".3" as 0.3 nor "-.3" as -0.3, so this
-- function changes ".xxx" to "0.xxx" and "-.xxx" to "-0.xxx"
prependZero :: Text -> Text
prependZero t0 = if T.null t1
then t1
else if T.head t1 == '.'
then '0' `T.cons` t1
else if "-." `T.isPrefixOf` t1
then "-0." `T.append` (T.drop 2 t1)
else t1
where t1 = T.dropWhile ((==) ' ') t0

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

@ -23,7 +23,10 @@ module Yesod.Form.Functions
, runFormGet
-- * Generate a blank form
, generateFormPost
, generateFormGet'
, generateFormGet
-- * More than one form on a handler
, identifyForm
-- * Rendering
, FormRender
, renderTable
@ -39,15 +42,16 @@ module Yesod.Form.Functions
-- * Utilities
, fieldSettingsLabel
, parseHelper
, parseHelperGen
) where
import Yesod.Form.Types
import Data.Text (Text, pack)
import Control.Arrow (second)
import Control.Monad.Trans.RWS (ask, get, put, runRWST, tell, evalRWST)
import Control.Monad.Trans.RWS (ask, get, put, runRWST, tell, evalRWST, local)
import Control.Monad.Trans.Class
import Control.Monad (liftM, join)
import Crypto.Classes (constTimeEq)
import Data.Byteable (constEqBytes)
import Text.Blaze (Markup, toMarkup)
#define Html Markup
#define toHtml toMarkup
@ -99,13 +103,18 @@ askFiles = do
(x, _, _) <- ask
return $ liftM snd x
-- | Converts a form field into monadic form. This field requires a value
-- and will return 'FormFailure' if left empty.
mreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
=> Field m a
-> FieldSettings site
-> Maybe a
=> Field m a -- ^ form field
-> FieldSettings site -- ^ settings for this field
-> Maybe a -- ^ optional default value
-> MForm m (FormResult a, FieldView site)
mreq field fs mdef = mhelper field fs mdef (\m l -> FormFailure [renderMessage m l MsgValueRequired]) FormSuccess True
-- | Converts a form field into monadic form. This field is optional, i.e.
-- if filled in, it returns 'Just a', if left empty, it returns 'Nothing'.
-- Arguments are the same as for 'mreq' (apart from type of default value).
mopt :: (site ~ HandlerSite m, MonadHandler m)
=> Field m a
-> FieldSettings site
@ -155,6 +164,7 @@ mhelper Field {..} FieldSettings {..} mdef onMissing onFound isReq = do
, fvRequired = isReq
})
-- | Applicative equivalent of 'mreq'.
areq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
=> Field m a
-> FieldSettings site
@ -162,6 +172,7 @@ areq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
-> AForm m a
areq a b = formToAForm . liftM (second return) . mreq a b
-- | Applicative equivalent of 'mopt'.
aopt :: MonadHandler m
=> Field m a
-> FieldSettings (HandlerSite m)
@ -175,7 +186,7 @@ runFormGeneric :: Monad m
-> [Text]
-> Maybe (Env, FileEnv)
-> m (a, Enctype)
runFormGeneric form site langs env = evalRWST form (env, site, langs) (IntSingle 1)
runFormGeneric form site langs env = evalRWST form (env, site, langs) (IntSingle 0)
-- | This function is used to both initially render a form and to later extract
-- results from it. Note that, due to CSRF protection and a few other issues,
@ -213,12 +224,12 @@ postHelper form env = do
| 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
where (Just [t1]) === (Just t2) = TE.encodeUtf8 t1 `constEqBytes` 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
-- | Similar to 'runFormPost', except it always ignores the currently available
-- environment. This is necessary in cases like a wizard UI, where a single
-- page will both receive and incoming form and produce a new, blank form. For
-- general usage, you can stick with @runFormPost@.
@ -259,6 +270,17 @@ runFormGet form = do
Just _ -> Just (Map.unionsWith (++) $ map (\(x, y) -> Map.singleton x [y]) gets, Map.empty)
getHelper form env
{- FIXME: generateFormGet' "Will be renamed to generateFormGet in next verison of Yesod" -}
-- |
--
-- Since 1.3.11
generateFormGet'
:: (RenderMessage (HandlerSite m) FormMessage, MonadHandler m)
=> (Html -> MForm m (FormResult a, xml))
-> m (xml, Enctype)
generateFormGet' form = first snd `liftM` getHelper form Nothing
{-# DEPRECATED generateFormGet "Will require RenderMessage in next verison of Yesod" #-}
generateFormGet :: MonadHandler m
=> (Html -> MForm m a)
-> m (a, Enctype)
@ -277,6 +299,57 @@ getHelper form env = do
m <- getYesod
runFormGeneric (form fragment) m langs env
-- | Creates a hidden field on the form that identifies it. This
-- identification is then used to distinguish between /missing/
-- and /wrong/ form data when a single handler contains more than
-- one form.
--
-- For instance, if you have the following code on your handler:
--
-- > ((fooRes, fooWidget), fooEnctype) <- runFormPost fooForm
-- > ((barRes, barWidget), barEnctype) <- runFormPost barForm
--
-- Then replace it with
--
-- > ((fooRes, fooWidget), fooEnctype) <- runFormPost $ identifyForm "foo" fooForm
-- > ((barRes, barWidget), barEnctype) <- runFormPost $ identifyForm "bar" barForm
--
-- Note that it's your responsibility to ensure that the
-- identification strings are unique (using the same one twice on a
-- single handler will not generate any errors). This allows you
-- to create a variable number of forms and still have them work
-- even if their number or order change between the HTML
-- generation and the form submission.
identifyForm
:: Monad m
=> Text -- ^ Form identification string.
-> (Html -> MForm m (FormResult a, WidgetT (HandlerSite m) IO ()))
-> (Html -> MForm m (FormResult a, WidgetT (HandlerSite m) IO ()))
identifyForm identVal form = \fragment -> do
-- Create hidden <input>.
let fragment' =
[shamlet|
<input type=hidden name=#{identifyFormKey} value=#{identVal}>
#{fragment}
|]
-- Check if we got its value back.
mp <- askParams
let missing = (mp >>= Map.lookup identifyFormKey) /= Just [identVal]
-- Run the form proper (with our hidden <input>). If the
-- data is missing, then do not provide any params to the
-- form, which will turn its result into FormMissing. Also,
-- doing this avoids having lots of fields with red errors.
let eraseParams | missing = local (\(_, h, l) -> (Nothing, h, l))
| otherwise = id
eraseParams (form fragment')
identifyFormKey :: Text
identifyFormKey = "_formid"
type FormRender m a =
AForm m a
-> Html
@ -326,7 +399,9 @@ $forall view <- views
|]
return (res, widget)
-- | Render a form using Bootstrap-friendly shamlet syntax.
-- | Render a form using Bootstrap v2-friendly shamlet syntax.
-- If you're using Bootstrap v3, then you should use the
-- functions from module "Yesod.Form.Bootstrap3".
--
-- Sample Hamlet:
--
@ -361,6 +436,7 @@ renderBootstrap aform fragment = do
<span .help-block>#{err}
|]
return (res, widget)
{-# DEPRECATED renderBootstrap "Please use the Yesod.Form.Bootstrap3 module." #-}
check :: (Monad m, RenderMessage (HandlerSite m) msg)
=> (a -> Either msg a)
@ -421,6 +497,15 @@ fieldSettingsLabel msg = FieldSettings (SomeMessage msg) Nothing Nothing Nothing
parseHelper :: (Monad m, RenderMessage site FormMessage)
=> (Text -> Either FormMessage a)
-> [Text] -> [FileInfo] -> m (Either (SomeMessage site) (Maybe a))
parseHelper _ [] _ = return $ Right Nothing
parseHelper _ ("":_) _ = return $ Right Nothing
parseHelper f (x:_) _ = return $ either (Left . SomeMessage) (Right . Just) $ f x
parseHelper = parseHelperGen
-- | A generalized version of 'parseHelper', allowing any type for the message
-- indicating a bad parse.
--
-- Since 1.3.6
parseHelperGen :: (Monad m, RenderMessage site msg)
=> (Text -> Either msg a)
-> [Text] -> [FileInfo] -> m (Either (SomeMessage site) (Maybe a))
parseHelperGen _ [] _ = return $ Right Nothing
parseHelperGen _ ("":_) _ = return $ Right Nothing
parseHelperGen f (x:_) _ = return $ either (Left . SomeMessage) (Right . Just) $ f x

22
yesod-form/Yesod/Form/Input.hs
View File

@ -4,6 +4,7 @@ module Yesod.Form.Input
( FormInput (..)
, runInputGet
, runInputPost
, runInputPostResult
, ireq
, iopt
) where
@ -66,11 +67,22 @@ toMap :: [(Text, a)] -> Map.Map Text [a]
toMap = Map.unionsWith (++) . map (\(x, y) -> Map.singleton x [y])
runInputPost :: MonadHandler m => FormInput m a -> m a
runInputPost (FormInput f) = do
runInputPost fi = do
emx <- runInputPostHelper fi
case emx of
Left errs -> invalidArgs errs
Right x -> return x
runInputPostResult :: MonadHandler m => FormInput m a -> m (FormResult a)
runInputPostResult fi = do
emx <- runInputPostHelper fi
case emx of
Left errs -> return $ FormFailure errs
Right x -> return $ FormSuccess x
runInputPostHelper :: MonadHandler m => FormInput m a -> m (Either [Text] a)
runInputPostHelper (FormInput f) = do
(env, fenv) <- liftM (toMap *** toMap) runRequestBody
m <- getYesod
l <- languages
emx <- f m l env fenv
case emx of
Left errs -> invalidArgs $ errs []
Right x -> return x
fmap (either (Left . ($ [])) Right) $ f m l env fenv

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

@ -11,7 +11,7 @@ module Yesod.Form.MassInput
import Yesod.Form.Types
import Yesod.Form.Functions
import Yesod.Form.Fields (boolField)
import Yesod.Form.Fields (checkBoxField)
import Yesod.Core
import Control.Monad.Trans.RWS (get, put, ask)
import Data.Maybe (fromMaybe)
@ -97,7 +97,7 @@ $newline never
<input type=hidden name=#{deleteName} value=yes>
|]
_ -> do
(_, xml2) <- aFormToForm $ areq boolField FieldSettings
(_, xml2) <- aFormToForm $ areq checkBoxField FieldSettings
{ fsLabel = SomeMessage MsgDelete
, fsTooltip = Nothing
, fsName = Just deleteName

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

@ -98,11 +98,11 @@ instance Monad m => Functor (AForm m) where
where
go (w, x, y, z) = (fmap f w, x, y, z)
instance Monad m => Applicative (AForm m) where
pure x = AForm $ const $ const $ \ints -> return (FormSuccess x, mempty, ints, mempty)
pure x = AForm $ const $ const $ \ints -> return (FormSuccess x, id, ints, mempty)
(AForm f) <*> (AForm g) = AForm $ \mr env ints -> do
(a, b, ints', c) <- f mr env ints
(x, y, ints'', z) <- g mr env ints'
return (a <*> x, b `mappend` y, ints'', c `mappend` z)
return (a <*> x, b . y, ints'', c `mappend` z)
instance (Monad m, Monoid a) => Monoid (AForm m a) where
mempty = pure mempty
mappend a b = mappend <$> a <*> b

4
yesod-form/hello-forms.hs
View File

@ -23,7 +23,8 @@ mkYesod "HelloForms" [parseRoutes|
/file FileR GET POST
|]
myForm = fixType $ runFormGet $ renderDivs $ pure (,,,,,,,,)
myForm = fixType $ runFormGet $ renderDivs $ pure (,,,,,,,,,,)
<*> pure "pure works!"
<*> areq boolField "Bool field" Nothing
<*> aopt boolField "Opt bool field" Nothing
<*> areq textField "Text field" Nothing
@ -33,6 +34,7 @@ myForm = fixType $ runFormGet $ renderDivs $ pure (,,,,,,,,)
<*> aopt (multiSelectFieldList fruits) "Opt multi select field" Nothing
<*> aopt intField "Opt int field" Nothing
<*> aopt (radioFieldList fruits) "Opt radio" Nothing
<*> aopt multiEmailField "Opt multi email" Nothing
data HelloForms = HelloForms

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

@ -1,5 +1,5 @@
name: yesod-form
version: 1.3.0.1
version: 1.3.11
license: MIT
license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com>
@ -17,10 +17,11 @@ library
, yesod-core >= 1.2 && < 1.3
, yesod-persistent >= 1.2 && < 1.3
, time >= 1.1.4
, hamlet >= 1.1 && < 1.2
, shakespeare-css >= 1.0 && < 1.1
, shakespeare-js >= 1.0.2 && < 1.2
, persistent >= 1.2 && < 1.3
, hamlet >= 1.1.8
, shakespeare
, shakespeare-css >= 1.0
, shakespeare-js >= 1.0.2
, persistent >= 1.2 && < 1.4
, template-haskell
, transformers >= 0.2.2
, data-default
@ -35,13 +36,14 @@ library
, blaze-html >= 0.5
, blaze-markup >= 0.5.1
, attoparsec >= 0.10
, crypto-api >= 0.8
, byteable
, aeson
, resourcet
exposed-modules: Yesod.Form
Yesod.Form.Types
Yesod.Form.Functions
Yesod.Form.Bootstrap3
Yesod.Form.Input
Yesod.Form.Fields
Yesod.Form.Jquery

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

@ -20,6 +20,7 @@
-- | Generation of Atom newsfeeds.
module Yesod.AtomFeed
( atomFeed
, atomFeedText
, atomLink
, RepAtom (..)
, module Yesod.FeedTypes
@ -47,6 +48,11 @@ atomFeed feed = do
render <- getUrlRender
return $ RepAtom $ toContent $ renderLBS def $ template feed render
-- | Same as @'atomFeed'@ but for @'Feed Text'@. Useful for cases where you are
-- generating a feed of external links.
atomFeedText :: MonadHandler m => Feed Text -> m RepAtom
atomFeedText feed = return $ RepAtom $ toContent $ renderLBS def $ template feed id
template :: Feed url -> (url -> Text) -> Document
template Feed {..} render =
Document (Prologue [] Nothing []) (addNS root) []
@ -62,7 +68,7 @@ template Feed {..} render =
: 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]
: Element "author" Map.empty [NodeElement $ Element "name" Map.empty [NodeContent feedAuthor]]
: map (flip entryTemplate render) feedEntries
entryTemplate :: FeedEntry url -> (url -> Text) -> Element

8
yesod-newsfeed/Yesod/Feed.hs
View File

@ -17,6 +17,7 @@
-------------------------------------------------------------------------------
module Yesod.Feed
( newsFeed
, newsFeedText
, module Yesod.FeedTypes
) where
@ -29,3 +30,10 @@ newsFeed :: MonadHandler m => Feed (Route (HandlerSite m)) -> m TypedContent
newsFeed f = selectRep $ do
provideRep $ atomFeed f
provideRep $ rssFeed f
-- | Same as @'newsFeed'@ but for @'Feed Text'@. Useful for cases where you are
-- generating a feed of external links.
newsFeedText :: MonadHandler m => Feed Text -> m TypedContent
newsFeedText f = selectRep $ do
provideRep $ atomFeedText f
provideRep $ rssFeedText f

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

@ -16,6 +16,7 @@
-------------------------------------------------------------------------------
module Yesod.RssFeed
( rssFeed
, rssFeedText
, rssLink
, RepRss (..)
, module Yesod.FeedTypes
@ -44,6 +45,11 @@ rssFeed feed = do
render <- getUrlRender
return $ RepRss $ toContent $ renderLBS def $ template feed render
-- | Same as @'rssFeed'@ but for @'Feed Text'@. Useful for cases where you are
-- generating a feed of external links.
rssFeedText :: MonadHandler m => Feed Text -> m RepRss
rssFeedText feed = return $ RepRss $ toContent $ renderLBS def $ template feed id
template :: Feed url -> (url -> Text) -> Document
template Feed {..} render =
Document (Prologue [] Nothing []) root []

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

@ -1,5 +1,5 @@
name: yesod-newsfeed
version: 1.2.0
version: 1.2.0.2
license: MIT
license-file: LICENSE
author: Michael Snoyman, Patrick Brisbin
@ -16,7 +16,8 @@ library
build-depends: base >= 4 && < 5
, yesod-core >= 1.2 && < 1.3
, time >= 1.1.4
, hamlet >= 1.1 && < 1.2
, hamlet >= 1.1
, shakespeare
, bytestring >= 0.9.1.4
, text >= 0.9
, xml-conduit >= 1.0

53
yesod-persistent/Yesod/Persist/Core.hs
View File

@ -25,16 +25,17 @@ import Control.Monad.Trans.Reader (runReaderT)
import Yesod.Core
import Data.Conduit
import Blaze.ByteString.Builder (Builder)
import Data.IORef.Lifted
import Data.Conduit.Pool
import Data.Pool
import Control.Monad.Trans.Resource
import Control.Exception (throwIO)
import Yesod.Core.Types (HandlerContents (HCError))
import qualified Database.Persist.Sql as SQL
type YesodDB site = YesodPersistBackend site (HandlerT site IO)
class Monad (YesodPersistBackend site (HandlerT site IO)) => YesodPersist site where
type YesodPersistBackend site :: (* -> *) -> * -> *
runDB :: YesodDB site a -> HandlerT site IO a
runDB :: YesodPersistBackend site (HandlerT site IO) a -> HandlerT site IO a
-- | Helper for creating 'runDB'.
--
@ -70,7 +71,7 @@ class YesodPersist site => YesodPersistRunner site where
getDBRunner :: HandlerT site IO (DBRunner site, HandlerT site IO ())
newtype DBRunner site = DBRunner
{ runDBRunner :: forall a. YesodDB site a -> HandlerT site IO a
{ runDBRunner :: forall a. YesodPersistBackend site (HandlerT site IO) a -> HandlerT site IO a
}
-- | Helper for implementing 'getDBRunner'.
@ -80,24 +81,23 @@ defaultGetDBRunner :: YesodPersistBackend site ~ SqlPersistT
=> (site -> Pool SQL.Connection)
-> HandlerT site IO (DBRunner site, HandlerT site IO ())
defaultGetDBRunner getPool = do
ididSucceed <- newIORef False
pool <- fmap getPool getYesod
managedConn <- takeResource pool
let conn = mrValue managedConn
let withPrep conn f = f conn (SQL.connPrepare conn)
(relKey, (conn, local)) <- allocate
(do
(conn, local) <- takeResource pool
withPrep conn SQL.connBegin
return (conn, local)
)
(\(conn, local) -> do
withPrep conn SQL.connRollback
destroyResource pool local conn)
let withPrep f = f conn (SQL.connPrepare conn)
(finishTransaction, ()) <- allocate (withPrep SQL.connBegin) $ \() -> do
didSucceed <- readIORef ididSucceed
withPrep $ if didSucceed
then SQL.connCommit
else SQL.connRollback
let cleanup = do
writeIORef ididSucceed True
release finishTransaction
mrReuse managedConn True
mrRelease managedConn
let cleanup = liftIO $ do
withPrep conn SQL.connCommit
putResource local conn
_ <- unprotect relKey
return ()
return (DBRunner $ \x -> runReaderT (unSqlPersistT x) conn, cleanup)
@ -106,7 +106,7 @@ defaultGetDBRunner getPool = do
--
-- Since 1.2.0
runDBSource :: YesodPersistRunner site
=> Source (YesodDB site) a
=> Source (YesodPersistBackend site (HandlerT site IO)) a
-> Source (HandlerT site IO) a
runDBSource src = do
(dbrunner, cleanup) <- lift getDBRunner
@ -116,7 +116,7 @@ runDBSource src = do
-- | Extends 'respondSource' to create a streaming database response body.
respondSourceDB :: YesodPersistRunner site
=> ContentType
-> Source (YesodDB site) (Flush Builder)
-> Source (YesodPersistBackend site (HandlerT site IO)) (Flush Builder)
-> HandlerT site IO TypedContent
respondSourceDB ctype = respondSource ctype . runDBSource
@ -132,7 +132,7 @@ get404 :: ( PersistStore (t m)
get404 key = do
mres <- get key
case mres of
Nothing -> lift notFound
Nothing -> notFound'
Just res -> return res
-- | Get the given entity by unique key, or return a 404 not found if it doesn't
@ -148,9 +148,14 @@ getBy404 :: ( PersistUnique (t m)
getBy404 key = do
mres <- getBy key
case mres of
Nothing -> lift notFound
Nothing -> notFound'
Just res -> return res
-- | Should be equivalent to @lift . notFound@, but there's an apparent bug in
-- GHC 7.4.2 that leads to segfaults. This is a workaround.
notFound' :: MonadIO m => m a
notFound' = liftIO $ throwIO $ HCError NotFound
instance MonadHandler m => MonadHandler (SqlPersistT m) where
type HandlerSite (SqlPersistT m) = HandlerSite m
liftHandlerT = lift . liftHandlerT

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

@ -1,5 +1,5 @@
name: yesod-persistent
version: 1.2.1
version: 1.2.3
license: MIT
license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com>
@ -15,14 +15,13 @@ description: Some helpers for using Persistent from Yesod.
library
build-depends: base >= 4 && < 5
, yesod-core >= 1.2.2 && < 1.3
, persistent >= 1.2 && < 1.3
, persistent-template >= 1.2 && < 1.3
, transformers >= 0.2.2 && < 0.4
, persistent >= 1.2 && < 1.4
, persistent-template >= 1.2 && < 1.4
, transformers >= 0.2.2
, blaze-builder
, conduit
, lifted-base
, pool-conduit
, resourcet
, resourcet >= 0.4.5
, resource-pool
exposed-modules: Yesod.Persist
Yesod.Persist.Core
ghc-options: -Wall
@ -35,6 +34,7 @@ test-suite test
build-depends: base
, hspec
, wai-test
, wai-extra
, yesod-core
, persistent-sqlite
, yesod-persistent

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

@ -7,4 +7,16 @@ then
cabal install cabal-nirvana -fgenerate
fi
cabal-nirvana-generate yesod yesod-static hjsmin blaze-html yesod-test shakespeare-text | runghc to-cabal.hs > yesod-platform.cabal
cabal-nirvana-generate \
yesod \
yesod-static \
yesod-auth-hashdb \
hjsmin \
blaze-html \
yesod-test \
shakespeare-text \
esqueleto \
warp-tls \
hjsmin \
http-reverse-proxy \
| runghc to-cabal.hs > yesod-platform.cabal

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

@ -3,7 +3,7 @@ import Control.Applicative ((<$>))
main = do
pkgs <- map (intercalate " == ")
. filter (\xs -> not $ any (`isPrefixOf` xs) $ map return ["parsec", "text", "transformers", "mtl", "HUnit", "QuickCheck", "binary", "zlib", "stm", "regex-compat", "hashable"])
. filter (\xs -> not $ any (`isPrefixOf` xs) $ map return ["parsec", "text", "transformers", "mtl", "HUnit", "QuickCheck", "binary", "zlib", "stm", "regex-compat", "hashable", "vault", "integer-gmp"])
. map words
. filter (not . null)
. lines

237
yesod-platform/yesod-platform.cabal
View File

@ -1,5 +1,5 @@
name: yesod-platform
version: 1.2.3
version: 1.2.12.2
license: MIT
license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com>
@ -14,131 +14,146 @@ homepage: http://www.yesodweb.com/
library
build-depends: base >= 4 && < 5
, SHA == 1.6.1
, aeson == 0.6.1.0
, ansi-terminal == 0.6
, asn1-data == 0.7.1
, asn1-types == 0.2.0
, attoparsec == 0.10.4.0
, attoparsec-conduit == 1.0.1.2
, authenticate == 1.3.2.6
, base-unicode-symbols == 0.2.2.4
, SHA == 1.6.4
, aeson == 0.7.0.6
, ansi-terminal == 0.6.1.1
, ansi-wl-pprint == 0.6.7.1
, asn1-encoding == 0.8.1.3
, asn1-parse == 0.8.1
, asn1-types == 0.2.3
, async == 2.0.1.5
, attoparsec == 0.12.0.0
, attoparsec-conduit == 1.1.0
, authenticate == 1.3.2.8
, base16-bytestring == 0.1.1.6
, base64-bytestring == 1.0.0.1
, blaze-builder == 0.3.1.1
, blaze-builder-conduit == 1.0.0
, blaze-html == 0.6.1.1
, blaze-markup == 0.5.1.5
, blaze-builder == 0.3.3.2
, blaze-builder-conduit == 1.1.0
, blaze-html == 0.7.0.2
, blaze-markup == 0.6.1.0
, byteable == 0.1.1
, byteorder == 1.0.4
, case-insensitive == 1.0.0.2
, cereal == 0.3.5.2
, certificate == 1.3.8
, cipher-aes == 0.1.8
, cipher-rc4 == 0.1.2
, clientsession == 0.9
, conduit == 1.0.7.3
, cookie == 0.4.0.1
, cprng-aes == 0.3.4
, crypto-api == 0.12.2.1
, crypto-conduit == 0.5.2
, crypto-numbers == 0.1.3
, crypto-pubkey == 0.1.4
, crypto-pubkey-types == 0.4.0
, crypto-random-api == 0.2.0
, cryptohash == 0.9.1
, css-text == 0.1.1
, case-insensitive == 1.2.0.0
, cereal == 0.4.0.1
, cipher-aes == 0.2.7
, cipher-des == 0.0.6
, cipher-rc4 == 0.1.4
, clientsession == 0.9.0.3
, conduit == 1.1.6
, conduit-extra == 1.1.0.4
, connection == 0.2.1
, cookie == 0.4.1.1
, cprng-aes == 0.5.2
, crypto-api == 0.13
, crypto-cipher-types == 0.0.9
, crypto-numbers == 0.2.3
, crypto-pubkey == 0.2.4
, crypto-pubkey-types == 0.4.2.2
, crypto-random == 0.0.7
, cryptohash == 0.11.5
, cryptohash-conduit == 0.1.1
, css-text == 0.1.2.1
, data-default == 0.5.3
, data-default-class == 0.0.1
, data-default-instances-base == 0.0.1
, data-default-instances-containers == 0.0.1
, data-default-instances-dlist == 0.0.1
, data-default-instances-old-locale == 0.0.1
, date-cache == 0.3.0
, dlist == 0.5
, email-validate == 1.0.0
, entropy == 0.2.2.1
, failure == 0.2.0.1
, fast-logger == 0.3.2
, file-embed == 0.0.4.9
, filesystem-conduit == 1.0.0.1
, hamlet == 1.1.7.1
, hjsmin == 0.1.4.1
, hspec == 1.6.1
, hspec-expectations == 0.3.2
, html-conduit == 1.1.0
, http-attoparsec == 0.1.0
, http-conduit == 1.9.4.1
, dlist == 0.7.0.1
, email-validate == 2.0.1
, entropy == 0.3.2
, esqueleto == 1.4.1.2
, exceptions == 0.6.1
, fast-logger == 2.1.5
, file-embed == 0.0.7
, hamlet == 1.2.0
, hjsmin == 0.1.4.6
, hspec == 1.9.5
, hspec-expectations == 0.5.0.1
, html-conduit == 1.1.0.5
, http-client == 0.3.3
, http-client-tls == 0.2.1.1
, http-conduit == 2.1.2
, http-date == 0.0.4
, http-types == 0.8.0
, language-javascript == 0.5.7
, lifted-base == 0.2.1.0
, mime-mail == 0.4.2
, mime-types == 0.1.0.3
, mmorph == 1.0.0
, monad-control == 0.3.2.1
, monad-logger == 0.3.1.1
, network-conduit == 1.0.0
, path-pieces == 0.1.2
, pem == 0.1.2
, persistent == 1.2.2.0
, persistent-template == 1.2.0.2
, pool-conduit == 0.1.2
, primitive == 0.5.0.1
, http-reverse-proxy == 0.3.1.8
, http-types == 0.8.5
, language-javascript == 0.5.13
, lifted-base == 0.2.2.2
, mime-mail == 0.4.5.2
, mime-types == 0.1.0.4
, mmorph == 1.0.3
, monad-control == 0.3.3.0
, monad-logger == 0.3.6.1
, monad-loops == 0.4.2
, nats == 0.2
, network-conduit == 1.1.0
, optparse-applicative == 0.8.1
, path-pieces == 0.1.3.1
, pem == 0.2.2
, persistent == 1.3.1.1
, persistent-template == 1.3.1.4
, primitive == 0.5.3.0
, publicsuffixlist == 0.1
, pureMD5 == 2.1.2.1
, pwstore-fast == 2.3
, quickcheck-io == 0.1.0
, resource-pool == 0.2.1.1
, resourcet == 0.4.7.1
, safe == 0.3.3
, semigroups == 0.9.2
, setenv == 0.1.0
, shakespeare == 1.0.5
, shakespeare-css == 1.0.6.2
, shakespeare-i18n == 1.0.0.3
, shakespeare-js == 1.1.4.1
, shakespeare-text == 1.0.0.6
, pwstore-fast == 2.4.1
, quickcheck-io == 0.1.1
, resource-pool == 0.2.3.0
, resourcet == 1.1.2.2
, safe == 0.3.4
, scientific == 0.3.2.1
, securemem == 0.1.3
, semigroups == 0.15
, setenv == 0.1.1.1
, shakespeare == 2.0.0.3
, shakespeare-css == 1.1.0
, shakespeare-i18n == 1.1.0
, shakespeare-js == 1.3.0
, shakespeare-text == 1.1.0
, silently == 1.2.4.1
, simple-sendfile == 0.2.12
, skein == 1.0.3
, socks == 0.5.1
, stringsearch == 0.3.6.4
, system-fileio == 0.3.11
, system-filepath == 0.4.7
, tagged == 0.6.1
, tagsoup == 0.12.8
, tagstream-conduit == 0.5.4
, tls == 1.1.2
, tls-extra == 0.6.4
, transformers-base == 0.4.1
, simple-sendfile == 0.2.14
, skein == 1.0.9
, socks == 0.5.4
, stm-chans == 3.0.0.2
, streaming-commons == 0.1.3
, stringsearch == 0.3.6.5
, system-fileio == 0.3.14
, system-filepath == 0.4.12
, tagged == 0.7.2
, tagsoup == 0.13.1
, tagstream-conduit == 0.5.5.1
, tf-random == 0.5
, tls == 1.2.8
, transformers-base == 0.4.2
-- , transformers-compat == 0.3.3.4
, unix-compat == 0.4.1.1
, unordered-containers == 0.2.3.1
, utf8-light == 0.4.0.1
, utf8-string == 0.3.7
, vault == 0.2.0.4
, vector == 0.10.0.1
, unordered-containers == 0.2.4.0
, utf8-string == 0.3.8
, vector == 0.10.11.0
, void == 0.6.1
, wai == 1.4.0.1
, wai-app-static == 1.3.1.3
, wai-extra == 1.3.4.2
, wai-logger == 0.3.1
, wai-test == 1.3.1.1
, warp == 1.3.9
, word8 == 0.0.3
, xml-conduit == 1.1.0.5
, wai == 3.0.0
, wai-app-static == 3.0.0
, wai-extra == 3.0.0
, wai-logger == 2.1.1
, wai-test == 3.0.0
, warp == 3.0.0.2
, warp-tls == 3.0.0
, word8 == 0.0.4
, x509 == 1.4.11
, x509-store == 1.4.4
, x509-system == 1.4.5
, x509-validation == 1.5.0
, xml-conduit == 1.2.0.2
, xml-types == 0.3.4
, xss-sanitize == 0.3.4
, yaml == 0.8.4
, yesod == 1.2.1.1
, yesod-auth == 1.2.0.2
, yesod-core == 1.2.3
, yesod-form == 1.3.0.1
, yesod-persistent == 1.2.1
, yesod-routes == 1.2.0.1
, yesod-static == 1.2.0
, yesod-test == 1.2.0
, zlib-bindings == 0.1.1.3
, zlib-conduit == 1.0.0
, xss-sanitize == 0.3.5.2
, yaml == 0.8.8.3
, yesod == 1.2.6
, yesod-auth == 1.3.1
, yesod-auth-hashdb == 1.3.0.1
, yesod-core == 1.2.16
, yesod-form == 1.3.10
, yesod-persistent == 1.2.3
, yesod-routes == 1.2.0.6
, yesod-static == 1.2.4
, yesod-test == 1.2.3
exposed-modules: Yesod.Platform

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

@ -8,15 +8,42 @@ module Yesod.Routes.Overlap
import Yesod.Routes.TH.Types
import Data.List (intercalate)
data Flattened t = Flattened
{ fNames :: [String]
, fPieces :: [(CheckOverlap, Piece t)]
, fHasSuffix :: Bool
}
flatten :: ResourceTree t -> [Flattened t]
flatten =
go id id
where
go names pieces (ResourceLeaf r) = return Flattened
{ fNames = names [resourceName r]
, fPieces = pieces (resourcePieces r)
, fHasSuffix = hasSuffix $ ResourceLeaf r
}
go names pieces (ResourceParent newname newpieces children) =
concatMap (go names' pieces') children
where
names' = names . (newname:)
pieces' = pieces . (newpieces ++)
data Overlap t = Overlap
{ overlapParents :: [String] -> [String] -- ^ parent resource trees
, overlap1 :: ResourceTree t
, overlap2 :: ResourceTree t
}
data OverlapF = OverlapF
{ overlapF1 :: [String]
, overlapF2 :: [String]
}
findOverlaps :: ([String] -> [String]) -> [ResourceTree t] -> [Overlap t]
findOverlaps _ [] = []
findOverlaps front (x:xs) = concatMap (findOverlap front x) xs ++ findOverlaps front xs
{-# DEPRECATED findOverlaps "This function is no longer used" #-}
findOverlap :: ([String] -> [String]) -> ResourceTree t -> ResourceTree t -> [Overlap t]
findOverlap front x y =
@ -30,14 +57,6 @@ findOverlap front x y =
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
-- No pieces on either side, will overlap regardless of suffix
@ -66,9 +85,26 @@ piecesOverlap _ _ = True
findOverlapNames :: [ResourceTree t] -> [(String, String)]
findOverlapNames =
map go . findOverlaps id
map go . findOverlapsF . concatMap Yesod.Routes.Overlap.flatten
where
go (Overlap front x y) =
(go' $ resourceTreeName x, go' $ resourceTreeName y)
go (OverlapF x y) =
(go' x, go' y)
where
go' = intercalate "/" . front . return
go' = intercalate "/"
findOverlapsF :: [Flattened t] -> [OverlapF]
findOverlapsF [] = []
findOverlapsF (x:xs) = concatMap (findOverlapF x) xs ++ findOverlapsF xs
findOverlapF :: Flattened t -> Flattened t -> [OverlapF]
findOverlapF x y
| overlaps (fPieces x) (fPieces y) (fHasSuffix x) (fHasSuffix y) = [OverlapF (fNames x) (fNames y)]
| otherwise = []
hasSuffix :: ResourceTree t -> Bool
hasSuffix (ResourceLeaf r) =
case resourceDispatch r of
Subsite{} -> True
Methods Just{} _ -> True
Methods Nothing _ -> False
hasSuffix ResourceParent{} = True

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

@ -1,5 +1,6 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE PatternGuards #-}
{-# OPTIONS_GHC -fno-warn-missing-fields #-} -- QuasiQuoter
module Yesod.Routes.Parse
( parseRoutes
@ -18,6 +19,8 @@ import qualified System.IO as SIO
import Yesod.Routes.TH
import Yesod.Routes.Overlap (findOverlapNames)
import Data.List (foldl')
import Data.Maybe (mapMaybe)
import qualified Data.Set as Set
-- | A quasi-quoter to parse a string into a list of 'Resource's. Checks for
-- overlapping routes, failing if present; use 'parseRoutesNoCheck' to skip the
@ -29,7 +32,7 @@ parseRoutes = QuasiQuoter { quoteExp = x }
let res = resourcesFromString s
case findOverlapNames res of
[] -> lift res
z -> error $ "Overlapping routes: " ++ unlines (map show z)
z -> error $ unlines $ "Overlapping routes: " : map show z
parseRoutesFile :: FilePath -> Q Exp
parseRoutesFile = parseRoutesFileWith parseRoutes
@ -60,21 +63,37 @@ parseRoutesNoCheck = QuasiQuoter
-- invalid input.
resourcesFromString :: String -> [ResourceTree String]
resourcesFromString =
fst . parse 0 . lines
fst . parse 0 . filter (not . all (== ' ')) . lines
where
parse _ [] = ([], [])
parse indent (thisLine:otherLines)
| length spaces < indent = ([], thisLine : otherLines)
| otherwise = (this others, remainder)
where
parseAttr ('!':x) = Just x
parseAttr _ = Nothing
stripColonLast =
go id
where
go _ [] = Nothing
go front [x]
| null x = Nothing
| last x == ':' = Just $ front [init x]
| otherwise = Nothing
go front (x:xs) = go (front . (x:)) xs
spaces = takeWhile (== ' ') thisLine
(others, remainder) = parse indent otherLines'
(this, otherLines') =
case takeWhile (/= "--") $ words thisLine of
[pattern, constr] | last constr == ':' ->
(pattern:rest0)
| Just (constr:rest) <- stripColonLast rest0
, Just attrs <- mapM parseAttr rest ->
let (children, otherLines'') = parse (length spaces + 1) otherLines
children' = addAttrs attrs children
(pieces, Nothing) = piecesFromString $ drop1Slash pattern
in ((ResourceParent (init constr) pieces children :), otherLines'')
in ((ResourceParent constr pieces children' :), otherLines'')
(pattern:constr:rest) ->
let (pieces, mmulti) = piecesFromString $ drop1Slash pattern
(attrs, rest') = takeAttrs rest
@ -83,6 +102,29 @@ resourcesFromString =
[] -> (id, otherLines)
_ -> error $ "Invalid resource line: " ++ thisLine
addAttrs :: [String] -> [ResourceTree String] -> [ResourceTree String]
addAttrs attrs =
map goTree
where
goTree (ResourceLeaf res) = ResourceLeaf (goRes res)
goTree (ResourceParent x y z) = ResourceParent x y (map goTree z)
goRes res =
res { resourceAttrs = noDupes ++ resourceAttrs res }
where
usedKeys = Set.fromList $ map fst $ mapMaybe toPair $ resourceAttrs res
used attr =
case toPair attr of
Nothing -> False
Just (key, _) -> key `Set.member` usedKeys
noDupes = filter (not . used) attrs
toPair s =
case break (== '=') s of
(x, '=':y) -> Just (x, y)
_ -> Nothing
-- | Take attributes out of the list and put them in the first slot in the
-- result tuple.
takeAttrs :: [String] -> ([String], [String])
@ -184,6 +226,7 @@ ttToType (TTList t) = ListT `AppT` ttToType t
pieceFromString :: String -> Either String (CheckOverlap, Piece String)
pieceFromString ('#':'!':x) = Right $ (False, Dynamic x)
pieceFromString ('!':'#':x) = Right $ (False, Dynamic x) -- https://github.com/yesodweb/yesod/issues/652
pieceFromString ('#':x) = Right $ (True, Dynamic x)
pieceFromString ('*':x) = Left x
pieceFromString ('+':x) = Left x

99
yesod-routes/test/Hierarchy.hs
View File

@ -10,7 +10,7 @@ module Hierarchy
( hierarchy
, Dispatcher (..)
, runHandler
, Handler
, Handler2
, App
, toText
, Env (..)
@ -24,9 +24,10 @@ 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)
import Data.Text (Text, pack, unpack, append)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as S8
import qualified Data.Set as Set
class ToText a where
toText :: a -> Text
@ -34,7 +35,9 @@ class ToText a where
instance ToText Text where toText = id
instance ToText String where toText = pack
type Handler sub master a = a
type Handler2 sub master a = a
type Handler site a = Handler2 site site a
type Request = ([Text], ByteString) -- path info, method
type App sub master = Request -> (Text, Maybe (YRC.Route master))
data Env sub master = Env
@ -45,7 +48,7 @@ data Env sub master = Env
subDispatch
:: (Env sub master -> App sub master)
-> (Handler sub master Text -> Env sub master -> Maybe (YRC.Route sub) -> App sub master)
-> (Handler2 sub master Text -> Env sub master -> Maybe (YRC.Route sub) -> App sub master)
-> (master -> sub)
-> (YRC.Route sub -> YRC.Route master)
-> Env master master
@ -63,24 +66,49 @@ class Dispatcher sub master where
runHandler
:: ToText a
=> Handler sub master a
=> Handler2 sub master a
-> Env sub master
-> Maybe (Route sub)
-> App sub master
runHandler h Env {..} route _ = (toText h, fmap envToMaster route)
data Hierarchy = Hierarchy
do
let resources = [parseRoutes|
/ HomeR GET
/!#Int BackwardsR GET
/admin/#Int AdminR:
/ AdminRootR GET
/login LoginR GET POST
/table/#Text TableR GET
/ AdminRootR GET
/login LoginR GET POST
/table/#Text TableR GET
/nest/ NestR !NestingAttr:
/spaces SpacedR GET !NonNested
/nest2 Nest2:
/ GetPostR GET POST
/get Get2 GET
/post Post2 POST
-- /#Int Delete2 DELETE
/nest3 Nest3:
/get Get3 GET
/post Post3 POST
-- /#Int Delete3 DELETE
/afterwards AfterR !parent !key=value1:
/ After GET !child !key=value2
-- /trailing-nest TrailingNestR:
-- /foo TrailingFooR GET
-- /#Int TrailingIntR GET
|]
rrinst <- mkRenderRouteInstance (ConT ''Hierarchy) $ map (fmap parseType) resources
rainst <- mkRouteAttrsInstance (ConT ''Hierarchy) $ map (fmap parseType) resources
prinst <- mkParseRouteInstance (ConT ''Hierarchy) $ map (fmap parseType) resources
dispatch <- mkDispatchClause MkDispatchSettings
{ mdsRunHandler = [|runHandler|]
@ -100,25 +128,50 @@ do
`AppT` ConT ''Hierarchy)
[FunD (mkName "dispatcher") [dispatch]]
: prinst
: rainst
: rrinst
getHomeR :: Handler sub master String
getSpacedR :: Handler site String
getSpacedR = "root-leaf"
getGet2 :: Handler site String; getGet2 = "get"
postPost2 :: Handler site String; postPost2 = "post"
deleteDelete2 :: Int -> Handler site String; deleteDelete2 = const "delete"
getGet3 :: Handler site String; getGet3 = "get"
postPost3 :: Handler site String; postPost3 = "post"
deleteDelete3 :: Int -> Handler site String; deleteDelete3 = const "delete"
getAfter :: Handler site String; getAfter = "after"
getHomeR :: Handler site String
getHomeR = "home"
getAdminRootR :: Int -> Handler sub master Text
getBackwardsR :: Int -> Handler site Text
getBackwardsR _ = pack "backwards"
getAdminRootR :: Int -> Handler site Text
getAdminRootR i = pack $ "admin root: " ++ show i
getLoginR :: Int -> Handler sub master Text
getLoginR :: Int -> Handler site Text
getLoginR i = pack $ "login: " ++ show i
postLoginR :: Int -> Handler sub master Text
postLoginR :: Int -> Handler site Text
postLoginR i = pack $ "post login: " ++ show i
getTableR :: Int -> Text -> Handler sub master Text
getTableR _ t = append "TableR " t
getTableR :: Int -> Text -> Handler site Text
getTableR _ = append "TableR "
getGetPostR :: Handler site Text
getGetPostR = pack "get"
postGetPostR :: Handler site Text
postGetPostR = pack "post"
hierarchy :: Spec
hierarchy = describe "hierarchy" $ do
it "nested with spacing" $
renderRoute (NestR SpacedR) @?= (["nest", "spaces"], [])
it "renders root correctly" $
renderRoute (AdminR 5 AdminRootR) @?= (["admin", "5"], [])
it "renders table correctly" $
@ -130,6 +183,18 @@ hierarchy = describe "hierarchy" $ do
, envSub = Hierarchy
})
(map pack ps, S8.pack m)
let testGetPost route getRes postRes = do
let routeStrs = map unpack $ fst (renderRoute route)
disp "GET" routeStrs @?= (getRes, Just route)
disp "POST" routeStrs @?= (postRes, Just route)
it "dispatches routes with multiple METHODs: admin" $
testGetPost (AdminR 1 LoginR) "login: 1" "post login: 1"
it "dispatches routes with multiple METHODs: nesting" $
testGetPost (NestR $ Nest2 GetPostR) "get" "post"
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")
it "parses" $ do
@ -137,3 +202,7 @@ hierarchy = describe "hierarchy" $ do
parseRoute ([], [("foo", "bar")]) @?= Just HomeR
parseRoute (["admin", "5"], []) @?= Just (AdminR 5 AdminRootR)
parseRoute (["admin!", "5"], []) @?= (Nothing :: Maybe (Route Hierarchy))
it "inherited attributes" $ do
routeAttrs (NestR SpacedR) @?= Set.fromList ["NestingAttr", "NonNested"]
it "pair attributes" $
routeAttrs (AfterR After) @?= Set.fromList ["parent", "child", "key=value2"]

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

@ -1,5 +1,5 @@
name: yesod-routes
version: 1.2.0.1
version: 1.2.0.7
license: MIT
license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com>
@ -16,7 +16,7 @@ extra-source-files:
library
build-depends: base >= 4 && < 5
, text >= 0.5 && < 0.12
, text >= 0.5
, vector >= 0.8 && < 0.11
, containers >= 0.2
, template-haskell
@ -42,7 +42,7 @@ test-suite runtests
build-depends: base >= 4.3 && < 5
, yesod-routes
, text >= 0.5 && < 0.12
, text >= 0.5
, HUnit >= 1.2 && < 1.3
, hspec >= 1.3
, containers

188
yesod-static/Yesod/EmbeddedStatic.hs Normal file
View File

@ -0,0 +1,188 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- | A subsite which serves static content which is embedded at compile time.
--
-- At compile time, you supply a list of files, directories, processing functions (like javascript
-- minification), and even custom content generators. You can also specify the specific relative
-- locations within the static subsite where these resources should appear. The 'mkEmbeddedStatic'
-- function then computes the resources and embeds them directly into the executable at
-- compile time, so that the original files do not need to be distributed along with
-- the executable. The content is also compressed and hashed at compile time, so that
-- during runtime the compressed content can be sent directly on the wire with the appropriate
-- HTTP header. The precomputed hash is used for an ETag so the client does not redownload
-- the content multiple times. There is also a development mode which does not embed the
-- contents but recomputes it on every request. A simple example using an embedded static
-- subsite is
-- <https://github.com/yesodweb/yesod/blob/master/yesod-static/sample-embed.hs static-embed.hs>.
--
-- To add this to a scaffolded project, replace the code in @Settings/StaticFiles.hs@
-- with a call to 'mkEmbeddedStatic' with the list of all your generators, use the type
-- 'EmbeddedStatic' in your site datatype for @getStatic@, update the route for @/static@ to
-- use the type 'EmbeddedStatic', use 'embedStaticContent' for 'addStaticContent' in
-- @Foundation.hs@, use the routes generated by 'mkEmbeddedStatic' and exported by
-- @Settings/StaticFiles.hs@ to link to your static content, and finally update
-- @Application.hs@ use the variable binding created by 'mkEmbeddedStatic' which
-- contains the created 'EmbeddedStatic'.
--
-- It is recommended that you serve static resources from a separate domain to save time
-- on transmitting cookies. You can use 'urlRenderOverride' to do so, by redirecting
-- routes to this subsite to a different domain (but the same path) and then pointing the
-- alternative domain to this server. In addition, you might consider using a reverse
-- proxy like varnish or squid to cache the static content, but the embedded content in
-- this subsite is cached and served directly from memory so is already quite fast.
module Yesod.EmbeddedStatic (
-- * Subsite
EmbeddedStatic
, embeddedResourceR
, mkEmbeddedStatic
, embedStaticContent
-- * Generators
, module Yesod.EmbeddedStatic.Generators
) where
import Control.Applicative ((<$>))
import Data.IORef
import Data.Maybe (catMaybes)
import Language.Haskell.TH
import Network.HTTP.Types.Status (status404)
import Network.Wai (responseLBS, pathInfo)
import Network.Wai.Application.Static (staticApp)
import System.IO.Unsafe (unsafePerformIO)
import Yesod.Core
( HandlerT
, Yesod(..)
, YesodSubDispatch(..)
)
import Yesod.Core.Types
( YesodSubRunnerEnv(..)
, YesodRunnerEnv(..)
)
import qualified Data.ByteString.Lazy as BL
import qualified Data.Text as T
import qualified Data.HashMap.Strict as M
import qualified WaiAppStatic.Storage.Embedded as Static
import Yesod.EmbeddedStatic.Types
import Yesod.EmbeddedStatic.Internal
import Yesod.EmbeddedStatic.Generators
-- Haddock doesn't support associated types in instances yet so we can't
-- export EmbeddedResourceR directly.
-- | Construct a route to an embedded resource.
embeddedResourceR :: [T.Text] -> [(T.Text, T.Text)] -> Route EmbeddedStatic
embeddedResourceR = EmbeddedResourceR
instance Yesod master => YesodSubDispatch EmbeddedStatic (HandlerT master IO) where
yesodSubDispatch YesodSubRunnerEnv {..} req = resp
where
master = yreSite ysreParentEnv
site = ysreGetSub master
resp = case pathInfo req of
("res":_) -> stApp site req
("widget":_) -> staticApp (widgetSettings site) req
#if MIN_VERSION_wai(3,0,0)
_ -> ($ responseLBS status404 [] "Not Found")
#else
_ -> return $ responseLBS status404 [] "Not Found"
#endif
-- | Create the haskell variable for the link to the entry
mkRoute :: ComputedEntry -> Q [Dec]
mkRoute (ComputedEntry { cHaskellName = Nothing }) = return []
mkRoute (c@ComputedEntry { cHaskellName = Just name }) = do
routeType <- [t| Route EmbeddedStatic |]
link <- [| $(cLink c) |]
return [ SigD name routeType
, ValD (VarP name) (NormalB link) []
]
-- | Creates an 'EmbeddedStatic' by running, at compile time, a list of generators.
-- Each generator produces a list of entries to embed into the executable.
--
-- This template haskell splice creates a variable binding holding the resulting
-- 'EmbeddedStatic' and in addition creates variable bindings for all the routes
-- produced by the generators. For example, if a directory called static has
-- the following contents:
--
-- * js/jquery.js
--
-- * css/bootstrap.css
--
-- * img/logo.png
--
-- then a call to
--
-- > #ifdef DEVELOPMENT
-- > #define DEV_BOOL True
-- > #else
-- > #define DEV_BOOL False
-- > #endif
-- > mkEmbeddedStatic DEV_BOOL "myStatic" [embedDir "static"]
--
-- will produce variables
--
-- > myStatic :: EmbeddedStatic
-- > js_jquery_js :: Route EmbeddedStatic
-- > css_bootstrap_css :: Route EmbeddedStatic
-- > img_logo_png :: Route EmbeddedStatic
mkEmbeddedStatic :: Bool -- ^ development?
-> String -- ^ variable name for the created 'EmbeddedStatic'
-> [Generator] -- ^ the generators (see "Yesod.EmbeddedStatic.Generators")
-> Q [Dec]
mkEmbeddedStatic dev esName gen = do
entries <- concat <$> sequence gen
computed <- runIO $ mapM (if dev then devEmbed else prodEmbed) entries
let settings = Static.mkSettings $ return $ map cStEntry computed
devExtra = listE $ catMaybes $ map ebDevelExtraFiles entries
ioRef = [| unsafePerformIO $ newIORef M.empty |]
-- build the embedded static
esType <- [t| EmbeddedStatic |]
esCreate <- if dev
then [| EmbeddedStatic (develApp $settings $devExtra) $ioRef |]
else [| EmbeddedStatic (staticApp $! $settings) $ioRef |]
let es = [ SigD (mkName esName) esType
, ValD (VarP $ mkName esName) (NormalB esCreate) []
]
routes <- mapM mkRoute computed
return $ es ++ concat routes
-- | Use this for 'addStaticContent' to have the widget static content be served by
-- the embedded static subsite. For example,
--
-- > import Yesod
-- > import Yesod.EmbeddedStatic
-- > import Text.Jasmine (minifym)
-- >
-- > data MySite = { ..., getStatic :: EmbeddedStatic, ... }
-- >
-- > mkYesod "MySite" [parseRoutes|
-- > ...
-- > /static StaticR EmbeddedStatic getStatic
-- > ...
-- > |]
-- >
-- > instance Yesod MySite where
-- > ...
-- > addStaticContent = embedStaticContent getStatic StaticR mini
-- > where mini = if development then Right else minifym
-- > ...
embedStaticContent :: Yesod site
=> (site -> EmbeddedStatic) -- ^ How to retrieve the embedded static subsite from your site
-> (Route EmbeddedStatic -> Route site) -- ^ how to convert an embedded static route
-> (BL.ByteString -> Either a BL.ByteString) -- ^ javascript minifier
-> AddStaticContent site
embedStaticContent = staticContentHelper

80
yesod-static/Yesod/EmbeddedStatic/Css/AbsoluteUrl.hs Normal file
View File

@ -0,0 +1,80 @@
{-# LANGUAGE OverloadedStrings #-}
-- | Manipulate CSS urls.
--
-- * Make relative urls absolute (useful when combining assets)
module Yesod.EmbeddedStatic.Css.AbsoluteUrl (
-- * Absolute urls
absoluteUrls
, absoluteUrlsAt
, absoluteUrlsWith
, absCssUrlsFileProd
, absCssUrlsProd
) where
import Prelude hiding (FilePath)
import Yesod.EmbeddedStatic.Generators
import Yesod.EmbeddedStatic.Types
import qualified Data.ByteString.Lazy as BL
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.IO as T
import qualified Data.Text.Lazy.Encoding as TL
import Control.Monad ((>=>))
import Data.Maybe (fromMaybe)
import Filesystem.Path.CurrentOS ((</>), collapse, FilePath, fromText, toText, encodeString, decodeString)
import Yesod.EmbeddedStatic.Css.Util
-------------------------------------------------------------------------------
-- Generator
-------------------------------------------------------------------------------
-- | Anchors relative CSS image urls
absCssUrlsFileProd :: FilePath -- ^ Anchor relative urls to here
-> FilePath
-> IO BL.ByteString
absCssUrlsFileProd dir file = do
contents <- T.readFile (encodeString file)
return $ TL.encodeUtf8 $ absCssUrlsProd dir contents
absCssUrlsProd :: FilePath -- ^ Anchor relative urls to here
-> T.Text
-> TL.Text
absCssUrlsProd dir contents =
let css = either error id $ parseCssUrls contents
in renderCssWith toAbsoluteUrl css
where
toAbsoluteUrl (UrlReference rel) = T.concat
[ "url('/"
, (either id id $ toText $ collapse $ dir </> fromText rel)
, "')"
]
-- | Equivalent to passing the same string twice to 'absoluteUrlsAt'.
absoluteUrls :: FilePath -> Generator
absoluteUrls f = absoluteUrlsAt (encodeString f) f
-- | Equivalent to passing @return@ to 'absoluteUrlsWith'.
absoluteUrlsAt :: Location -> FilePath -> Generator
absoluteUrlsAt loc f = absoluteUrlsWith loc f Nothing
-- | Automatically make relative urls absolute
--
-- During development, leave CSS as is.
--
-- When CSS is organized into a directory structure, it will work properly for individual requests for each file.
-- During production, we want to combine and minify CSS as much as possible.
-- The combination process combines files from different directories, messing up relative urls.
-- This pre-processor makes relative urls absolute
absoluteUrlsWith ::
Location -- ^ The location the CSS file should appear in the static subsite
-> FilePath -- ^ Path to the CSS file.
-> Maybe (CssGeneration -> IO BL.ByteString) -- ^ Another filter function run after this one (for example @return . yuiCSS . cssContent@) or other CSS filter that runs after this filter.
-> Generator
absoluteUrlsWith loc file mpostFilter =
return [ cssProductionFilter (absCssUrlsFileProd (decodeString loc) >=> postFilter . mkCssGeneration loc file) loc file
]
where
postFilter = fromMaybe (return . cssContent) mpostFilter

196
yesod-static/Yesod/EmbeddedStatic/Css/Util.hs Normal file
View File

@ -0,0 +1,196 @@
{-# LANGUAGE OverloadedStrings, QuasiQuotes, TemplateHaskell, TupleSections, GeneralizedNewtypeDeriving #-}
module Yesod.EmbeddedStatic.Css.Util where
import Prelude hiding (FilePath)
import Control.Applicative
import Control.Monad (void, foldM)
import Data.Hashable (Hashable)
import Data.Monoid
import Network.Mime (MimeType, defaultMimeLookup)
import Filesystem.Path.CurrentOS (FilePath, directory, (</>), dropExtension, filename, toText, decodeString, encodeString, fromText, absolute)
import Text.CSS.Parse (parseBlocks)
import Language.Haskell.TH (litE, stringL)
import Text.CSS.Render (renderBlocks)
import Yesod.EmbeddedStatic.Types
import Yesod.EmbeddedStatic (pathToName)
import Data.Default (def)
import qualified Blaze.ByteString.Builder as B
import qualified Blaze.ByteString.Builder.Char.Utf8 as B
import qualified Data.Attoparsec.Text as P
import qualified Data.Attoparsec.ByteString.Lazy as PBL
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Base64 as B64
import qualified Data.HashMap.Lazy as M
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.IO as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as TL
-------------------------------------------------------------------------------
-- Loading CSS
-------------------------------------------------------------------------------
-- | In the parsed CSS, this will be an image reference that we want to replace.
-- the contents will be the filepath.
newtype UrlReference = UrlReference T.Text
deriving (Show, Eq, Hashable, Ord)
type EithUrl = (T.Text, Either T.Text UrlReference)
-- | The parsed CSS
type Css = [(T.Text, [EithUrl])]
-- | Parse the filename out of url('filename')
parseUrl :: P.Parser T.Text
parseUrl = do
P.skipSpace
void $ P.string "url('"
P.takeTill (== '\'')
checkForUrl :: T.Text -> T.Text -> EithUrl
checkForUrl n@("background-image") v = parseBackgroundImage n v
checkForUrl n@("src") v = parseBackgroundImage n v
checkForUrl n v = (n, Left v)
-- | Check if a given CSS attribute is a background image referencing a local file
checkForImage :: T.Text -> T.Text -> EithUrl
checkForImage n@("background-image") v = parseBackgroundImage n v
checkForImage n v = (n, Left v)
parseBackgroundImage :: T.Text -> T.Text -> EithUrl
parseBackgroundImage n v = (n, case P.parseOnly parseUrl v of
Left _ -> Left v -- Can't parse url
Right url -> -- maybe we should find a uri parser
if any (`T.isPrefixOf` url) ["http://", "https://", "//"] || absolute (fromText url)
then Left v
else Right $ UrlReference url)
parseCssWith :: (T.Text -> T.Text -> EithUrl) -> T.Text -> Either String Css
parseCssWith urlParser contents =
let mparsed = parseBlocks contents in
case mparsed of
Left err -> Left err
Right blocks -> Right [ (t, map (uncurry urlParser) b) | (t,b) <- blocks ]
parseCssUrls :: T.Text -> Either String Css
parseCssUrls = parseCssWith checkForUrl
parseCssFileWith :: (T.Text -> T.Text -> EithUrl) -> FilePath -> IO Css
parseCssFileWith urlParser fp = do
mparsed <- parseCssWith urlParser <$> T.readFile (encodeString fp)
case mparsed of
Left err -> fail $ "Unable to parse " ++ encodeString fp ++ ": " ++ err
Right css -> return css
parseCssFileUrls :: FilePath -> IO Css
parseCssFileUrls = parseCssFileWith checkForUrl
renderCssWith :: (UrlReference -> T.Text) -> Css -> TL.Text
renderCssWith urlRenderer css =
TL.toLazyText $ renderBlocks [(n, map render block) | (n,block) <- css]
where
render (n, Left b) = (n, b)
render (n, Right f) = (n, urlRenderer f)
-- | Load an image map from the images in the CSS
loadImages :: FilePath -> Css -> (FilePath -> IO (Maybe a)) -> IO (M.HashMap UrlReference a)
loadImages dir css loadImage = foldM load M.empty $ concat [map snd block | (_,block) <- css]
where
load imap (Left _) = return imap
load imap (Right f) | f `M.member` imap = return imap
load imap (Right f@(UrlReference path)) = do
img <- loadImage (dir </> fromText path)
return $ maybe imap (\i -> M.insert f i imap) img
-- | If you tack on additional CSS post-processing filters, they use this as an argument.
data CssGeneration = CssGeneration {
cssContent :: BL.ByteString
, cssStaticLocation :: Location
, cssFileLocation :: FilePath
}
mkCssGeneration :: Location -> FilePath -> BL.ByteString -> CssGeneration
mkCssGeneration loc file content =
CssGeneration { cssContent = content
, cssStaticLocation = loc
, cssFileLocation = file
}
cssProductionFilter ::
(FilePath -> IO BL.ByteString) -- ^ a filter to be run on production
-> Location -- ^ The location the CSS file should appear in the static subsite
-> FilePath -- ^ Path to the CSS file.
-> Entry
cssProductionFilter prodFilter loc file =
def { ebHaskellName = Just $ pathToName loc
, ebLocation = loc
, ebMimeType = "text/css"
, ebProductionContent = prodFilter file
, ebDevelReload = [| develPassThrough $(litE (stringL loc)) $(litE (stringL $ encodeString file)) |]
, ebDevelExtraFiles = Nothing
}
cssProductionImageFilter :: (FilePath -> IO BL.ByteString) -> Location -> FilePath -> Entry
cssProductionImageFilter prodFilter loc file =
(cssProductionFilter prodFilter loc file)
{ ebDevelReload = [| develBgImgB64 $(litE (stringL loc)) $(litE (stringL $ encodeString file)) |]
, ebDevelExtraFiles = Just [| develExtraFiles $(litE (stringL loc)) |]
}
-------------------------------------------------------------------------------
-- Helpers for the generators
-------------------------------------------------------------------------------
-- For development, all we need to do is update the background-image url to base64 encode it.
-- We want to preserve the formatting (whitespace+newlines) during development so we do not parse
-- using css-parse. Instead we write a simple custom parser.
parseBackground :: Location -> FilePath -> PBL.Parser B.Builder
parseBackground loc file = do
void $ PBL.string "background-image"
s1 <- PBL.takeWhile (\x -> x == 32 || x == 9) -- space or tab
void $ PBL.word8 58 -- colon
s2 <- PBL.takeWhile (\x -> x == 32 || x == 9) -- space or tab
void $ PBL.string "url('"
url <- PBL.takeWhile (/= 39) -- single quote
void $ PBL.string "')"
let b64 = B64.encode $ T.encodeUtf8 (either id id $ toText (directory file)) <> url
newUrl = B.fromString (encodeString $ filename $ decodeString loc) <> B.fromString "/" <> B.fromByteString b64
return $ B.fromByteString "background-image"
<> B.fromByteString s1
<> B.fromByteString ":"
<> B.fromByteString s2
<> B.fromByteString "url('"
<> newUrl
<> B.fromByteString "')"
parseDev :: Location -> FilePath -> B.Builder -> PBL.Parser B.Builder
parseDev loc file b = do
b' <- parseBackground loc file <|> (B.fromWord8 <$> PBL.anyWord8)
(PBL.endOfInput *> (pure $! b <> b')) <|> (parseDev loc file $! b <> b')
develPassThrough :: Location -> FilePath -> IO BL.ByteString
develPassThrough _ = BL.readFile . encodeString
-- | Create the CSS during development
develBgImgB64 :: Location -> FilePath -> IO BL.ByteString
develBgImgB64 loc file = do
ct <- BL.readFile $ encodeString file
case PBL.eitherResult $ PBL.parse (parseDev loc file mempty) ct of
Left err -> error err
Right b -> return $ B.toLazyByteString b
-- | Serve the extra image files during development
develExtraFiles :: Location -> [T.Text] -> IO (Maybe (MimeType, BL.ByteString))
develExtraFiles loc parts =
case reverse parts of
(file:dir) | T.pack loc == T.intercalate "/" (reverse dir) -> do
let file' = T.decodeUtf8 $ B64.decodeLenient $ T.encodeUtf8 $ either id id $ toText $ dropExtension $ fromText file
ct <- BL.readFile $ T.unpack file'
return $ Just (defaultMimeLookup file', ct)
_ -> return Nothing

329
yesod-static/Yesod/EmbeddedStatic/Generators.hs Normal file
View File

@ -0,0 +1,329 @@
{-# LANGUAGE TemplateHaskell, QuasiQuotes, ScopedTypeVariables #-}
-- | A generator is executed at compile time to load a list of entries
-- to embed into the subsite. This module contains several basic generators,
-- but the design of generators and entries is such that it is straightforward
-- to make custom generators for your own specific purposes, see <#g:4 this section>.
module Yesod.EmbeddedStatic.Generators (
-- * Generators
Location
, embedFile
, embedFileAt
, embedDir
, embedDirAt
, concatFiles
, concatFilesWith
-- * Compression options for 'concatFilesWith'
, jasmine
, uglifyJs
, yuiJavascript
, yuiCSS
, closureJs
, compressTool
, tryCompressTools
-- * Util
, pathToName
-- * Custom Generators
-- $example
) where
import Control.Applicative ((<$>), (<*>))
import Control.Exception (try, SomeException)
import Control.Monad (forM, when)
import Control.Monad.Trans.Resource (runResourceT)
import Data.Char (isDigit, isLower)
import Data.Conduit (($$))
import Data.Default (def)
import Data.Maybe (isNothing)
import Language.Haskell.TH
import Network.Mime (defaultMimeLookup)
import System.Directory (doesDirectoryExist, getDirectoryContents, findExecutable)
import System.FilePath ((</>))
import Text.Jasmine (minifym)
import qualified Data.ByteString.Lazy as BL
import qualified Data.Conduit.List as C
import Data.Conduit.Binary (sourceHandle)
import qualified Data.Text as T
import qualified System.Process as Proc
import System.Exit (ExitCode (ExitSuccess))
import Control.Concurrent.Async (Concurrently (..))
import System.IO (hClose)
import Yesod.EmbeddedStatic.Types
-- | Embed a single file. Equivalent to passing the same string twice to 'embedFileAt'.
embedFile :: FilePath -> Generator
embedFile f = embedFileAt f f
-- | Embed a single file at a given location within the static subsite and generate a
-- route variable based on the location via 'pathToName'. The @FilePath@ must be a relative
-- path to the directory in which you run @cabal build@. During development, the file located
-- at this filepath will be reloaded on every request. When compiling for production, the contents
-- of the file will be embedded into the executable and so the file does not need to be
-- distributed along with the executable.
embedFileAt :: Location -> FilePath -> Generator
embedFileAt loc f = do
let mime = defaultMimeLookup $ T.pack f
let entry = def {
ebHaskellName = Just $ pathToName loc
, ebLocation = loc
, ebMimeType = mime
, ebProductionContent = BL.readFile f
, ebDevelReload = [| BL.readFile $(litE $ stringL f) |]
}
return [entry]
-- | List all files recursively in a directory
getRecursiveContents :: Location -- ^ The directory to search
-> FilePath -- ^ The prefix to add to the filenames
-> IO [(Location,FilePath)]
getRecursiveContents prefix topdir = do
names <- getDirectoryContents topdir
let properNames = filter (`notElem` [".", ".."]) names
paths <- forM properNames $ \name -> do
let path = topdir </> name
let loc = if null prefix then name else prefix ++ "/" ++ name
isDirectory <- doesDirectoryExist path
if isDirectory
then getRecursiveContents loc path
else return [(loc, path)]
return (concat paths)
-- | Embed all files in a directory into the static subsite.
--
-- Equivalent to passing the empty string as the location to 'embedDirAt',
-- so the directory path itself is not part of the resource locations (and so
-- also not part of the generated route variable names).
embedDir :: FilePath -> Generator
embedDir = embedDirAt ""
-- | Embed all files in a directory to a given location within the static subsite.
--
-- The directory tree rooted at the 'FilePath' (which must be relative to the directory in
-- which you run @cabal build@) is embedded into the static subsite at the given
-- location. Also, route variables will be created based on the final location
-- of each file. For example, if a directory \"static\" contains the files
--
-- * css/bootstrap.css
--
-- * js/jquery.js
--
-- * js/bootstrap.js
--
-- then @embedDirAt \"somefolder\" \"static\"@ will
--
-- * Make the file @static\/css\/bootstrap.css@ available at the location
-- @somefolder\/css\/bootstrap.css@ within the static subsite and similarly
-- for the other two files.
--
-- * Create variables @somefolder_css_bootstrap_css@, @somefolder_js_jquery_js@,
-- @somefolder_js_bootstrap_js@ all of type @Route EmbeddedStatic@.
--
-- * During development, the files will be reloaded on every request. During
-- production, the contents of all files will be embedded into the executable.
--
-- * During development, files that are added to the directory while the server
-- is running will not be detected. You need to recompile the module which
-- contains the call to @mkEmbeddedStatic@. This will also generate new route
-- variables for the new files.
embedDirAt :: Location -> FilePath -> Generator
embedDirAt loc dir = do
files <- runIO $ getRecursiveContents loc dir
concat <$> mapM (uncurry embedFileAt) files
-- | Concatinate a list of files and embed it at the location. Equivalent to passing @return@ to
-- 'concatFilesWith'.
concatFiles :: Location -> [FilePath] -> Generator
concatFiles loc files = concatFilesWith loc return files
-- | Concatinate a list of files into a single 'BL.ByteString', run the resulting content through the given
-- function, embed it at the given location, and create a haskell variable name for the route based on
-- the location.
--
-- The processing function is only run when compiling for production, and the processing function is
-- executed at compile time. During development, on every request the files listed are reloaded,
-- concatenated, and served as a single resource at the given location without being processed.
concatFilesWith :: Location -> (BL.ByteString -> IO BL.ByteString) -> [FilePath] -> Generator
concatFilesWith loc process files = do
let load = do putStrLn $ "Creating " ++ loc
BL.concat <$> mapM BL.readFile files >>= process
expFiles = listE $ map (litE . stringL) files
expCt = [| BL.concat <$> mapM BL.readFile $expFiles |]
mime = defaultMimeLookup $ T.pack loc
return [def { ebHaskellName = Just $ pathToName loc
, ebLocation = loc
, ebMimeType = mime
, ebProductionContent = load
, ebDevelReload = expCt
}]
-- | Convienient rexport of 'minifym' with a type signature to work with 'concatFilesWith'.
jasmine :: BL.ByteString -> IO BL.ByteString
jasmine ct = return $ either (const ct) id $ minifym ct
-- | Use <https://github.com/mishoo/UglifyJS2 UglifyJS2> to compress javascript.
-- Assumes @uglifyjs@ is located in the path and uses options @[\"-m\", \"-c\"]@
-- to both mangle and compress and the option \"-\" to cause uglifyjs to read from
-- standard input.
uglifyJs :: BL.ByteString -> IO BL.ByteString
uglifyJs = compressTool "uglifyjs" ["-m", "-c", "-"]
-- | Use <http://yui.github.io/yuicompressor/ YUI Compressor> to compress javascript.
-- Assumes a script @yuicompressor@ is located in the path. If not, you can still
-- use something like
--
-- > compressTool "java" ["-jar", "/path/to/yuicompressor.jar", "--type", "js"]
yuiJavascript :: BL.ByteString -> IO BL.ByteString
yuiJavascript = compressTool "yuicompressor" ["--type", "js"]
-- | Use <http://yui.github.io/yuicompressor/ YUI Compressor> to compress CSS.
-- Assumes a script @yuicompressor@ is located in the path.
yuiCSS :: BL.ByteString -> IO BL.ByteString
yuiCSS = compressTool "yuicompressor" ["--type", "css"]
-- | Use <https://developers.google.com/closure/compiler/ Closure> to compress
-- javascript using the default options. Assumes a script @closure@ is located in
-- the path. If not, you can still run using
--
-- > compressTool "java" ["-jar", "/path/to/compiler.jar"]
closureJs :: BL.ByteString -> IO BL.ByteString
closureJs = compressTool "closure" []
-- | Helper to convert a process into a compression function. The process
-- should be set up to take input from standard input and write to standard output.
compressTool :: FilePath -- ^ program
-> [String] -- ^ options
-> BL.ByteString -> IO BL.ByteString
compressTool f opts ct = do
mpath <- findExecutable f
when (isNothing mpath) $
fail $ "Unable to find " ++ f
let p = (Proc.proc f opts)
{ Proc.std_in = Proc.CreatePipe
, Proc.std_out = Proc.CreatePipe
}
(Just hin, Just hout, _, ph) <- Proc.createProcess p
(compressed, (), code) <- runConcurrently $ (,,)
<$> Concurrently (sourceHandle hout $$ C.consume)
<*> Concurrently (BL.hPut hin ct >> hClose hin)
<*> Concurrently (Proc.waitForProcess ph)
if code == ExitSuccess
then do
putStrLn $ "Compressed successfully with " ++ f
return $ BL.fromChunks compressed
else error $ "compressTool: compression failed with " ++ f
-- | Try a list of processing functions (like the compressions above) one by one until
-- one succeeds (does not raise an exception). Once a processing function succeeds,
-- none of the remaining functions are used. If none succeeds, the input is just
-- returned unprocessed. This is helpful if you are distributing
-- code on hackage and do not know what compressors the user will have installed. You
-- can list several and they will be tried in order until one succeeds.
tryCompressTools :: [BL.ByteString -> IO BL.ByteString] -> BL.ByteString -> IO BL.ByteString
tryCompressTools [] x = return x
tryCompressTools (p:ps) x = do
mres <- try $ p x
case mres of
Left (err :: SomeException) -> do
putStrLn $ show err
tryCompressTools ps x
Right res -> return res
-- | Clean up a path to make it a valid haskell name by replacing all non-letters
-- and non-numbers by underscores. In addition, if the path starts with a capital
-- letter or number add an initial underscore.
pathToName :: FilePath -> Name
pathToName f = routeName
where
replace c
| 'A' <= c && c <= 'Z' = c
| 'a' <= c && c <= 'z' = c
| '0' <= c && c <= '9' = c
| otherwise = '_'
name = map replace f
routeName = mkName $
case () of
()
| null name -> error "null-named file"
| isDigit (head name) -> '_' : name
| isLower (head name) -> name
| otherwise -> '_' : name
-- $example
-- Here is an example of creating your own custom generator.
-- Because of template haskell stage restrictions, you must define generators in a
-- different module from where you use them. The following generator will embed a
-- JSON document that contains the compile time.
--
-- >{-# LANGUAGE TemplateHaskell, QuasiQuotes, OverloadedStrings #-}
-- >module CompileTime where
-- >
-- >import Data.Aeson
-- >import Data.Default
-- >import Data.Time
-- >import Yesod.EmbeddedStatic.Generators
-- >import Yesod.EmbeddedStatic.Types
-- >import qualified Data.ByteString.Lazy as BL
-- >
-- >getTime :: IO BL.ByteString
-- >getTime = do
-- > t <- getCurrentTime
-- > return $ encode $
-- > object [ "compile_time" .= show t ]
-- >
-- >timeGenerator :: Location -> Generator
-- >timeGenerator loc =
-- > return $ [def
-- > { ebHaskellName = Just $ pathToName loc
-- > , ebLocation = loc
-- > , ebMimeType = "application/json"
-- > , ebProductionContent = getTime
-- > , ebDevelReload = [| getTime |]
-- > }]
--
-- Notice how the @getTime@ action is given as both 'ebProductionContent' and
-- 'ebDevelReload'. The result is that during development, the @getTime@ action
-- will be re-executed on every request so the time returned will be different
-- for each reload. When compiling for production, the @getTime@ action will
-- be executed once at compile time to produce the content to embed and never
-- called at runtime.
--
-- Here is a small example yesod program using this generator. Try toggling
-- the development argument to @mkEmbeddedStatic@.
--
-- >{-# LANGUAGE TemplateHaskell, QuasiQuotes, TypeFamilies #-}
-- >module Main where
-- >
-- >import Yesod
-- >import Yesod.EmbeddedStatic
-- >import CompileTime (timeGenerator)
-- >
-- >mkEmbeddedStatic True "eStatic" [timeGenerator "compile-time.json"]
-- >
-- >-- The above will generate variables
-- >-- eStatic :: EmbeddedStatic
-- >-- compile_time_json :: Route EmbeddedStatic
-- >
-- >data MyApp = MyApp { getStatic :: EmbeddedStatic }
-- >
-- >mkYesod "MyApp" [parseRoutes|
-- >/ HomeR GET
-- >/static StaticR EmbeddedStatic getStatic
-- >|]
-- >
-- >instance Yesod MyApp
-- >
-- >getHomeR :: Handler Html
-- >getHomeR = defaultLayout $ [whamlet|
-- ><h1>Hello
-- ><p>Check the
-- > <a href=@{StaticR compile_time_json}>compile time
-- >|]
-- >
-- >main :: IO ()
-- >main = warp 3000 $ MyApp eStatic

187
yesod-static/Yesod/EmbeddedStatic/Internal.hs Normal file
View File

@ -0,0 +1,187 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE CPP #-}
module Yesod.EmbeddedStatic.Internal (
EmbeddedStatic(..)
, Route(..)
, ComputedEntry(..)
, devEmbed
, prodEmbed
, develApp
, AddStaticContent
, staticContentHelper
, widgetSettings
) where
import Control.Applicative ((<$>))
import Data.IORef
import Language.Haskell.TH
import Network.HTTP.Types (Status(..), status404, status200, status304)
import Network.Mime (MimeType)
import Network.Wai
import Network.Wai.Application.Static (defaultWebAppSettings, staticApp)
import WaiAppStatic.Types
import Yesod.Core
( HandlerT
, ParseRoute(..)
, RenderRoute(..)
, Yesod(..)
, getYesod
, liftIO
)
import qualified Data.ByteString.Lazy as BL
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.HashMap.Strict as M
import qualified WaiAppStatic.Storage.Embedded as Static
import Yesod.Static (base64md5)
import Yesod.EmbeddedStatic.Types
#if !MIN_VERSION_base(4,6,0)
-- copied from base
atomicModifyIORef' :: IORef a -> (a -> (a,b)) -> IO b
atomicModifyIORef' ref f = do
b <- atomicModifyIORef ref
(\x -> let (a, b) = f x
in (a, a `seq` b))
b `seq` return b
#endif
-- | The subsite for the embedded static file server.
data EmbeddedStatic = EmbeddedStatic {
stApp :: !Application
, widgetFiles :: !(IORef (M.HashMap T.Text File))
}
instance RenderRoute EmbeddedStatic where
data Route EmbeddedStatic = EmbeddedResourceR [T.Text] [(T.Text,T.Text)]
| EmbeddedWidgetR T.Text
deriving (Eq, Show, Read)
renderRoute (EmbeddedResourceR x y) = ("res":x, y)
renderRoute (EmbeddedWidgetR h) = (["widget",h], [])
instance ParseRoute EmbeddedStatic where
parseRoute (("res":x), y) = Just $ EmbeddedResourceR x y
parseRoute (["widget",h], _) = Just $ EmbeddedWidgetR h
parseRoute _ = Nothing
-- | At compile time, one of these is created for every 'Entry' created by
-- the generators. The cLink is a template haskell expression of type @Route EmbeddedStatic@.
data ComputedEntry = ComputedEntry {
cHaskellName :: Maybe Name -- ^ Optional haskell name to create a variable for the route
, cStEntry :: Static.EmbeddableEntry -- ^ The entry to be embedded into the executable
, cLink :: ExpQ -- ^ The route for this entry
}
mkStr :: String -> ExpQ
mkStr = litE . stringL
-- | Create a 'ComputedEntry' for development mode, reloading the content on every request.
devEmbed :: Entry -> IO ComputedEntry
devEmbed e = return computed
where
st = Static.EmbeddableEntry {
Static.eLocation = "res/" `T.append` T.pack (ebLocation e)
, Static.eMimeType = ebMimeType e
, Static.eContent = Right [| $(ebDevelReload e) >>= \c ->
return (T.pack (base64md5 c), c) |]
}
link = [| EmbeddedResourceR (T.splitOn (T.pack "/") $ T.pack $(mkStr $ ebLocation e)) [] |]
computed = ComputedEntry (ebHaskellName e) st link
-- | Create a 'ComputedEntry' for production mode, hashing and embedding the content into the executable.
prodEmbed :: Entry -> IO ComputedEntry
prodEmbed e = do
ct <- ebProductionContent e
let hash = base64md5 ct
link = [| EmbeddedResourceR (T.splitOn (T.pack "/") $ T.pack $(mkStr $ ebLocation e))
[(T.pack "etag", T.pack $(mkStr hash))] |]
st = Static.EmbeddableEntry {
Static.eLocation = "res/" `T.append` T.pack (ebLocation e)
, Static.eMimeType = ebMimeType e
, Static.eContent = Left (T.pack hash, ct)
}
return $ ComputedEntry (ebHaskellName e) st link
toApp :: (Request -> IO Response) -> Application
#if MIN_VERSION_wai(3, 0, 0)
toApp f req g = f req >>= g
#else
toApp = id
#endif
tryExtraDevelFiles :: [[T.Text] -> IO (Maybe (MimeType, BL.ByteString))] -> Application
tryExtraDevelFiles = toApp . tryExtraDevelFiles'
tryExtraDevelFiles' :: [[T.Text] -> IO (Maybe (MimeType, BL.ByteString))] -> Request -> IO Response
tryExtraDevelFiles' [] _ = return $ responseLBS status404 [] ""
tryExtraDevelFiles' (f:fs) r = do
mct <- liftIO $ f $ drop 1 $ pathInfo r -- drop the initial "res"
case mct of
Nothing -> tryExtraDevelFiles' fs r
Just (mime, ct) -> do
let hash = T.encodeUtf8 $ T.pack $ base64md5 ct
let headers = [ ("Content-Type", mime)
, ("ETag", hash)
]
case lookup "If-None-Match" (requestHeaders r) of
Just h | hash == h -> return $ responseLBS status304 headers ""
_ -> return $ responseLBS status200 headers ct
-- | Helper to create the development application at runtime
develApp :: StaticSettings -> [[T.Text] -> IO (Maybe (MimeType, BL.ByteString))] -> Application
#if MIN_VERSION_wai(3, 0, 0)
develApp settings extra req sendResponse = do
staticApp settings {ssMaxAge = NoMaxAge} req $ \resp ->
if statusCode (responseStatus resp) == 404
then tryExtraDevelFiles extra req sendResponse
else sendResponse resp
#else
develApp settings extra req = do
resp <- staticApp settings {ssMaxAge = NoMaxAge} req
if statusCode (responseStatus resp) == 404
then tryExtraDevelFiles extra req
else return resp
#endif
-- | The type of 'addStaticContent'
type AddStaticContent site = T.Text -> T.Text -> BL.ByteString
-> HandlerT site IO (Maybe (Either T.Text (Route site, [(T.Text, T.Text)])))
-- | Helper for embedStaticContent and embedLicensedStaticContent.
staticContentHelper :: Yesod site
=> (site -> EmbeddedStatic)
-> (Route EmbeddedStatic -> Route site)
-> (BL.ByteString -> Either a BL.ByteString)
-> AddStaticContent site
staticContentHelper getStatic staticR minify ext _ ct = do
wIORef <- widgetFiles . getStatic <$> getYesod
let hash = T.pack $ base64md5 ct
hash' = Just $ T.encodeUtf8 hash
filename = T.concat [hash, ".", ext]
content = case ext of
"js" -> either (const ct) id $ minify ct
_ -> ct
file = File
{ fileGetSize = fromIntegral $ BL.length content
, fileToResponse = \s h -> responseLBS s h content
, fileName = unsafeToPiece filename
, fileGetHash = return hash'
, fileGetModified = Nothing
}
liftIO $ atomicModifyIORef' wIORef $ \m ->
(M.insertWith (\old _ -> old) filename file m, ())
return $ Just $ Right (staticR $ EmbeddedWidgetR filename, [])
-- | Create a wai-app-static settings based on the IORef inside the EmbeddedStaic site.
widgetSettings :: EmbeddedStatic -> StaticSettings
widgetSettings es = (defaultWebAppSettings "") { ssLookupFile = lookupFile }
where
lookupFile [_,p] = do -- The first part of the path is "widget"
m <- readIORef $ widgetFiles es
return $ maybe LRNotFound LRFile $ M.lookup (fromPiece p) m
lookupFile _ = return LRNotFound

67
yesod-static/Yesod/EmbeddedStatic/Types.hs Normal file
View File

@ -0,0 +1,67 @@
{-# LANGUAGE TemplateHaskell, QuasiQuotes, OverloadedStrings #-}
module Yesod.EmbeddedStatic.Types(
Location
, Generator
-- ** Entry
, Entry
, ebHaskellName
, ebLocation
, ebMimeType
, ebProductionContent
, ebDevelReload
, ebDevelExtraFiles
) where
import Data.Default
import Language.Haskell.TH
import Network.Mime (MimeType)
import qualified Data.ByteString.Lazy as BL
-- | A location is a relative path within the static subsite at which resource(s) are made available.
-- The location can include slashes to simulate directories but must not start or end with a slash.
type Location = String
-- | A single resource embedded into the executable at compile time.
--
-- This data type is a settings type. For more information, see
-- <http://www.yesodweb.com/book/settings-types>.
data Entry = Entry {
ebHaskellName :: Maybe Name
-- ^ An optional haskell name. If the name is present, a variable
-- of type @Route 'Yesod.EmbeddedStatic.EmbeddedStatic'@ with the
-- given name will be created which points to this resource.
, ebLocation :: Location -- ^ The location to serve the resource from.
, ebMimeType :: MimeType -- ^ The mime type of the resource.
, ebProductionContent :: IO BL.ByteString
-- ^ If the development argument to 'Yesod.EmbeddedStatic.mkEmbeddedStatic' is False,
-- then at compile time this action will be executed to load the content.
-- During development, this action will not be executed.
, ebDevelReload :: ExpQ
-- ^ This must be a template haskell expression of type @IO 'BL.ByteString'@.
-- If the development argument to 'Yesod.EmbeddedStatic.mkEmbeddedStatic' is True,
-- this action is executed on every request to compute the content. Most of the
-- time, 'ebProductionContent' and 'ebDevelReload' should be the same action but
-- occasionally you might want additional processing inside the 'ebProductionContent'
-- function like javascript/css minification to only happen when building for production.
, ebDevelExtraFiles :: Maybe ExpQ
-- ^ Occasionally, during development an entry needs extra files/resources available
-- that are not present during production (for example, image files that are embedded
-- into the CSS at production but left unembedded during development). If present,
-- @ebDevelExtraFiles@ must be a template haskell expression of type
-- @['T.Text'] -> IO (Maybe ('MimeType', 'BL.ByteString'))@. That is, a function
-- taking as input the list of path pieces and optionally returning a mime type
-- and content.
}
-- | When using 'def', you must fill in at least 'ebLocation'.
instance Default Entry where
def = Entry { ebHaskellName = Nothing
, ebLocation = "xxxx"
, ebMimeType = "application/octet-stream"
, ebProductionContent = return BL.empty
, ebDevelReload = [| return BL.empty |]
, ebDevelExtraFiles = Nothing
}
-- | An embedded generator is executed at compile time to produce the entries to embed.
type Generator = Q [Entry]

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

@ -35,7 +35,6 @@ module Yesod.Static
-- * Smart constructor
, static
, staticDevel
, embed
-- * Combining CSS/JS
-- $combining
, combineStylesheets'
@ -54,6 +53,8 @@ module Yesod.Static
, publicFiles
-- * Hashing
, base64md5
-- * Embed
, embed
#ifdef TEST_EXPORT
, getFileListPieces
#endif
@ -65,6 +66,7 @@ import System.Directory
import Control.Monad
import Data.FileEmbed (embedDir)
import Control.Monad.Trans.Resource (runResourceT)
import Yesod.Core
import Yesod.Core.Types
@ -72,14 +74,14 @@ import Data.List (intercalate)
import Language.Haskell.TH
import Language.Haskell.TH.Syntax as TH
import Crypto.Conduit (hashFile, sinkHash)
import Crypto.Hash.MD5 (MD5)
import Crypto.Hash.Conduit (hashFile, sinkHash)
import Crypto.Hash (MD5, Digest)
import Control.Monad.Trans.State
import qualified Data.Byteable as Byteable
import qualified Data.ByteString.Base64
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as L
import qualified Data.Serialize
import Data.Text (Text, pack)
import qualified Data.Text as T
import qualified Data.Map as M
@ -100,7 +102,7 @@ import Filesystem (createTree)
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TLE
import Data.Default
import Text.Lucius (luciusRTMinified)
--import Text.Lucius (luciusRTMinified)
import Network.Wai.Application.Static
( StaticSettings (..)
@ -134,8 +136,11 @@ staticDevel dir = do
hashLookup <- cachedETagLookupDevel dir
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.
-- | Produce a 'Static' based on embedding all of the static files' contents in the
-- executable at compile time.
--
-- You should use "Yesod.EmbeddedStatic" instead, it is much more powerful.
--
-- 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
@ -222,7 +227,7 @@ getFileListPieces = flip evalStateT M.empty . flip go id
-- definitions would be created:
--
-- > style_css = StaticRoute ["style.css"] []
-- > js_script_js = StaticRoute ["js/script.js"] []
-- > js_script_js = StaticRoute ["js", "script.js"] []
--
-- Note that dots (@.@), dashes (@-@) and slashes (@\/@) are
-- replaced by underscores (@\_@) to create valid Haskell
@ -355,7 +360,7 @@ mkStaticFilesList fp fs routeConName makeHash = do
base64md5File :: Prelude.FilePath -> IO String
base64md5File = fmap (base64 . encode) . hashFile
where encode d = Data.Serialize.encode (d :: MD5)
where encode d = Byteable.toBytes (d :: Digest MD5)
base64md5 :: L.ByteString -> String
base64md5 lbs =
@ -363,7 +368,7 @@ base64md5 lbs =
$ runIdentity
$ sourceList (L.toChunks lbs) $$ sinkHash
where
encode d = Data.Serialize.encode (d :: MD5)
encode d = Byteable.toBytes (d :: Digest MD5)
base64 :: S.ByteString -> String
base64 = map tr
@ -442,7 +447,7 @@ data CombineSettings = CombineSettings
, csCssPostProcess :: [FilePath] -> L.ByteString -> IO L.ByteString
-- ^ Post processing to be performed on CSS files.
--
-- Default: Use Lucius to minify.
-- Default: Pass-through.
--
-- Since 1.2.0
, csJsPostProcess :: [FilePath] -> L.ByteString -> IO L.ByteString
@ -474,10 +479,13 @@ data CombineSettings = CombineSettings
instance Default CombineSettings where
def = CombineSettings
{ csStaticDir = "static"
{- Disabled due to: https://github.com/yesodweb/yesod/issues/623
, csCssPostProcess = \fps ->
either (error . (errorIntro fps)) (return . TLE.encodeUtf8)
. flip luciusRTMinified []
. TLE.decodeUtf8
-}
, csCssPostProcess = const return
, csJsPostProcess = const return
-- FIXME The following borders on a hack. With combining of files,
-- the final location of the CSS is no longer fixed, so relative

53
yesod-static/sample-embed.hs
View File

@ -1,23 +1,42 @@
{-# LANGUAGE QuasiQuotes, TypeFamilies, MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
import Yesod.Static
import Yesod.Dispatch
{-# LANGUAGE TemplateHaskell, QuasiQuotes, TypeFamilies #-}
-- | This embeds just a single file; it embeds the source code file
-- \"sample-embed.hs\" from the current directory so when you compile,
-- the sample-embed.hs file must be in the current directory.
--
-- Try toggling the development argument to 'mkEmbeddedStatic'. When the
-- development argument is true the file \"sample-embed.hs\" is reloaded
-- from disk on every request (try changing it after you start the server).
-- When development is false, the contents are embedded and the sample-embed.hs
-- file does not even need to be present during runtime.
module Main where
import Yesod.Core
import Network.Wai.Handler.Warp (run)
import Yesod.EmbeddedStatic
staticFiles "."
mkEmbeddedStatic False "eStatic" [embedFile "sample-embed.hs"]
data Sample = Sample
getStatic _ = $(embed "tests")
mkYesod "Sample" [parseRoutes|
/ RootR GET
/static StaticR Static getStatic
-- The above will generate variables
-- eStatic :: EmbeddedStatic
-- sample_embed_hs :: Route EmbeddedStatic
data MyApp = MyApp { getStatic :: EmbeddedStatic }
mkYesod "MyApp" [parseRoutes|
/ HomeR GET
/static StaticR EmbeddedStatic getStatic
|]
instance Yesod Sample where approot _ = ""
getRootR = do
redirectText RedirectPermanent "static"
return ()
instance Yesod MyApp where
addStaticContent = embedStaticContent getStatic StaticR Right
main = toWaiApp Sample >>= run 3000
getHomeR :: Handler Html
getHomeR = defaultLayout $ do
toWidget [julius|console.log("Hello World");|]
[whamlet|
<h1>Hello
<p>Check the
<a href=@{StaticR sample_embed_hs}>embedded file
|]
main :: IO ()
main = warp 3000 $ MyApp eStatic

95
yesod-static/test/EmbedDevelTest.hs Normal file
View File

@ -0,0 +1,95 @@
{-# LANGUAGE TemplateHaskell, QuasiQuotes, TypeFamilies, OverloadedStrings #-}
module EmbedDevelTest where
-- Tests the development mode of the embedded static subsite by
-- using a custom generator testGen.
import Data.Maybe (isNothing)
import EmbedTestGenerator
import EmbedProductionTest (findEtag)
import Network.Wai.Test (SResponse(simpleHeaders))
import Test.HUnit (assertBool)
import Test.Hspec (Spec)
import Yesod.Core
import Yesod.EmbeddedStatic
import Yesod.Test
mkEmbeddedStatic True "eDev" [testGen]
data MyApp = MyApp { getStatic :: EmbeddedStatic }
mkYesod "MyApp" [parseRoutes|
/static StaticR EmbeddedStatic getStatic
|]
instance Yesod MyApp
noCacheControl :: YesodExample site ()
noCacheControl = withResponse $ \r -> do
liftIO $ assertBool "Cache-Control exists" $
isNothing $ lookup "Cache-Control" $ simpleHeaders r
liftIO $ assertBool "Expires exists" $
isNothing $ lookup "Expires" $ simpleHeaders r
embedDevSpecs :: Spec
embedDevSpecs = yesodSpec (MyApp eDev) $ do
ydescribe "Embedded Development Entries" $ do
yit "e1 loads" $ do
get $ StaticR e1
statusIs 200
assertHeader "Content-Type" "text/plain"
noCacheControl
bodyEquals "e1 devel"
tag <- findEtag
request $ do
setMethod "GET"
setUrl $ StaticR e1
addRequestHeader ("If-None-Match", tag)
statusIs 304
yit "e2 with simulated directory" $ do
get $ StaticR e2
statusIs 200
assertHeader "Content-Type" "abcdef"
noCacheControl
bodyEquals "e2 devel"
yit "e3 without haskell name" $ do
get $ StaticR $ embeddedResourceR ["xxxx", "e3"] []
statusIs 200
assertHeader "Content-Type" "yyy"
noCacheControl
bodyEquals "e3 devel"
yit "e4 loads" $ do
get $ StaticR e4
statusIs 200
assertHeader "Content-Type" "text/plain"
noCacheControl
bodyEquals "e4 devel"
yit "e4 extra development dev1" $ do
get $ StaticR $ embeddedResourceR ["dev1"] []
statusIs 200
assertHeader "Content-Type" "mime"
noCacheControl
bodyEquals "dev1 content"
tag <- findEtag
request $ do
setMethod "GET"
setUrl $ StaticR $ embeddedResourceR ["dev1"] []
addRequestHeader ("If-None-Match", tag)
statusIs 304
yit "e4 extra development with path" $ do
get $ StaticR $ embeddedResourceR ["dir", "dev2"] []
statusIs 200
assertHeader "Content-Type" "mime2"
noCacheControl
bodyEquals "dev2 content"
yit "extra development file 404" $ do
get $ StaticR $ embeddedResourceR ["xxxxxxxxxx"] []
statusIs 404

118
yesod-static/test/EmbedProductionTest.hs Normal file
View File

@ -0,0 +1,118 @@
{-# LANGUAGE TemplateHaskell, QuasiQuotes, TypeFamilies, OverloadedStrings #-}
module EmbedProductionTest where
-- Tests the production mode of the embedded static subsite by
-- using a custom generator testGen. Also tests that the widget
-- content is embedded properly.
import Data.Maybe (isJust)
import EmbedTestGenerator
import Network.Wai.Test (SResponse(simpleHeaders))
import Test.HUnit (assertFailure, assertBool)
import Test.Hspec (Spec)
import Yesod.Core
import Yesod.EmbeddedStatic
import Yesod.Test
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TL
mkEmbeddedStatic False "eProduction" [testGen]
data MyApp = MyApp { getStatic :: EmbeddedStatic }
mkYesod "MyApp" [parseRoutes|
/ HomeR GET
/static StaticR EmbeddedStatic getStatic
|]
getHomeR :: Handler Html
getHomeR = defaultLayout $ do
toWidget [julius|console.log("Hello World");|]
[whamlet|<h1>Hello|]
instance Yesod MyApp where
addStaticContent = embedStaticContent getStatic StaticR Right
findEtag :: YesodExample site B.ByteString
findEtag = withResponse $ \r ->
case lookup "ETag" (simpleHeaders r) of
Nothing -> liftIO (assertFailure "No etag found") >> error ""
Just e -> return e
hasCacheControl :: YesodExample site ()
hasCacheControl = withResponse $ \r -> do
liftIO $ assertBool "Cache-Control missing" $
isJust $ lookup "Cache-Control" $ simpleHeaders r
liftIO $ assertBool "Expires missing" $
isJust $ lookup "Expires" $ simpleHeaders r
embedProductionSpecs :: Spec
embedProductionSpecs = yesodSpec (MyApp eProduction) $ do
ydescribe "Embedded Production Entries" $ do
yit "e1 loads" $ do
get $ StaticR e1
statusIs 200
assertHeader "Content-Type" "text/plain"
hasCacheControl
bodyEquals "e1 production"
tag <- findEtag
request $ do
setMethod "GET"
setUrl $ StaticR e1
addRequestHeader ("If-None-Match", tag)
statusIs 304
yit "e1 with custom built path" $ do
get $ StaticR $ embeddedResourceR ["e1"] []
statusIs 200
assertHeader "Content-Type" "text/plain"
hasCacheControl
bodyEquals "e1 production"
yit "e2 with simulated directory" $ do
get $ StaticR e2
statusIs 200
assertHeader "Content-Type" "abcdef"
hasCacheControl
bodyEquals "e2 production"
yit "e2 with custom built directory path" $ do
get $ StaticR $ embeddedResourceR ["dir", "e2"] []
statusIs 200
assertHeader "Content-Type" "abcdef"
hasCacheControl
bodyEquals "e2 production"
yit "e3 without haskell name" $ do
get $ StaticR $ embeddedResourceR ["xxxx", "e3"] []
statusIs 200
assertHeader "Content-Type" "yyy"
hasCacheControl
bodyEquals "e3 production"
yit "e4 is embedded" $ do
get $ StaticR e4
statusIs 200
assertHeader "Content-Type" "text/plain"
hasCacheControl
bodyEquals "e4 production"
yit "e4 extra development files are not embedded" $ do
get $ StaticR $ embeddedResourceR ["dev1"] []
statusIs 404
ydescribe "Embedded Widget Content" $
yit "Embedded Javascript" $ do
get HomeR
statusIs 200
[script] <- htmlQuery "script"
let src = BL.takeWhile (/= 34) $ BL.drop 1 $ BL.dropWhile (/= 34) script -- 34 is "
get $ TL.toStrict $ TL.decodeUtf8 src
statusIs 200
hasCacheControl
assertHeader "Content-Type" "application/javascript"
bodyEquals "console.log(\"Hello World\");"

62
yesod-static/test/EmbedTestGenerator.hs Normal file
View File

@ -0,0 +1,62 @@
{-# LANGUAGE TemplateHaskell, QuasiQuotes, OverloadedStrings #-}
module EmbedTestGenerator (testGen) where
import Data.Default
import Network.Mime (MimeType)
import Yesod.EmbeddedStatic.Types
import Yesod.EmbeddedStatic.Generators (pathToName)
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TL
import qualified Data.ByteString.Lazy as BL
e1, e2, e3, e4 :: Entry
-- Basic entry
e1 = def
{ ebHaskellName = Just $ pathToName "e1"
, ebLocation = "e1"
, ebMimeType = "text/plain"
, ebProductionContent = return $ TL.encodeUtf8 "e1 production"
, ebDevelReload = [| return $ TL.encodeUtf8 $ TL.pack "e1 devel" |]
, ebDevelExtraFiles = Nothing
}
-- Test simulated directory in location
e2 = def
{ ebHaskellName = Just $ pathToName "e2"
, ebLocation = "dir/e2"
, ebMimeType = "abcdef"
, ebProductionContent = return $ TL.encodeUtf8 "e2 production"
, ebDevelReload = [| return $ TL.encodeUtf8 $ TL.pack "e2 devel" |]
, ebDevelExtraFiles = Nothing
}
-- Test empty haskell name
e3 = def
{ ebHaskellName = Nothing
, ebLocation = "xxxx/e3"
, ebMimeType = "yyy"
, ebProductionContent = return $ TL.encodeUtf8 "e3 production"
, ebDevelReload = [| return $ TL.encodeUtf8 $ TL.pack "e3 devel" |]
, ebDevelExtraFiles = Nothing
}
devExtra :: [T.Text] -> IO (Maybe (MimeType, BL.ByteString))
devExtra ["dev1"] = return $ Just ("mime", "dev1 content")
devExtra ["dir", "dev2"] = return $ Just ("mime2", "dev2 content")
devExtra _ = return Nothing
-- Entry with devel extra files
e4 = def
{ ebHaskellName = Just $ pathToName "e4"
, ebLocation = "e4"
, ebMimeType = "text/plain"
, ebProductionContent = return $ TL.encodeUtf8 "e4 production"
, ebDevelReload = [| return $ TL.encodeUtf8 $ TL.pack "e4 devel" |]
, ebDevelExtraFiles = Just [| devExtra |]
}
testGen :: Generator
testGen = return [e1, e2, e3, e4]

92
yesod-static/test/FileGeneratorTests.hs Normal file
View File

@ -0,0 +1,92 @@
{-# LANGUAGE TemplateHaskell, QuasiQuotes, OverloadedStrings #-}
module FileGeneratorTests (fileGenSpecs) where
import Control.Exception
import Control.Monad (forM_)
import GeneratorTestUtil
import Test.Hspec
import Test.HUnit (assertFailure, assertEqual)
import Yesod.EmbeddedStatic.Generators
import qualified Data.ByteString.Lazy as BL
-- | Embeds the LICENSE file
license :: GenTestResult
license = $(embedFile "LICENSE" >>=
testOneEntry (Just "_LICENSE") "LICENSE" (BL.readFile "LICENSE")
)
licenseAt :: GenTestResult
licenseAt = $(embedFileAt "abc.txt" "LICENSE" >>=
testOneEntry (Just "abc_txt") "abc.txt" (BL.readFile "LICENSE")
)
embDir :: [GenTestResult]
embDir = $(embedDir "test/embed-dir" >>=
testEntries
[ (Just "abc_def_txt", "abc/def.txt", BL.readFile "test/embed-dir/abc/def.txt")
, (Just "lorem_txt", "lorem.txt", BL.readFile "test/embed-dir/lorem.txt")
, (Just "foo", "foo", BL.readFile "test/embed-dir/foo")
]
)
embDirAt :: [GenTestResult]
embDirAt = $(embedDirAt "xxx" "test/embed-dir" >>=
testEntries
[ (Just "xxx_abc_def_txt", "xxx/abc/def.txt", BL.readFile "test/embed-dir/abc/def.txt")
, (Just "xxx_lorem_txt", "xxx/lorem.txt", BL.readFile "test/embed-dir/lorem.txt")
, (Just "xxx_foo", "xxx/foo", BL.readFile "test/embed-dir/foo")
]
)
concatR :: GenTestResult
concatR = $(concatFiles "out.txt" [ "test/embed-dir/abc/def.txt", "test/embed-dir/foo"] >>=
testOneEntry (Just "out_txt") "out.txt" (return "Yesod Rocks\nBar\n")
)
-- The transform function should only run at compile for the production content
concatWithR :: GenTestResult
concatWithR = $(concatFilesWith "out2.txt"
(\x -> return $ x `BL.append` "Extra")
[ "test/embed-dir/abc/def.txt", "test/embed-dir/foo"] >>=
testOneEntry (Just "out2_txt") "out2.txt" (return "Yesod Rocks\nBar\nExtra")
)
fileGenSpecs :: Spec
fileGenSpecs = do
describe "Embed File" $ do
it "embeds a single file" $
assertGenResult (BL.readFile "LICENSE") license
it "embeds a single file at a location" $
assertGenResult (BL.readFile "LICENSE") licenseAt
describe "Embed Directory" $ do
it "embeds a directory" $
forM_ [embDir, embDirAt] $ \d -> case d of
[GenError e] -> assertFailure e
[def, foo, lorem] -> do
assertGenResult (BL.readFile "test/embed-dir/abc/def.txt") def
assertGenResult (BL.readFile "test/embed-dir/foo") foo
assertGenResult (BL.readFile "test/embed-dir/lorem.txt") lorem
_ -> assertFailure "Bad directory list"
describe "Concat Files" $ do
it "simple concat" $
assertGenResult (return "Yesod Rocks\nBar\n") concatR
it "concat with processing function" $
assertGenResult (return "Yesod Rocks\nBar\n") concatWithR -- no Extra since this is development
describe "Compress" $ do
it "compress tool function" $ do
out <- compressTool "runhaskell" [] "main = putStrLn \"Hello World\""
assertEqual "" "Hello World\n" out
it "tryCompressTools" $ do
out <- flip tryCompressTools "abcdef"
[ const $ throwIO $ ErrorCall "An expected error"
, const $ return "foo"
, const $ return "bar"
]
assertEqual "" "foo" out
out2 <- flip tryCompressTools "abcdef"
[ const $ throwIO $ ErrorCall "An expected error"]
assertEqual "" "abcdef" out2

59
yesod-static/test/GeneratorTestUtil.hs Normal file
View File

@ -0,0 +1,59 @@
{-# LANGUAGE TemplateHaskell, QuasiQuotes, OverloadedStrings #-}
module GeneratorTestUtil where
import Control.Applicative
import Control.Monad (when)
import Data.List (sortBy)
import Language.Haskell.TH
import Test.HUnit
import Yesod.EmbeddedStatic.Types
import qualified Data.ByteString.Lazy as BL
-- We test the generators by executing them at compile time
-- and sticking the result into the GenTestResult. We then
-- test the GenTestResult at runtime. But to test the ebDevelReload
-- we must run the action at runtime so that is also embedded.
-- Because of template haskell stage restrictions, this code
-- needs to be in a separate module.
data GenTestResult = GenError String
| GenSuccessWithDevel (IO BL.ByteString)
-- | Creates a GenTestResult at compile time by testing the entry.
testEntry :: Maybe String -> Location -> IO BL.ByteString -> Entry -> ExpQ
testEntry name _ _ e | ebHaskellName e /= (mkName <$> name) =
[| GenError ("haskell name " ++ $(litE $ stringL $ show $ ebHaskellName e)
++ " /= "
++ $(litE $ stringL $ show name)) |]
testEntry _ loc _ e | ebLocation e /= loc =
[| GenError ("location " ++ $(litE $ stringL $ show $ ebLocation e)) |]
testEntry _ _ act e = do
expected <- runIO act
actual <- runIO $ ebProductionContent e
if expected == actual
then [| GenSuccessWithDevel $(ebDevelReload e) |]
else [| GenError "production content" |]
testOneEntry :: Maybe String -> Location -> IO BL.ByteString -> [Entry] -> ExpQ
testOneEntry name loc ct [e] = testEntry name loc ct e
testOneEntry _ _ _ _ = [| GenError "not exactly one entry" |]
-- | Tests a list of entries
testEntries :: [(Maybe String, Location, IO BL.ByteString)] -> [Entry] -> ExpQ
testEntries a b | length a /= length b = [| [GenError "lengths differ"] |]
testEntries a b = listE $ zipWith f a' b'
where
a' = sortBy (\(_,l1,_) (_,l2,_) -> compare l1 l2) a
b' = sortBy (\e1 e2 -> ebLocation e1 `compare` ebLocation e2) b
f (name, loc, ct) e = testEntry name loc ct e
-- | Use this at runtime to assert the 'GenTestResult' is OK
assertGenResult :: (IO BL.ByteString) -- ^ expected development content
-> GenTestResult -- ^ test result created at compile time
-> Assertion
assertGenResult _ (GenError e) = assertFailure ("invalid " ++ e)
assertGenResult mexpected (GenSuccessWithDevel mactual) = do
expected <- mexpected
actual <- mactual
when (expected /= actual) $
assertFailure "invalid devel content"

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