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

Merge pull request #1464 from yesodweb/better-monads

Browse Source 
Better monads
This commit is contained in:
Michael Snoyman 2018-02-02 11:27:06 +02:00 committed by GitHub
commit ce0c697659
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
95 changed files with 1376 additions and 1854 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

129
.travis.yml
View File

@ -11,7 +11,7 @@
# Use new container infrastructure to enable caching
sudo: false
# Choose a lightweight base image; we provide our own build tools.
# Do not choose a language; we provide our own build tools.
language: generic
# Caching so the next build will be fast too.
@ -35,27 +35,12 @@ matrix:
include:
# We grab the appropriate GHC and cabal-install versions from hvr's PPA. See:
# https://github.com/hvr/multi-ghc-travis
#- env: BUILD=cabal GHCVER=7.0.4 CABALVER=1.16 HAPPYVER=1.19.5 ALEXVER=3.1.7
# compiler: ": #GHC 7.0.4"
# addons: {apt: {packages: [cabal-install-1.16,ghc-7.0.4,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}}
#- env: BUILD=cabal GHCVER=7.2.2 CABALVER=1.16 HAPPYVER=1.19.5 ALEXVER=3.1.7
# compiler: ": #GHC 7.2.2"
# addons: {apt: {packages: [cabal-install-1.16,ghc-7.2.2,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}}
#- env: BUILD=cabal GHCVER=7.4.2 CABALVER=1.16 HAPPYVER=1.19.5 ALEXVER=3.1.7
# compiler: ": #GHC 7.4.2"
# addons: {apt: {packages: [cabal-install-1.16,ghc-7.4.2,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}}
#- env: BUILD=cabal GHCVER=7.6.3 CABALVER=1.16 HAPPYVER=1.19.5 ALEXVER=3.1.7
# compiler: ": #GHC 7.6.3"
# addons: {apt: {packages: [cabal-install-1.16,ghc-7.6.3,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}}
- env: BUILD=cabal GHCVER=7.8.4 CABALVER=1.18 HAPPYVER=1.19.5 ALEXVER=3.1.7
compiler: ": #GHC 7.8.4"
addons: {apt: {packages: [cabal-install-1.18,ghc-7.8.4,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}}
- env: BUILD=cabal GHCVER=7.10.3 CABALVER=1.22 HAPPYVER=1.19.5 ALEXVER=3.1.7
compiler: ": #GHC 7.10.3"
addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}}
- env: BUILD=cabal GHCVER=8.0.2 CABALVER=1.24 HAPPYVER=1.19.5 ALEXVER=3.1.7
compiler: ": #GHC 8.0.2"
addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.2,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}}
- env: BUILD=cabal GHCVER=8.2.2 CABALVER=2.0 HAPPYVER=1.19.5 ALEXVER=3.1.7
compiler: ": #GHC 8.2.2"
addons: {apt: {packages: [cabal-install-2.0,ghc-8.2.2,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}}
# Build with the newest GHC and cabal-install. This is an accepted failure,
# see below.
@ -69,32 +54,40 @@ matrix:
compiler: ": #stack default"
addons: {apt: {packages: [libgmp-dev]}}
- env: BUILD=stack ARGS="--resolver lts-6"
compiler: ": #stack 7.10.3"
- env: BUILD=stack ARGS="--resolver lts-7"
compiler: ": #stack 8.0.1"
addons: {apt: {packages: [libgmp-dev]}}
- env: BUILD=stack ARGS="--resolver lts-8"
- env: BUILD=stack ARGS="--resolver lts-9"
compiler: ": #stack 8.0.2"
addons: {apt: {packages: [libgmp-dev]}}
- env: BUILD=stack ARGS="--resolver lts-10"
compiler: ": #stack 8.2.2"
addons: {apt: {packages: [libgmp-dev]}}
# Nightly builds are allowed to fail
- env: BUILD=stack ARGS="--resolver nightly"
compiler: ": #stack nightly"
addons: {apt: {packages: [libgmp-dev]}}
# Build on OS X in addition to Linux
# Build on macOS in addition to Linux
- env: BUILD=stack ARGS=""
compiler: ": #stack default osx"
os: osx
- env: BUILD=stack ARGS="--resolver lts-6"
compiler: ": #stack 7.10.3 osx"
- env: BUILD=stack ARGS="--resolver lts-7"
compiler: ": #stack 8.0.1 osx"
os: osx
- env: BUILD=stack ARGS="--resolver lts-8"
- env: BUILD=stack ARGS="--resolver lts-9"
compiler: ": #stack 8.0.2 osx"
os: osx
- env: BUILD=stack ARGS="--resolver lts-10"
compiler: ": #stack 8.2.2 osx"
os: osx
- env: BUILD=stack ARGS="--resolver nightly"
compiler: ": #stack nightly osx"
os: osx
@ -102,8 +95,6 @@ matrix:
allow_failures:
- env: BUILD=cabal GHCVER=head CABALVER=head HAPPYVER=1.19.5 ALEXVER=3.1.7
- env: BUILD=stack ARGS="--resolver nightly"
- env: BUILD=cabal GHCVER=7.8.4 CABALVER=1.18 HAPPYVER=1.19.5 ALEXVER=3.1.7
- env: BUILD=cabal GHCVER=7.10.3 CABALVER=1.22 HAPPYVER=1.19.5 ALEXVER=3.1.7
before_install:
# Using compiler above sets CC to an invalid value, so unset it
@ -139,11 +130,28 @@ install:
- if [ -f configure.ac ]; then autoreconf -i; fi
- |
set -ex
if [ "$ARGS" = "--resolver nightly" ]
then
stack --install-ghc $ARGS build cabal-install
stack --install-ghc $ARGS solver --update-config
fi
case "$BUILD" in
stack)
# Add in extra-deps for older snapshots, as necessary
stack --no-terminal --install-ghc $ARGS test --bench --dry-run || ( \
stack --no-terminal $ARGS build cabal-install && \
stack --no-terminal $ARGS solver --update-config)
# Build the dependencies
stack --no-terminal --install-ghc $ARGS test --bench --only-dependencies
;;
cabal)
cabal --version
travis_retry cabal update
# Get the list of packages from the stack.yaml file. Note that
# this will also implicitly run hpack as necessary to generate
# the .cabal files needed by cabal-install.
PACKAGES=$(stack --install-ghc query locals | grep '^ *path' | sed 's@^ *path:@@')
cabal install --only-dependencies --enable-tests --enable-benchmarks --force-reinstalls --ghc-options=-O0 --reorder-goals --max-backjumps=-1 $CABALARGS $PACKAGES
;;
esac
set +ex
script:
@ -151,47 +159,28 @@ script:
set -ex
case "$BUILD" in
stack)
if [ `uname` = "Darwin" ]
then
# Build dependencies with -O0 as well
echo "apply-ghc-options: everything" >> stack.yaml
# Avoid OOM for building Cabal
stack --install-ghc --no-terminal $ARGS build Cabal --fast
# Use slightly less intensive options on OS X due to Travis timeouts
stack --install-ghc --no-terminal $ARGS test --fast
else
# Avoid OOM for building Cabal
stack --install-ghc --no-terminal $ARGS build Cabal --fast
stack --install-ghc --no-terminal $ARGS test --bench --no-run-benchmarks --haddock --no-haddock-deps --pedantic
fi
stack --no-terminal $ARGS test --bench --no-run-benchmarks --haddock --no-haddock-deps
;;
cabal)
cabal --version
travis_retry cabal update
# Get the list of packages from the stack.yaml file
PACKAGES=$(stack --install-ghc query locals | grep '^ *path' | sed 's@^ *path:@@')
cabal install --enable-tests --enable-benchmarks --force-reinstalls --ghc-options=-O0 --reorder-goals --max-backjumps=-1 $CABALARGS $PACKAGES
ORIGDIR=$(pwd)
for dir in $PACKAGES
do
cd $dir
cabal check || [ "$CABALVER" == "1.16" ]
cabal sdist
PKGVER=$(cabal info . | awk '{print $2;exit}')
SRC_TGZ=$PKGVER.tar.gz
cd dist
tar zxfv "$SRC_TGZ"
cd "$PKGVER"
cabal configure --enable-tests
cabal build
cd $ORIGDIR
done
# Times out
#ORIGDIR=$(pwd)
#for dir in $PACKAGES
#do
# cd $dir
# cabal check || [ "$CABALVER" == "1.16" ]
# cabal sdist
# PKGVER=$(cabal info . | awk '{print $2;exit}')
# SRC_TGZ=$PKGVER.tar.gz
# cd dist
# tar zxfv "$SRC_TGZ"
# cd "$PKGVER"
# cabal configure --enable-tests --ghc-options -O0
# cabal build
# cabal test
# cd $ORIGDIR
#done
;;
esac
set +ex

25
stack.yaml
View File

@ -14,6 +14,25 @@ packages:
- ./yesod-eventsource
- ./yesod-websockets
extra-deps:
- conduit-extra-1.2.2
- unliftio-core-0.1.0.0
- typed-process-0.2.0.0
- unliftio-core-0.1.1.0
- unliftio-0.2.4.0
- authenticate-1.3.4
- typed-process-0.2.1.0
- conduit-1.3.0
- conduit-extra-1.3.0
- persistent-2.8.0
- resourcet-1.2.0
- mono-traversable-1.0.8.1
- yaml-0.8.28
- project-template-0.2.0.1
- xml-conduit-1.8.0
- wai-extra-3.0.22.0
- monad-logger-0.3.28.1
- html-conduit-1.3.0
- http-conduit-2.3.0
- persistent-sqlite-2.8.0
- cookie-0.4.3
- gauge-0.2.1
- basement-0.0.6
- foundation-0.0.19
- memory-0.14.14

4
yesod-auth-oauth/ChangeLog.md
View File

@ -1,3 +1,7 @@
## 1.6.0
* Upgrade to yesod-core 1.6.0
## 1.4.2
* Fix warnings

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

@ -1,5 +1,8 @@
{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, QuasiQuotes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Yesod.Auth.OAuth
( authOAuth
, oauthUrl
@ -12,15 +15,15 @@ module Yesod.Auth.OAuth
) where
import Control.Applicative as A ((<$>), (<*>))
import Control.Arrow ((***))
import Control.Exception.Lifted
import UnliftIO.Exception
import Control.Monad.IO.Class
import UnliftIO (MonadUnliftIO)
import Data.ByteString (ByteString)
import Data.Maybe
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8With, encodeUtf8)
import Data.Text.Encoding.Error (lenientDecode)
import Data.Typeable
import Web.Authenticate.OAuth
import Yesod.Auth
import Yesod.Form
@ -35,26 +38,37 @@ instance Exception YesodOAuthException
oauthUrl :: Text -> AuthRoute
oauthUrl name = PluginR name ["forward"]
authOAuth :: YesodAuth m
authOAuth :: forall master. YesodAuth master
=> OAuth -- ^ 'OAuth' data-type for signing.
-> (Credential -> IO (Creds m)) -- ^ How to extract ident.
-> AuthPlugin m
-> (Credential -> IO (Creds master)) -- ^ How to extract ident.
-> AuthPlugin master
authOAuth oauth mkCreds = AuthPlugin name dispatch login
where
name = T.pack $ oauthServerName oauth
url = PluginR name []
lookupTokenSecret = bsToText . fromMaybe "" . lookup "oauth_token_secret" . unCredential
oauthSessionName :: Text
oauthSessionName = "__oauth_token_secret"
dispatch
:: ( MonadHandler m
, master ~ HandlerSite m
, Auth ~ SubHandlerSite m
, MonadUnliftIO m
)
=> Text
-> [Text]
-> m TypedContent
dispatch "GET" ["forward"] = do
render <- lift getUrlRender
render <- getUrlRender
tm <- getRouteToParent
let oauth' = oauth { oauthCallback = Just $ encodeUtf8 $ render $ tm url }
master <- lift getYesod
tok <- lift $ getTemporaryCredential oauth' (authHttpManager master)
manager <- authHttpManager
tok <- getTemporaryCredential oauth' manager
setSession oauthSessionName $ lookupTokenSecret tok
redirect $ authorizeUrl oauth' tok
dispatch "GET" [] = lift $ do
dispatch "GET" [] = do
Just tokSec <- lookupSession oauthSessionName
deleteSession oauthSessionName
reqTok <-
@ -72,8 +86,8 @@ authOAuth oauth mkCreds = AuthPlugin name dispatch login
, ("oauth_token", encodeUtf8 oaTok)
, ("oauth_token_secret", encodeUtf8 tokSec)
]
master <- getYesod
accTok <- getAccessToken oauth reqTok (authHttpManager master)
manager <- authHttpManager
accTok <- getAccessToken oauth reqTok manager
creds <- liftIO $ mkCreds accTok
setCredsRedirect creds
dispatch _ _ = notFound

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

@ -1,5 +1,5 @@
name: yesod-auth-oauth
version: 1.4.2
version: 1.6.0
license: BSD3
license-file: LICENSE
author: Hiromi Ishii
@ -23,12 +23,12 @@ library
build-depends: base >= 4 && < 4.3
build-depends: authenticate-oauth >= 1.5 && < 1.7
, bytestring >= 0.9.1.4
, yesod-core >= 1.4 && < 1.5
, yesod-auth >= 1.4 && < 1.5
, yesod-core >= 1.6 && < 1.7
, yesod-auth >= 1.6 && < 1.7
, text >= 0.7
, yesod-form >= 1.4 && < 1.5
, yesod-form >= 1.6 && < 1.7
, transformers >= 0.2.2 && < 0.6
, lifted-base >= 0.2 && < 0.3
, unliftio
exposed-modules: Yesod.Auth.OAuth
ghc-options: -Wall

4
yesod-auth/ChangeLog.md
View File

@ -1,3 +1,7 @@
## 1.6.0
* Upgrade to yesod-core 1.6.0
## 1.4.21
* Add redirectToCurrent to Yesod.Auth module for controlling setUltDestCurrent in redirectLogin [#1461](https://github.com/yesodweb/yesod/pull/1461)

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

@ -39,6 +39,7 @@ module Yesod.Auth
-- * Exception
, AuthException (..)
-- * Helper
, MonadAuthHandler
, AuthHandler
-- * Internal
, credsKey
@ -47,9 +48,9 @@ module Yesod.Auth
, asHtml
) where
import Control.Applicative ((<$>))
import Control.Monad (when)
import Control.Monad.Trans.Maybe
import UnliftIO (withRunInIO, MonadUnliftIO)
import Yesod.Auth.Routes
import Data.Aeson hiding (json)
@ -60,11 +61,11 @@ import qualified Data.Text as T
import qualified Data.HashMap.Lazy as Map
import Data.Monoid (Endo)
import Network.HTTP.Client (Manager, Request, withResponse, Response, BodyReader)
import Network.HTTP.Client.TLS (getGlobalManager)
import qualified Network.Wai as W
import Yesod.Core
import Yesod.Core.Types (HandlerT(..), unHandlerT)
import Yesod.Persist
import Yesod.Auth.Message (AuthMessage, defaultMessage)
import qualified Yesod.Auth.Message as Msg
@ -72,13 +73,13 @@ import Yesod.Form (FormMessage)
import Data.Typeable (Typeable)
import Control.Exception (Exception)
import Network.HTTP.Types (Status, internalServerError500, unauthorized401)
import Control.Monad.Trans.Resource (MonadResourceBase)
import qualified Control.Monad.Trans.Writer as Writer
import Control.Monad (void)
type AuthRoute = Route Auth
type AuthHandler master a = YesodAuth master => HandlerT Auth (HandlerT master IO) a
type MonadAuthHandler master m = (MonadHandler m, YesodAuth master, master ~ HandlerSite m, Auth ~ SubHandlerSite m, MonadUnliftIO m)
type AuthHandler master a = forall m. MonadAuthHandler master m => m a
type Method = Text
type Piece = Text
@ -94,7 +95,7 @@ data AuthenticationResult master
data AuthPlugin master = AuthPlugin
{ apName :: Text
, apDispatch :: Method -> [Piece] -> AuthHandler master TypedContent
, apLogin :: (Route Auth -> Route master) -> WidgetT master IO ()
, apLogin :: (Route Auth -> Route master) -> WidgetFor master ()
}
getAuth :: a -> Auth
@ -111,8 +112,8 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage
type AuthId master
-- | specify the layout. Uses defaultLayout by default
authLayout :: WidgetT master IO () -> HandlerT master IO Html
authLayout = defaultLayout
authLayout :: WidgetFor master () -> AuthHandler master Html
authLayout = liftHandler . defaultLayout
-- | Default destination on successful login, if no other
-- destination exists.
@ -126,8 +127,8 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage
--
-- Default implementation is in terms of @'getAuthId'@
--
-- @since 1.4.4
authenticate :: Creds master -> HandlerT master IO (AuthenticationResult master)
-- @since: 1.4.4
authenticate :: Creds master -> AuthHandler master (AuthenticationResult master)
authenticate creds = do
muid <- getAuthId creds
@ -137,7 +138,7 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage
--
-- Default implementation is in terms of @'authenticate'@
--
getAuthId :: Creds master -> HandlerT master IO (Maybe (AuthId master))
getAuthId :: Creds master -> AuthHandler master (Maybe (AuthId master))
getAuthId creds = do
auth <- authenticate creds
@ -167,7 +168,7 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage
-- > lift $ redirect HomeR -- or any other Handler code you want
-- > defaultLoginHandler
--
loginHandler :: HandlerT Auth (HandlerT master IO) Html
loginHandler :: AuthHandler master Html
loginHandler = defaultLoginHandler
-- | Used for i18n of messages provided by this package.
@ -193,15 +194,16 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage
-- type. This allows backends to reuse persistent connections. If none of
-- the backends you're using use HTTP connections, you can safely return
-- @error \"authHttpManager\"@ here.
authHttpManager :: master -> Manager
authHttpManager :: AuthHandler master Manager
authHttpManager = liftIO getGlobalManager
-- | Called on a successful login. By default, calls
-- @addMessageI "success" NowLoggedIn@.
onLogin :: HandlerT master IO ()
onLogin :: AuthHandler master ()
onLogin = addMessageI "success" Msg.NowLoggedIn
-- | Called on logout. By default, does nothing
onLogout :: HandlerT master IO ()
onLogout :: AuthHandler master ()
onLogout = return ()
-- | Retrieves user credentials, if user is authenticated.
@ -213,16 +215,16 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage
-- other than a browser.
--
-- @since 1.2.0
maybeAuthId :: HandlerT master IO (Maybe (AuthId master))
maybeAuthId :: AuthHandler master (Maybe (AuthId master))
default maybeAuthId
:: (YesodAuthPersist master, Typeable (AuthEntity master))
=> HandlerT master IO (Maybe (AuthId master))
=> AuthHandler master (Maybe (AuthId master))
maybeAuthId = defaultMaybeAuthId
-- | Called on login error for HTTP requests. By default, calls
-- @addMessage@ with "error" as status and redirects to @dest@.
onErrorHtml :: (MonadResourceBase m) => Route master -> Text -> HandlerT master m Html
onErrorHtml :: Route master -> Text -> AuthHandler master Html
onErrorHtml dest msg = do
addMessage "error" $ toHtml msg
fmap asHtml $ redirect dest
@ -232,10 +234,14 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage
--
-- The HTTP 'Request' is given in case it is useful to change behavior based on inspecting the request.
-- This is an experimental API that is not broadly used throughout the yesod-auth code base
runHttpRequest :: Request -> (Response BodyReader -> HandlerT master IO a) -> HandlerT master IO a
runHttpRequest
:: MonadAuthHandler master m
=> Request
-> (Response BodyReader -> m a)
-> m a
runHttpRequest req inner = do
man <- authHttpManager Control.Applicative.<$> getYesod
HandlerT $ \t -> withResponse req man $ \res -> unHandlerT (inner res) t
man <- authHttpManager
withRunInIO $ \run -> withResponse req man $ run . inner
{-# MINIMAL loginDest, logoutDest, (authenticate | getAuthId), authPlugins, authHttpManager #-}
@ -256,7 +262,7 @@ credsKey = "_ID"
-- @since 1.1.2
defaultMaybeAuthId
:: (YesodAuthPersist master, Typeable (AuthEntity master))
=> HandlerT master IO (Maybe (AuthId master))
=> AuthHandler master (Maybe (AuthId master))
defaultMaybeAuthId = runMaybeT $ do
s <- MaybeT $ lookupSession credsKey
aid <- MaybeT $ return $ fromPathPiece s
@ -265,7 +271,8 @@ defaultMaybeAuthId = runMaybeT $ do
cachedAuth
:: (YesodAuthPersist master, Typeable (AuthEntity master))
=> AuthId master -> HandlerT master IO (Maybe (AuthEntity master))
=> AuthId master
-> AuthHandler master (Maybe (AuthEntity master))
cachedAuth
= fmap unCachedMaybeAuth
. cached
@ -282,48 +289,53 @@ cachedAuth
defaultLoginHandler :: AuthHandler master Html
defaultLoginHandler = do
tp <- getRouteToParent
lift $ authLayout $ do
authLayout $ do
setTitleI Msg.LoginTitle
master <- getYesod
mapM_ (flip apLogin tp) (authPlugins master)
loginErrorMessageI :: (MonadResourceBase m, YesodAuth master)
=> Route child
-> AuthMessage
-> HandlerT child (HandlerT master m) TypedContent
loginErrorMessageI
:: Route Auth
-> AuthMessage
-> AuthHandler master TypedContent
loginErrorMessageI dest msg = do
toParent <- getRouteToParent
lift $ loginErrorMessageMasterI (toParent dest) msg
loginErrorMessageMasterI (toParent dest) msg
loginErrorMessageMasterI :: (YesodAuth master, MonadResourceBase m, RenderMessage master AuthMessage)
=> Route master
-> AuthMessage
-> HandlerT master m TypedContent
loginErrorMessageMasterI
:: Route master
-> AuthMessage
-> AuthHandler master 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 :: (YesodAuth master, MonadResourceBase m)
=> Route master
loginErrorMessage
:: Route master
-> Text
-> HandlerT master m TypedContent
-> AuthHandler master TypedContent
loginErrorMessage dest msg = messageJson401 msg (onErrorHtml dest msg)
messageJson401 :: MonadResourceBase m => Text -> HandlerT master m Html -> HandlerT master m TypedContent
messageJson401
:: MonadAuthHandler master m
=> Text
-> m Html
-> m TypedContent
messageJson401 = messageJsonStatus unauthorized401
messageJson500 :: MonadResourceBase m => Text -> HandlerT master m Html -> HandlerT master m TypedContent
messageJson500 :: MonadAuthHandler master m => Text -> m Html -> m TypedContent
messageJson500 = messageJsonStatus internalServerError500
messageJsonStatus :: MonadResourceBase m
=> Status
-> Text
-> HandlerT master m Html
-> HandlerT master m TypedContent
messageJsonStatus
:: MonadAuthHandler master m
=> Status
-> Text
-> m Html
-> m TypedContent
messageJsonStatus status msg html = selectRep $ do
provideRep html
provideRep $ do
@ -335,9 +347,9 @@ 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 master -- ^ new credentials
-> AuthHandler master TypedContent
setCredsRedirect creds = do
y <- getYesod
auth <- authenticate creds
@ -376,10 +388,9 @@ setCredsRedirect creds = do
return $ renderAuthMessage master langs msg
-- | Sets user credentials for the session after checking them with authentication backends.
setCreds :: YesodAuth master
=> Bool -- ^ if HTTP redirects should be done
setCreds :: Bool -- ^ if HTTP redirects should be done
-> Creds master -- ^ new credentials
-> HandlerT master IO ()
-> AuthHandler master ()
setCreds doRedirects creds =
if doRedirects
then void $ setCredsRedirect creds
@ -389,10 +400,11 @@ setCreds doRedirects creds =
_ -> return ()
-- | 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
:: (ToJSON j, MonadAuthHandler master m)
=> WidgetFor master () -- ^ HTML
-> m j -- ^ JSON
-> m TypedContent
authLayoutJson w json = selectRep $ do
provideRep $ authLayout w
provideRep $ fmap toJSON json
@ -400,9 +412,8 @@ authLayoutJson w json = selectRep $ do
-- | Clears current user credentials for the session.
--
-- @since 1.1.7
clearCreds :: YesodAuth master
=> Bool -- ^ if HTTP redirect to 'logoutDest' should be done
-> HandlerT master IO ()
clearCreds :: Bool -- ^ if HTTP redirect to 'logoutDest' should be done
-> AuthHandler master ()
clearCreds doRedirects = do
y <- getYesod
onLogout
@ -411,7 +422,7 @@ clearCreds doRedirects = do
redirectUltDest $ logoutDest y
getCheckR :: AuthHandler master TypedContent
getCheckR = lift $ do
getCheckR = do
creds <- maybeAuthId
authLayoutJson (do
setTitle "Authentication Status"
@ -432,7 +443,7 @@ $nothing
]
setUltDestReferer' :: AuthHandler master ()
setUltDestReferer' = lift $ do
setUltDestReferer' = do
master <- getYesod
when (redirectToReferer master) setUltDestReferer
@ -440,14 +451,16 @@ getLoginR :: AuthHandler master Html
getLoginR = setUltDestReferer' >> loginHandler
getLogoutR :: AuthHandler master ()
getLogoutR = setUltDestReferer' >> redirectToPost LogoutR
getLogoutR = do
tp <- getRouteToParent
setUltDestReferer' >> redirectToPost (tp LogoutR)
postLogoutR :: AuthHandler master ()
postLogoutR = lift $ clearCreds True
postLogoutR = clearCreds True
handlePluginR :: Text -> [Text] -> AuthHandler master TypedContent
handlePluginR plugin pieces = do
master <- lift getYesod
master <- getYesod
env <- waiRequest
let method = decodeUtf8With lenientDecode $ W.requestMethod env
case filter (\x -> apName x == plugin) (authPlugins master) of
@ -464,17 +477,16 @@ maybeAuth :: ( YesodAuthPersist master
, Key val ~ AuthId master
, PersistEntity val
, Typeable val
) => HandlerT master IO (Maybe (Entity val))
maybeAuth = runMaybeT $ do
(aid, ae) <- MaybeT maybeAuthPair
return $ Entity aid ae
) => AuthHandler master (Maybe (Entity val))
maybeAuth = fmap (fmap (uncurry Entity)) maybeAuthPair
-- | Similar to 'maybeAuth', but doesn’t assume that you are using a
-- Persistent database.
--
-- @since 1.4.0
maybeAuthPair :: (YesodAuthPersist master, Typeable (AuthEntity master))
=> HandlerT master IO (Maybe (AuthId master, AuthEntity master))
maybeAuthPair
:: (YesodAuthPersist master, Typeable (AuthEntity master))
=> AuthHandler master (Maybe (AuthId master, AuthEntity master))
maybeAuthPair = runMaybeT $ do
aid <- MaybeT maybeAuthId
ae <- MaybeT $ cachedAuth aid
@ -505,27 +517,16 @@ class (YesodAuth master, YesodPersist master) => YesodAuthPersist master where
type AuthEntity master :: *
type AuthEntity master = KeyEntity (AuthId master)
getAuthEntity :: AuthId master -> HandlerT master IO (Maybe (AuthEntity master))
getAuthEntity :: AuthId master -> AuthHandler master (Maybe (AuthEntity master))
#if MIN_VERSION_persistent(2,5,0)
default getAuthEntity
:: ( YesodPersistBackend master ~ backend
, PersistRecordBackend (AuthEntity master) backend
, Key (AuthEntity master) ~ AuthId master
, PersistStore backend
)
=> AuthId master -> HandlerT master IO (Maybe (AuthEntity master))
#else
default getAuthEntity
:: ( YesodPersistBackend master
~ PersistEntityBackend (AuthEntity master)
, Key (AuthEntity master) ~ AuthId master
, PersistStore (YesodPersistBackend master)
, PersistEntity (AuthEntity master)
)
=> AuthId master -> HandlerT master IO (Maybe (AuthEntity master))
#endif
getAuthEntity = runDB . get
=> AuthId master -> AuthHandler master (Maybe (AuthEntity master))
getAuthEntity = liftHandler . runDB . get
type family KeyEntity key
@ -535,7 +536,7 @@ type instance KeyEntity (Key x) = x
-- authenticated or responds with error 401 if this is an API client (expecting JSON).
--
-- @since 1.1.0
requireAuthId :: YesodAuth master => HandlerT master IO (AuthId master)
requireAuthId :: AuthHandler master (AuthId master)
requireAuthId = maybeAuthId >>= maybe handleAuthLack return
-- | Similar to 'maybeAuth', but redirects to a login page if user is not
@ -547,23 +548,26 @@ requireAuth :: ( YesodAuthPersist master
, Key val ~ AuthId master
, PersistEntity val
, Typeable val
) => HandlerT master IO (Entity val)
) => AuthHandler master (Entity val)
requireAuth = maybeAuth >>= maybe handleAuthLack return
-- | Similar to 'requireAuth', but not tied to Persistent's 'Entity' type.
-- Instead, the 'AuthId' and 'AuthEntity' are returned in a tuple.
--
-- @since 1.4.0
requireAuthPair :: (YesodAuthPersist master, Typeable (AuthEntity master))
=> HandlerT master IO (AuthId master, AuthEntity master)
requireAuthPair
:: ( YesodAuthPersist master
, Typeable (AuthEntity master)
)
=> AuthHandler master (AuthId master, AuthEntity master)
requireAuthPair = maybeAuthPair >>= maybe handleAuthLack return
handleAuthLack :: YesodAuth master => HandlerT master IO a
handleAuthLack :: AuthHandler master a
handleAuthLack = do
aj <- acceptsJson
if aj then notAuthenticated else redirectLogin
redirectLogin :: YesodAuth master => HandlerT master IO a
redirectLogin :: AuthHandler master a
redirectLogin = do
y <- getYesod
when (redirectToCurrent y) setUltDestCurrent
@ -578,7 +582,7 @@ data AuthException = InvalidFacebookResponse
deriving (Show, Typeable)
instance Exception AuthException
instance YesodAuth master => YesodSubDispatch Auth (HandlerT master IO) where
instance YesodAuth master => YesodSubDispatch Auth master where
yesodSubDispatch = $(mkYesodSubDispatch resourcesAuth)
asHtml :: Html -> Html

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

@ -70,20 +70,21 @@ authBrowserId bis@BrowserIdSettings {..} = AuthPlugin
, apDispatch = \m ps ->
case (m, ps) of
("GET", [assertion]) -> do
master <- lift getYesod
audience <-
case bisAudience of
Just a -> return a
Nothing -> do
r <- getUrlRender
return $ T.takeWhile (/= '/') $ stripScheme $ r LoginR
memail <- lift $ checkAssertion audience assertion (authHttpManager master)
tm <- getRouteToParent
return $ T.takeWhile (/= '/') $ stripScheme $ r $ tm LoginR
manager <- authHttpManager
memail <- checkAssertion audience assertion manager
case memail of
Nothing -> do
$logErrorS "yesod-auth" "BrowserID assertion failure"
tm <- getRouteToParent
lift $ loginErrorMessage (tm LoginR) "BrowserID login error."
Just email -> lift $ setCredsRedirect Creds
loginErrorMessage (tm LoginR) "BrowserID login error."
Just email -> setCredsRedirect Creds
{ credsPlugin = pid
, credsIdent = email
, credsExtra = []
@ -116,7 +117,7 @@ $newline never
createOnClickOverride :: BrowserIdSettings
-> (Route Auth -> Route master)
-> Maybe (Route master)
-> WidgetT master IO Text
-> WidgetFor master Text
createOnClickOverride BrowserIdSettings {..} toMaster mOnRegistration = do
unless bisLazyLoad $ addScriptRemote browserIdJs
onclick <- newIdent
@ -165,5 +166,5 @@ createOnClickOverride BrowserIdSettings {..} toMaster mOnRegistration = do
-- name.
createOnClick :: BrowserIdSettings
-> (Route Auth -> Route master)
-> WidgetT master IO Text
-> WidgetFor master Text
createOnClick bidSettings toMaster = createOnClickOverride bidSettings toMaster Nothing

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

@ -1,5 +1,7 @@
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
-- | Provides a dummy authentication module that simply lets a user specify
-- his/her identifier. This is not intended for real world use, just for
-- testing.
@ -16,8 +18,8 @@ authDummy =
AuthPlugin "dummy" dispatch login
where
dispatch "POST" [] = do
ident <- lift $ runInputPost $ ireq textField "ident"
lift $ setCredsRedirect $ Creds "dummy" ident []
ident <- runInputPost $ ireq textField "ident"
setCredsRedirect $ Creds "dummy" ident []
dispatch _ _ = notFound
url = PluginR "dummy" []
login authToMaster = do

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

@ -186,29 +186,29 @@ class ( YesodAuth site
-- has not yet been verified.
--
-- @since 1.1.0
addUnverified :: Email -> VerKey -> HandlerT site IO (AuthEmailId site)
addUnverified :: Email -> VerKey -> AuthHandler site (AuthEmailId site)
-- | Send an email to the given address to verify ownership.
--
-- @since 1.1.0
sendVerifyEmail :: Email -> VerKey -> VerUrl -> HandlerT site IO ()
sendVerifyEmail :: Email -> VerKey -> VerUrl -> AuthHandler site ()
-- | Get the verification key for the given email ID.
--
-- @since 1.1.0
getVerifyKey :: AuthEmailId site -> HandlerT site IO (Maybe VerKey)
getVerifyKey :: AuthEmailId site -> AuthHandler site (Maybe VerKey)
-- | Set the verification key for the given email ID.
--
-- @since 1.1.0
setVerifyKey :: AuthEmailId site -> VerKey -> HandlerT site IO ()
setVerifyKey :: AuthEmailId site -> VerKey -> AuthHandler site ()
-- | Hash and salt a password
--
-- Default: 'saltPass'.
--
-- @since 1.4.20
hashAndSaltPassword :: Text -> HandlerT site IO SaltedPass
hashAndSaltPassword :: Text -> AuthHandler site SaltedPass
hashAndSaltPassword = liftIO . saltPass
-- | Verify a password matches the stored password for the given account.
@ -216,7 +216,7 @@ class ( YesodAuth site
-- Default: Fetch a password with 'getPassword' and match using 'Yesod.Auth.Util.PasswordStore.verifyPassword'.
--
-- @since 1.4.20
verifyPassword :: Text -> SaltedPass -> HandlerT site IO Bool
verifyPassword :: Text -> SaltedPass -> AuthHandler site Bool
verifyPassword plain salted = return $ isValidPass plain salted
-- | Verify the email address on the given account.
@ -228,28 +228,28 @@ class ( YesodAuth site
-- See <https://github.com/yesodweb/yesod/issues/1222>.
--
-- @since 1.1.0
verifyAccount :: AuthEmailId site -> HandlerT site IO (Maybe (AuthId site))
verifyAccount :: AuthEmailId site -> AuthHandler site (Maybe (AuthId site))
-- | Get the salted password for the given account.
--
-- @since 1.1.0
getPassword :: AuthId site -> HandlerT site IO (Maybe SaltedPass)
getPassword :: AuthId site -> AuthHandler site (Maybe SaltedPass)
-- | Set the salted password for the given account.
--
-- @since 1.1.0
setPassword :: AuthId site -> SaltedPass -> HandlerT site IO ()
setPassword :: AuthId site -> SaltedPass -> AuthHandler site ()
-- | Get the credentials for the given @Identifier@, which may be either an
-- email address or some other identification (e.g., username).
--
-- @since 1.2.0
getEmailCreds :: Identifier -> HandlerT site IO (Maybe (EmailCreds site))
getEmailCreds :: Identifier -> AuthHandler site (Maybe (EmailCreds site))
-- | Get the email address for the given email ID.
--
-- @since 1.1.0
getEmail :: AuthEmailId site -> HandlerT site IO (Maybe Email)
getEmail :: AuthEmailId site -> AuthHandler site (Maybe Email)
-- | Generate a random alphanumeric string.
--
@ -268,7 +268,7 @@ class ( YesodAuth site
-- Default: if the user logged in via an email link do not require a password.
--
-- @since 1.2.1
needOldPassword :: AuthId site -> HandlerT site IO Bool
needOldPassword :: AuthId site -> AuthHandler site Bool
needOldPassword aid' = do
mkey <- lookupSession loginLinkKey
case mkey >>= readMay . TS.unpack of
@ -280,7 +280,7 @@ class ( YesodAuth site
-- | Check that the given plain-text password meets minimum security standards.
--
-- Default: password is at least three characters.
checkPasswordSecurity :: AuthId site -> Text -> HandlerT site IO (Either Text ())
checkPasswordSecurity :: AuthId site -> Text -> AuthHandler site (Either Text ())
checkPasswordSecurity _ x
| TS.length x >= 3 = return $ Right ()
| otherwise = return $ Left "Password must be at least three characters"
@ -288,7 +288,7 @@ class ( YesodAuth site
-- | Response after sending a confirmation email.
--
-- @since 1.2.2
confirmationEmailSentResponse :: Text -> HandlerT site IO TypedContent
confirmationEmailSentResponse :: Text -> AuthHandler site TypedContent
confirmationEmailSentResponse identifier = do
mr <- getMessageRender
selectRep $ do
@ -314,7 +314,7 @@ class ( YesodAuth site
-- Default: 'defaultEmailLoginHandler'.
--
-- @since 1.4.17
emailLoginHandler :: (Route Auth -> Route site) -> WidgetT site IO ()
emailLoginHandler :: (Route Auth -> Route site) -> WidgetFor site ()
emailLoginHandler = defaultEmailLoginHandler
@ -325,7 +325,7 @@ class ( YesodAuth site
-- Default: 'defaultRegisterHandler'.
--
-- @since: 1.2.6
registerHandler :: HandlerT Auth (HandlerT site IO) Html
registerHandler :: AuthHandler site Html
registerHandler = defaultRegisterHandler
-- | Handler called to render the \"forgot password\" page.
@ -335,7 +335,7 @@ class ( YesodAuth site
-- Default: 'defaultForgotPasswordHandler'.
--
-- @since: 1.2.6
forgotPasswordHandler :: HandlerT Auth (HandlerT site IO) Html
forgotPasswordHandler :: AuthHandler site Html
forgotPasswordHandler = defaultForgotPasswordHandler
-- | Handler called to render the \"set password\" page. The
@ -351,7 +351,7 @@ class ( YesodAuth site
-- field for the old password should be presented.
-- Otherwise, just two fields for the new password are
-- needed.
-> HandlerT Auth (HandlerT site IO) TypedContent
-> AuthHandler site TypedContent
setPasswordHandler = defaultSetPasswordHandler
authEmail :: (YesodAuthEmail m) => AuthPlugin m
@ -371,15 +371,18 @@ authEmail =
dispatch "POST" ["set-password"] = postPasswordR >>= sendResponse
dispatch _ _ = notFound
getRegisterR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) Html
getRegisterR :: YesodAuthEmail master => AuthHandler master Html
getRegisterR = registerHandler
-- | Default implementation of 'emailLoginHandler'.
--
-- @since 1.4.17
defaultEmailLoginHandler :: YesodAuthEmail master => (Route Auth -> Route master) -> WidgetT master IO ()
defaultEmailLoginHandler
:: YesodAuthEmail master
=> (Route Auth -> Route master)
-> WidgetFor master ()
defaultEmailLoginHandler toParent = do
(widget, enctype) <- liftWidgetT $ generateFormPost loginForm
(widget, enctype) <- generateFormPost loginForm
[whamlet|
<form method="post" action="@{toParent loginR}", enctype=#{enctype}>
@ -437,11 +440,11 @@ defaultEmailLoginHandler toParent = do
-- | Default implementation of 'registerHandler'.
--
-- @since 1.2.6
defaultRegisterHandler :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) Html
defaultRegisterHandler :: YesodAuthEmail master => AuthHandler master Html
defaultRegisterHandler = do
(widget, enctype) <- lift $ generateFormPost registrationForm
(widget, enctype) <- generateFormPost registrationForm
toParentRoute <- getRouteToParent
lift $ authLayout $ do
authLayout $ do
setTitleI Msg.RegisterLong
[whamlet|
<p>_{Msg.EnterEmail}
@ -480,14 +483,14 @@ parseEmail = withObject "email" (\obj -> do
registerHelper :: YesodAuthEmail master
=> Bool -- ^ allow usernames?
-> Route Auth
-> HandlerT Auth (HandlerT master IO) TypedContent
-> AuthHandler master TypedContent
registerHelper allowUsername dest = do
y <- lift getYesod
y <- getYesod
checkCsrfHeaderOrParam defaultCsrfHeaderName defaultCsrfParamName
pidentifier <- lookupPostParam "email"
midentifier <- case pidentifier of
Nothing -> do
(jidentifier :: Result Value) <- lift parseCheckJsonBody
(jidentifier :: Result Value) <- parseCheckJsonBody
case jidentifier of
Error _ -> return Nothing
Success val -> return $ parseMaybe parseEmail val
@ -502,43 +505,44 @@ registerHelper allowUsername dest = do
case eidentifier of
Left route -> loginErrorMessageI dest route
Right identifier -> do
mecreds <- lift $ getEmailCreds identifier
mecreds <- 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
setVerifyKey lid key
return $ Just (lid, key, email)
Nothing
| allowUsername -> return Nothing
| otherwise -> do
key <- liftIO $ randomKey y
lid <- lift $ addUnverified identifier key
lid <- 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 $ verifyR (toPathPiece lid) verKey
lift $ sendVerifyEmail email verKey verUrl
lift $ confirmationEmailSentResponse identifier
tp <- getRouteToParent
let verUrl = render $ tp $ verifyR (toPathPiece lid) verKey
sendVerifyEmail email verKey verUrl
confirmationEmailSentResponse identifier
postRegisterR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) TypedContent
postRegisterR :: YesodAuthEmail master => AuthHandler master TypedContent
postRegisterR = registerHelper False registerR
getForgotPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) Html
getForgotPasswordR :: YesodAuthEmail master => AuthHandler master Html
getForgotPasswordR = forgotPasswordHandler
-- | Default implementation of 'forgotPasswordHandler'.
--
-- @since 1.2.6
defaultForgotPasswordHandler :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) Html
defaultForgotPasswordHandler :: YesodAuthEmail master => AuthHandler master Html
defaultForgotPasswordHandler = do
(widget, enctype) <- lift $ generateFormPost forgotPasswordForm
(widget, enctype) <- generateFormPost forgotPasswordForm
toParent <- getRouteToParent
lift $ authLayout $ do
authLayout $ do
setTitleI Msg.PasswordResetTitle
[whamlet|
<p>_{Msg.PasswordResetPrompt}
@ -569,35 +573,36 @@ defaultForgotPasswordHandler = do
fsAttrs = [("autofocus", "")]
}
postForgotPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) TypedContent
postForgotPasswordR :: YesodAuthEmail master => AuthHandler master TypedContent
postForgotPasswordR = registerHelper True forgotPasswordR
getVerifyR :: YesodAuthEmail site
=> AuthEmailId site
-> Text
-> HandlerT Auth (HandlerT site IO) TypedContent
-> AuthHandler site TypedContent
getVerifyR lid key = do
realKey <- lift $ getVerifyKey lid
memail <- lift $ getEmail lid
mr <- lift getMessageRender
realKey <- getVerifyKey lid
memail <- getEmail lid
mr <- getMessageRender
case (realKey == Just key, memail) of
(True, Just email) -> do
muid <- lift $ verifyAccount lid
muid <- verifyAccount lid
case muid of
Nothing -> invalidKey mr
Just uid -> do
lift $ setCreds False $ Creds "email-verify" email [("verifiedEmail", email)] -- FIXME uid?
lift $ setLoginLinkKey uid
setCreds False $ Creds "email-verify" email [("verifiedEmail", email)] -- FIXME uid?
setLoginLinkKey uid
let msgAv = Msg.AddressVerified
selectRep $ do
provideRep $ do
lift $ addMessageI "success" msgAv
fmap asHtml $ redirect setpassR
addMessageI "success" msgAv
tp <- getRouteToParent
fmap asHtml $ redirect $ tp setpassR
provideJsonMessage $ mr msgAv
_ -> invalidKey mr
where
msgIk = Msg.InvalidKey
invalidKey mr = messageJson401 (mr msgIk) $ lift $ authLayout $ do
invalidKey mr = messageJson401 (mr msgIk) $ authLayout $ do
setTitleI msgIk
[whamlet|
$newline never
@ -612,16 +617,16 @@ parseCreds = withObject "creds" (\obj -> do
return (email', pass))
postLoginR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) TypedContent
postLoginR :: YesodAuthEmail master => AuthHandler master TypedContent
postLoginR = do
result <- lift $ runInputPostResult $ (,)
result <- runInputPostResult $ (,)
<$> ireq textField "email"
<*> ireq textField "password"
midentifier <- case result of
FormSuccess (iden, pass) -> return $ Just (iden, pass)
_ -> do
(creds :: Result Value) <- lift parseCheckJsonBody
(creds :: Result Value) <- parseCheckJsonBody
case creds of
Error _ -> return Nothing
Success val -> return $ parseMaybe parseCreds val
@ -629,18 +634,18 @@ postLoginR = do
case midentifier of
Nothing -> loginErrorMessageI LoginR Msg.NoIdentifierProvided
Just (identifier, pass) -> do
mecreds <- lift $ getEmailCreds identifier
mecreds <- getEmailCreds identifier
maid <-
case ( mecreds >>= emailCredsAuthId
, emailCredsEmail <$> mecreds
, emailCredsStatus <$> mecreds
) of
(Just aid, Just email', Just True) -> do
mrealpass <- lift $ getPassword aid
mrealpass <- getPassword aid
case mrealpass of
Nothing -> return Nothing
Just realpass -> do
passValid <- lift $ verifyPassword pass realpass
passValid <- verifyPassword pass realpass
return $ if passValid
then Just email'
else Nothing
@ -648,7 +653,7 @@ postLoginR = do
let isEmail = Text.Email.Validate.isValid $ encodeUtf8 identifier
case maid of
Just email' ->
lift $ setCredsRedirect $ Creds
setCredsRedirect $ Creds
(if isEmail then "email" else "username")
email'
[("verifiedEmail", email')]
@ -658,26 +663,26 @@ postLoginR = do
then Msg.InvalidEmailPass
else Msg.InvalidUsernamePass
getPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) TypedContent
getPasswordR :: YesodAuthEmail master => AuthHandler master TypedContent
getPasswordR = do
maid <- lift maybeAuthId
maid <- maybeAuthId
case maid of
Nothing -> loginErrorMessageI LoginR Msg.BadSetPass
Just _ -> do
needOld <- maybe (return True) (lift . needOldPassword) maid
needOld <- maybe (return True) needOldPassword maid
setPasswordHandler needOld
-- | Default implementation of 'setPasswordHandler'.
--
-- @since 1.2.6
defaultSetPasswordHandler :: YesodAuthEmail master => Bool -> HandlerT Auth (HandlerT master IO) TypedContent
defaultSetPasswordHandler :: YesodAuthEmail master => Bool -> AuthHandler master TypedContent
defaultSetPasswordHandler needOld = do
messageRender <- lift getMessageRender
messageRender <- getMessageRender
toParent <- getRouteToParent
selectRep $ do
provideJsonMessage $ messageRender Msg.SetPass
provideRep $ lift $ authLayout $ do
(widget, enctype) <- liftWidgetT $ generateFormPost setPasswordForm
provideRep $ authLayout $ do
(widget, enctype) <- generateFormPost setPasswordForm
setTitleI Msg.SetPassTitle
[whamlet|
<h3>_{Msg.SetPass}
@ -749,10 +754,10 @@ parsePassword = withObject "password" (\obj -> do
curr <- obj .:? "current"
return (email', pass, curr))
postPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) TypedContent
postPasswordR :: YesodAuthEmail master => AuthHandler master TypedContent
postPasswordR = do
maid <- lift maybeAuthId
(creds :: Result Value) <- lift parseCheckJsonBody
maid <- maybeAuthId
(creds :: Result Value) <- parseCheckJsonBody
let jcreds = case creds of
Error _ -> Nothing
Success val -> parseMaybe parsePassword val
@ -761,26 +766,26 @@ postPasswordR = do
Nothing -> loginErrorMessageI LoginR Msg.BadSetPass
Just aid -> do
tm <- getRouteToParent
needOld <- lift $ needOldPassword aid
needOld <- needOldPassword aid
if not needOld then confirmPassword aid tm jcreds else do
res <- lift $ runInputPostResult $ ireq textField "current"
res <- runInputPostResult $ ireq textField "current"
let fcurrent = case res of
FormSuccess currentPass -> Just currentPass
_ -> Nothing
let current = if doJsonParsing
then getThird jcreds
else fcurrent
mrealpass <- lift $ getPassword aid
mrealpass <- getPassword aid
case (mrealpass, current) of
(Nothing, _) ->
lift $ loginErrorMessage (tm setpassR) "You do not currently have a password set on your account"
loginErrorMessage (tm setpassR) "You do not currently have a password set on your account"
(_, Nothing) ->
loginErrorMessageI LoginR Msg.BadSetPass
(Just realpass, Just current') -> do
passValid <- lift $ verifyPassword current' realpass
passValid <- verifyPassword current' realpass
if passValid
then confirmPassword aid tm jcreds
else lift $ loginErrorMessage (tm setpassR) "Invalid current password, please try again"
else loginErrorMessage (tm setpassR) "Invalid current password, please try again"
where
msgOk = Msg.PassUpdated
@ -789,7 +794,7 @@ postPasswordR = do
getNewConfirm (Just (a,b,_)) = Just (a,b)
getNewConfirm _ = Nothing
confirmPassword aid tm jcreds = do
res <- lift $ runInputPostResult $ (,)
res <- runInputPostResult $ (,)
<$> ireq textField "new"
<*> ireq textField "confirm"
let creds = if (isJust jcreds)
@ -803,21 +808,21 @@ postPasswordR = do
if new /= confirm
then loginErrorMessageI setpassR Msg.PassMismatch
else do
isSecure <- lift $ checkPasswordSecurity aid new
isSecure <- checkPasswordSecurity aid new
case isSecure of
Left e -> lift $ loginErrorMessage (tm setpassR) e
Left e -> loginErrorMessage (tm setpassR) e
Right () -> do
salted <- lift $ hashAndSaltPassword new
y <- lift $ do
salted <- hashAndSaltPassword new
y <- do
setPassword aid salted
deleteSession loginLinkKey
addMessageI "success" msgOk
getYesod
mr <- lift getMessageRender
mr <- getMessageRender
selectRep $ do
provideRep $
fmap asHtml $ lift $ redirect $ afterPasswordRoute y
fmap asHtml $ redirect $ afterPasswordRoute y
provideJsonMessage (mr msgOk)
saltLength :: Int

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

@ -1,89 +0,0 @@
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE RankNTypes #-}
-- | Use an email address as an identifier via Google's OpenID login system.
--
-- This backend will not use the OpenID identifier at all. It only uses OpenID
-- as a login system. By using this plugin, you are trusting Google to validate
-- an email address, and requiring users to have a Google account. On the plus
-- side, you get to use email addresses as the identifier, many users have
-- existing Google accounts, the login system has been long tested (as opposed
-- to BrowserID), and it requires no credential managing or setup (as opposed
-- to Email).
module Yesod.Auth.GoogleEmail
{-# DEPRECATED "Google no longer provides OpenID support, please use Yesod.Auth.GoogleEmail2" #-}
( authGoogleEmail
, forwardUrl
) where
import Yesod.Auth
import qualified Web.Authenticate.OpenId as OpenId
import Yesod.Core
import Data.Text (Text)
import qualified Yesod.Auth.Message as Msg
import qualified Data.Text as T
import Control.Exception.Lifted (try, SomeException)
pid :: Text
pid = "googleemail"
forwardUrl :: AuthRoute
forwardUrl = PluginR pid ["forward"]
googleIdent :: Text
googleIdent = "https://www.google.com/accounts/o8/id"
authGoogleEmail :: YesodAuth m => AuthPlugin m
authGoogleEmail =
AuthPlugin pid dispatch login
where
complete = PluginR pid ["complete"]
login tm =
[whamlet|<a href=@{tm forwardUrl}>_{Msg.LoginGoogle}|]
dispatch "GET" ["forward"] = do
render <- getUrlRender
let complete' = render complete
master <- lift getYesod
eres <- lift $ try $ OpenId.getForwardUrl googleIdent complete' Nothing
[ ("openid.ax.type.email", "http://schema.openid.net/contact/email")
, ("openid.ns.ax", "http://openid.net/srv/ax/1.0")
, ("openid.ns.ax.required", "email")
, ("openid.ax.mode", "fetch_request")
, ("openid.ax.required", "email")
, ("openid.ui.icon", "true")
] (authHttpManager master)
either
(\err -> do
tm <- getRouteToParent
lift $ loginErrorMessage (tm LoginR) $ T.pack $ show (err :: SomeException))
redirect
eres
dispatch "GET" ["complete", ""] = dispatch "GET" ["complete"] -- compatibility issues
dispatch "GET" ["complete"] = do
rr <- getRequest
completeHelper $ reqGetParams rr
dispatch "POST" ["complete", ""] = dispatch "POST" ["complete"] -- compatibility issues
dispatch "POST" ["complete"] = do
(posts, _) <- runRequestBody
completeHelper posts
dispatch _ _ = notFound
completeHelper :: [(Text, Text)] -> AuthHandler master TypedContent
completeHelper gets' = do
master <- lift getYesod
eres <- lift $ try $ OpenId.authenticateClaimed gets' (authHttpManager master)
tm <- getRouteToParent
either (onFailure tm) (onSuccess tm) eres
where
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 $ setCredsRedirect $ Creds pid email []
(_, False) -> lift $ loginErrorMessage (tm LoginR) "Only Google login is supported"
(Nothing, _) -> lift $ loginErrorMessage (tm LoginR) "No email address provided"

54
yesod-auth/Yesod/Auth/GoogleEmail2.hs
View File

@ -2,6 +2,8 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
-- | Use an email address as an identifier via Google's login system.
--
-- Note that this is a replacement for "Yesod.Auth.GoogleEmail", which depends
@ -54,16 +56,16 @@ import Yesod.Auth (Auth, AuthPlugin (AuthPlugin),
AuthRoute, Creds (Creds),
Route (PluginR), YesodAuth,
runHttpRequest, setCredsRedirect,
logoutDest)
logoutDest, AuthHandler)
import qualified Yesod.Auth.Message as Msg
import Yesod.Core (HandlerSite, HandlerT, MonadHandler,
import Yesod.Core (HandlerSite, MonadHandler,
TypedContent, getRouteToParent,
getUrlRender, invalidArgs,
lift, liftIO, lookupGetParam,
liftIO, lookupGetParam,
lookupSession, notFound, redirect,
setSession, whamlet, (.:),
addMessage, getYesod,
toHtml)
toHtml, liftSubHandler)
import Blaze.ByteString.Builder (fromByteString, toByteString)
@ -82,7 +84,7 @@ import qualified Data.Aeson.Encode as A
import Data.Aeson.Parser (json')
import Data.Aeson.Types (FromJSON (parseJSON), parseEither,
parseMaybe, withObject, withText)
import Data.Conduit (($$+-), ($$))
import Data.Conduit
import Data.Conduit.Attoparsec (sinkParser)
import qualified Data.HashMap.Strict as M
import Data.Maybe (fromMaybe)
@ -187,10 +189,10 @@ authPlugin storeToken clientID clientSecret =
dispatch :: YesodAuth site
=> Text
-> [Text]
-> HandlerT Auth (HandlerT site IO) TypedContent
-> AuthHandler site TypedContent
dispatch "GET" ["forward"] = do
tm <- getRouteToParent
lift (getDest tm) >>= redirect
getDest tm >>= redirect
dispatch "GET" ["complete"] = do
mstate <- lookupGetParam "state"
@ -207,30 +209,27 @@ authPlugin storeToken clientID clientSecret =
case merr of
Nothing -> invalidArgs ["Missing code paramter"]
Just err -> do
master <- lift getYesod
master <- getYesod
let msg =
case err of
"access_denied" -> "Access denied"
_ -> "Unknown error occurred: " `T.append` err
addMessage "error" $ toHtml msg
lift $ redirect $ logoutDest master
redirect $ logoutDest master
Just c -> return c
render <- getUrlRender
tm <- getRouteToParent
req' <- liftIO $
#if MIN_VERSION_http_client(0,4,30)
HTTP.parseUrlThrow
#else
HTTP.parseUrl
#endif
"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)
, ("redirect_uri", encodeUtf8 $ render $ tm complete)
, ("grant_type", "authorization_code")
]
req'
@ -257,38 +256,31 @@ authPlugin storeToken clientID clientSecret =
[e] -> return e
[] -> error "No account email"
x -> error $ "Too many account emails: " ++ show x
lift $ setCredsRedirect $ Creds pid email $ allPersonInfo personValue
setCredsRedirect $ Creds pid email $ allPersonInfo personValue
dispatch _ _ = notFound
makeHttpRequest
:: (YesodAuth site)
=> Request
-> HandlerT Auth (HandlerT site IO) A.Value
makeHttpRequest req = lift $
runHttpRequest req $ \res -> bodyReaderSource (responseBody res) $$ sinkParser json'
makeHttpRequest :: Request -> AuthHandler site A.Value
makeHttpRequest req =
liftSubHandler $ runHttpRequest req $ \res ->
runConduit $ bodyReaderSource (responseBody res) .| sinkParser json'
-- | Allows to fetch information about a user from Google's API.
-- In case of parsing error returns 'Nothing'.
-- Will throw 'HttpException' in case of network problems or error response code.
--
-- @since 1.4.3
getPerson :: Manager -> Token -> HandlerT site IO (Maybe Person)
getPerson manager token = parseMaybe parseJSON <$> (do
getPerson :: Manager -> Token -> AuthHandler site (Maybe Person)
getPerson manager token = liftSubHandler $ parseMaybe parseJSON <$> (do
req <- personValueRequest token
res <- http req manager
responseBody res $$+- sinkParser json'
runConduit $ responseBody res .| sinkParser json'
)
personValueRequest :: MonadIO m => Token -> m Request
personValueRequest token = do
req2' <- liftIO $
#if MIN_VERSION_http_client(0,4,30)
HTTP.parseUrlThrow
#else
HTTP.parseUrl
#endif
"https://www.googleapis.com/plus/v1/people/me"
req2' <- liftIO
$ HTTP.parseUrlThrow "https://www.googleapis.com/plus/v1/people/me"
return req2'
{ requestHeaders =
[ ("Authorization", encodeUtf8 $ "Bearer " `mappend` accessToken token)

23
yesod-auth/Yesod/Auth/Hardcoded.hs
View File

@ -131,9 +131,10 @@ module Yesod.Auth.Hardcoded
, loginR )
where
import Yesod.Auth (Auth, AuthPlugin (..), AuthRoute,
import Yesod.Auth (AuthPlugin (..), AuthRoute,
Creds (..), Route (..), YesodAuth,
loginErrorMessageI, setCredsRedirect)
loginErrorMessageI, setCredsRedirect,
AuthHandler)
import qualified Yesod.Auth.Message as Msg
import Yesod.Core
import Yesod.Form (ireq, runInputPost, textField)
@ -148,10 +149,10 @@ loginR = PluginR "hardcoded" ["login"]
class (YesodAuth site) => YesodAuthHardcoded site where
-- | Check whether given user name exists among hardcoded names.
doesUserNameExist :: Text -> HandlerT site IO Bool
doesUserNameExist :: Text -> AuthHandler site Bool
-- | Validate given user name with given password.
validatePassword :: Text -> Text -> HandlerT site IO Bool
validatePassword :: Text -> Text -> AuthHandler site Bool
authHardcoded :: YesodAuthHardcoded m => AuthPlugin m
@ -182,16 +183,16 @@ authHardcoded =
|]
postLoginR :: (YesodAuthHardcoded master)
=> HandlerT Auth (HandlerT master IO) TypedContent
postLoginR :: YesodAuthHardcoded site
=> AuthHandler site TypedContent
postLoginR =
do (username, password) <- lift (runInputPost
do (username, password) <- runInputPost
((,) Control.Applicative.<$> ireq textField "username"
Control.Applicative.<*> ireq textField "password"))
isValid <- lift (validatePassword username password)
Control.Applicative.<*> ireq textField "password")
isValid <- validatePassword username password
if isValid
then lift (setCredsRedirect (Creds "hardcoded" username []))
else do isExists <- lift (doesUserNameExist username)
then setCredsRedirect (Creds "hardcoded" username [])
else do isExists <- doesUserNameExist username
loginErrorMessageI LoginR
(if isExists
then Msg.InvalidUsernamePass

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

@ -3,6 +3,7 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE GADTs #-}
module Yesod.Auth.OpenId
( authOpenId
, forwardUrl
@ -19,7 +20,7 @@ import Yesod.Form
import Yesod.Core
import Data.Text (Text, isPrefixOf)
import qualified Yesod.Auth.Message as Msg
import Control.Exception.Lifted (SomeException, try)
import UnliftIO.Exception (tryAny)
import Data.Maybe (fromMaybe)
import qualified Data.Text as T
@ -36,7 +37,10 @@ authOpenId idType extensionFields =
AuthPlugin "openid" dispatch login
where
complete = PluginR "openid" ["complete"]
name :: Text
name = "openid_identifier"
login tm = do
ident <- newIdent
-- FIXME this is a hack to get GHC 7.6's type checker to allow the
@ -57,19 +61,19 @@ $newline never
<input id="#{ident}" type="text" name="#{name}" value="http://">
<input type="submit" value="_{Msg.LoginOpenID}">
|]
dispatch :: Text -> [Text] -> AuthHandler master TypedContent
dispatch "GET" ["forward"] = do
roid <- lift $ runInputGet $ iopt textField name
roid <- runInputGet $ iopt textField name
case roid of
Just oid -> do
tm <- getRouteToParent
render <- getUrlRender
let complete' = render complete
master <- lift getYesod
eres <- lift $ try $ OpenId.getForwardUrl oid complete' Nothing extensionFields (authHttpManager master)
let complete' = render $ tm complete
manager <- authHttpManager
eres <- tryAny $ OpenId.getForwardUrl oid complete' Nothing extensionFields manager
case eres of
Left err -> do
tm <- getRouteToParent
lift $ loginErrorMessage (tm LoginR) $ T.pack $
show (err :: SomeException)
Left err -> loginErrorMessage (tm LoginR) $ T.pack $ show err
Right x -> redirect x
Nothing -> loginErrorMessageI LoginR Msg.NoOpenID
dispatch "GET" ["complete", ""] = dispatch "GET" ["complete"] -- compatibility issues
@ -84,14 +88,13 @@ $newline never
completeHelper :: IdentifierType -> [(Text, Text)] -> AuthHandler master TypedContent
completeHelper idType gets' = do
master <- lift getYesod
eres <- try $ OpenId.authenticateClaimed gets' (authHttpManager master)
manager <- authHttpManager
eres <- tryAny $ OpenId.authenticateClaimed gets' manager
either onFailure onSuccess eres
where
onFailure err = do
tm <- getRouteToParent
lift $ loginErrorMessage (tm LoginR) $ T.pack $
show (err :: SomeException)
loginErrorMessage (tm LoginR) $ T.pack $ show err
onSuccess oir = do
let claimed =
case OpenId.oirClaimed oir of
@ -105,7 +108,7 @@ completeHelper idType gets' = do
case idType of
OPLocal -> OpenId.oirOpLocal oir
Claimed -> fromMaybe (OpenId.oirOpLocal oir) $ OpenId.oirClaimed oir
lift $ setCredsRedirect $ Creds "openid" i gets''
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

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

@ -2,6 +2,7 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
module Yesod.Auth.Rpxnow
( authRpxnow
) where
@ -17,10 +18,10 @@ import Data.Text.Encoding.Error (lenientDecode)
import Control.Arrow ((***))
import Network.HTTP.Types (renderQuery)
authRpxnow :: YesodAuth m
authRpxnow :: YesodAuth master
=> String -- ^ app name
-> String -- ^ key
-> AuthPlugin m
-> AuthPlugin master
authRpxnow app apiKey =
AuthPlugin "rpxnow" dispatch login
where
@ -32,14 +33,16 @@ authRpxnow app apiKey =
$newline never
<iframe src="http://#{app}.rpxnow.com/openid/embed#{queryString}" scrolling="no" frameBorder="no" allowtransparency="true" style="width:400px;height:240px">
|]
dispatch :: a -> [b] -> AuthHandler master TypedContent
dispatch _ [] = do
token1 <- lookupGetParams "token"
token2 <- lookupPostParams "token"
token <- case token1 ++ token2 of
[] -> invalidArgs ["token: Value not supplied"]
x:_ -> return $ unpack x
master <- lift getYesod
Rpxnow.Identifier ident extra <- lift $ Rpxnow.authenticate apiKey token (authHttpManager master)
manager <- authHttpManager
Rpxnow.Identifier ident extra <- Rpxnow.authenticate apiKey token manager
let creds =
Creds "rpxnow" ident
$ maybe id (\x -> (:) ("verifiedEmail", x))
@ -47,7 +50,7 @@ $newline never
$ maybe id (\x -> (:) ("displayName", x))
(fmap pack $ getDisplayName $ map (unpack *** unpack) extra)
[]
lift $ setCredsRedirect creds
setCredsRedirect creds
dispatch _ _ = notFound
-- | Get some form of a display name.

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

@ -1,5 +1,5 @@
name: yesod-auth
version: 1.4.21
version: 1.6.0
license: MIT
license-file: LICENSE
author: Michael Snoyman, Patrick Brisbin
@ -21,9 +21,9 @@ flag network-uri
library
build-depends: base >= 4 && < 5
, authenticate >= 1.3
, authenticate >= 1.3.4
, bytestring >= 0.9.1.4
, yesod-core >= 1.4.31 && < 1.5
, yesod-core >= 1.6 && < 1.7
, wai >= 1.4
, template-haskell
, base16-bytestring
@ -32,18 +32,19 @@ library
, random >= 1.0.0.2
, text >= 0.7
, mime-mail >= 0.3
, yesod-persistent >= 1.4
, yesod-persistent >= 1.6
, shakespeare
, containers
, unordered-containers
, yesod-form >= 1.4 && < 1.5
, yesod-form >= 1.6 && < 1.7
, transformers >= 0.2.2
, persistent >= 2.1 && < 2.8
, persistent >= 2.8 && < 2.9
, persistent-template >= 2.1 && < 2.8
, http-client
, http-client >= 0.5
, http-client-tls
, http-conduit >= 2.1
, aeson >= 0.7
, lifted-base >= 0.1
, unliftio
, blaze-html >= 0.5
, blaze-markup >= 0.5.1
, http-types
@ -58,9 +59,11 @@ library
, binary
, http-client
, blaze-builder
, conduit
, conduit >= 1.3
, conduit-extra
, nonce >= 1.0.2 && < 1.1
, unliftio-core
, unliftio
if flag(network-uri)
build-depends: network-uri >= 2.6
@ -74,7 +77,6 @@ library
Yesod.Auth.OpenId
Yesod.Auth.Rpxnow
Yesod.Auth.Message
Yesod.Auth.GoogleEmail
Yesod.Auth.GoogleEmail2
Yesod.Auth.Hardcoded
Yesod.Auth.Util.PasswordStore

9
yesod-bin/AddHandler.hs
View File

@ -1,3 +1,4 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE PatternGuards #-}
module AddHandler (addHandler) where
@ -8,7 +9,11 @@ import Data.List (isPrefixOf, isSuffixOf, stripPrefix)
import Data.Maybe (fromMaybe, listToMaybe)
import qualified Data.Text as T
import qualified Data.Text.IO as TIO
#if MIN_VERSION_Cabal(2, 0, 0)
import Distribution.PackageDescription.Parse (readGenericPackageDescription)
#else
import Distribution.PackageDescription.Parse (readPackageDescription)
#endif
import Distribution.PackageDescription.Configuration (flattenPackageDescription)
import Distribution.PackageDescription (allBuildInfo, hsSourceDirs)
import Distribution.Verbosity (normal)
@ -224,7 +229,11 @@ uncapitalize "" = ""
getSrcDir :: FilePath -> IO FilePath
getSrcDir cabal = do
#if MIN_VERSION_Cabal(2, 0, 0)
pd <- flattenPackageDescription <$> readGenericPackageDescription normal cabal
#else
pd <- flattenPackageDescription <$> readPackageDescription normal cabal
#endif
let buildInfo = allBuildInfo pd
srcDirs = concatMap hsSourceDirs buildInfo
return $ fromMaybe "." $ listToMaybe srcDirs

270
yesod-bin/Build.hs
View File

@ -1,270 +0,0 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
module Build
( getDeps
, touchDeps
, touch
, recompDeps
, isNewerThan
, safeReadFile
) where
import Control.Applicative as App ((<|>), many, (<$>))
import qualified Data.Attoparsec.Text as A
import Data.Char (isSpace, isUpper)
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8With)
import Data.Text.Encoding.Error (lenientDecode)
import Data.ByteString (ByteString)
import qualified Data.ByteString as S
import Control.Exception (SomeException, try, IOException)
import Control.Exception.Lifted (handle)
import Control.Monad (when, filterM, forM, forM_, (>=>))
import Control.Monad.Trans.State (StateT, get, put, execStateT)
import Control.Monad.Trans.Writer (WriterT, tell, execWriterT)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Trans.Class (lift)
import Data.Monoid (Monoid (..))
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified System.Posix.Types
import System.Directory
import System.FilePath (takeExtension, replaceExtension, (</>), takeDirectory,
splitPath, joinPath)
import System.PosixCompat.Files (getFileStatus, setFileTimes,
accessTime, modificationTime)
import Text.Shakespeare (Deref)
import Text.Julius (juliusUsedIdentifiers)
import Text.Cassius (cassiusUsedIdentifiers)
import Text.Lucius (luciusUsedIdentifiers)
safeReadFile :: MonadIO m => FilePath -> m (Either IOException ByteString)
safeReadFile = liftIO . try . S.readFile
touch :: IO ()
touch = do
m <- handle (\(_ :: SomeException) -> return Map.empty) $ readFile touchCache >>= readIO
x <- fmap snd (getDeps [])
m' <- execStateT (execWriterT $ touchDeps id updateFileTime x) m
createDirectoryIfMissing True $ takeDirectory touchCache
writeFile touchCache $ show m'
where
touchCache = "dist/touchCache.txt"
-- | Returns True if any files were touched, otherwise False
recompDeps :: [FilePath] -> StateT (Map.Map FilePath (Set.Set Deref)) IO Bool
recompDeps =
fmap toBool . execWriterT . (liftIO . getDeps >=> touchDeps hiFile removeHi . snd)
where
toBool NoFilesTouched = False
toBool SomeFilesTouched = True
type Deps = Map.Map FilePath ([FilePath], ComparisonType)
getDeps :: [FilePath] -> IO ([FilePath], Deps)
getDeps hsSourceDirs = do
let defSrcDirs = case hsSourceDirs of
[] -> ["."]
ds -> ds
hss <- fmap concat $ mapM findHaskellFiles defSrcDirs
deps' <- mapM determineDeps hss
return $ (hss, fixDeps $ zip hss deps')
data AnyFilesTouched = NoFilesTouched | SomeFilesTouched
instance Data.Monoid.Monoid AnyFilesTouched where
mempty = NoFilesTouched
mappend NoFilesTouched NoFilesTouched = mempty
mappend _ _ = SomeFilesTouched
touchDeps :: (FilePath -> FilePath) ->
(FilePath -> FilePath -> IO ()) ->
Deps -> WriterT AnyFilesTouched (StateT (Map.Map FilePath (Set.Set Deref)) IO) ()
touchDeps f action deps = (mapM_ go . Map.toList) deps
where
go (x, (ys, ct)) = do
isChanged <- handle (\(_ :: SomeException) -> return True) $ lift $
case ct of
AlwaysOutdated -> return True
CompareUsedIdentifiers getDerefs -> do
derefMap <- get
ebs <- safeReadFile x
let newDerefs =
case ebs of
Left _ -> Set.empty
Right bs -> Set.fromList $ getDerefs $ T.unpack $ decodeUtf8With lenientDecode bs
put $ Map.insert x newDerefs derefMap
case Map.lookup x derefMap of
Just oldDerefs | oldDerefs == newDerefs -> return False
_ -> return True
when isChanged $ forM_ ys $ \y -> do
n <- liftIO $ x `isNewerThan` f y
when n $ do
liftIO $ putStrLn ("Forcing recompile for " ++ y ++ " because of " ++ x)
liftIO $ action x y
tell SomeFilesTouched
-- | remove the .hi files for a .hs file, thereby forcing a recompile
removeHi :: FilePath -> FilePath -> IO ()
removeHi _ hs = mapM_ removeFile' hiFiles
where
removeFile' file = try' (removeFile file) >> return ()
hiFiles = map (\e -> "dist/build" </> removeSrc (replaceExtension hs e))
["hi", "p_hi"]
-- | change file mtime of .hs file to that of the dependency
updateFileTime :: FilePath -> FilePath -> IO ()
updateFileTime x hs = do
(_ , modx) <- getFileStatus' x
(access, _ ) <- getFileStatus' hs
_ <- try' (setFileTimes hs access modx)
return ()
hiFile :: FilePath -> FilePath
hiFile hs = "dist/build" </> removeSrc (replaceExtension hs "hi")
removeSrc :: FilePath -> FilePath
removeSrc f = case splitPath f of
("src/" : xs) -> joinPath xs
_ -> f
try' :: IO x -> IO (Either SomeException x)
try' = try
isNewerThan :: FilePath -> FilePath -> IO Bool
isNewerThan f1 f2 = do
(_, mod1) <- getFileStatus' f1
(_, mod2) <- getFileStatus' f2
return (mod1 > mod2)
getFileStatus' :: FilePath ->
IO (System.Posix.Types.EpochTime, System.Posix.Types.EpochTime)
getFileStatus' fp = do
efs <- try' $ getFileStatus fp
case efs of
Left _ -> return (0, 0)
Right fs -> return (accessTime fs, modificationTime fs)
fixDeps :: [(FilePath, [(ComparisonType, FilePath)])] -> Deps
fixDeps =
Map.unionsWith combine . map go
where
go :: (FilePath, [(ComparisonType, FilePath)]) -> Deps
go (x, ys) = Map.fromList $ map (\(ct, y) -> (y, ([x], ct))) ys
combine (ys1, ct) (ys2, _) = (ys1 `mappend` ys2, ct)
findHaskellFiles :: FilePath -> IO [FilePath]
findHaskellFiles path = do
contents <- getDirectoryContents path
fmap concat $ mapM go contents
where
go ('.':_) = return []
go filename = do
d <- doesDirectoryExist full
if not d
then if isHaskellFile
then return [full]
else return []
else if isHaskellDir
then findHaskellFiles full
else return []
where
-- this could fail on unicode
isHaskellDir = isUpper (head filename)
isHaskellFile = takeExtension filename `elem` watch_files
full = path </> filename
watch_files = [".hs", ".lhs"]
data TempType = StaticFiles FilePath
| Verbatim | Messages FilePath | Hamlet | Widget | Julius | Cassius | Lucius
deriving Show
-- | How to tell if a file is outdated.
data ComparisonType = AlwaysOutdated
| CompareUsedIdentifiers (String -> [Deref])
determineDeps :: FilePath -> IO [(ComparisonType, FilePath)]
determineDeps x = do
y <- safeReadFile x
case y of
Left _ -> return []
Right bs -> do
let z = A.parseOnly (many $ (parser <|> (A.anyChar >> return Nothing)))
$ decodeUtf8With lenientDecode bs
case z of
Left _ -> return []
Right r -> mapM go r >>= filterM (doesFileExist . snd) . concat
where
go (Just (StaticFiles fp, _)) = map ((,) AlwaysOutdated) App.<$> getFolderContents fp
go (Just (Hamlet, f)) = return [(AlwaysOutdated, f)]
go (Just (Widget, f)) = return
[ (AlwaysOutdated, "templates/" ++ f ++ ".hamlet")
, (CompareUsedIdentifiers $ map fst . juliusUsedIdentifiers, "templates/" ++ f ++ ".julius")
, (CompareUsedIdentifiers $ map fst . luciusUsedIdentifiers, "templates/" ++ f ++ ".lucius")
, (CompareUsedIdentifiers $ map fst . cassiusUsedIdentifiers, "templates/" ++ f ++ ".cassius")
]
go (Just (Julius, f)) = return [(CompareUsedIdentifiers $ map fst . juliusUsedIdentifiers, f)]
go (Just (Cassius, f)) = return [(CompareUsedIdentifiers $ map fst . cassiusUsedIdentifiers, f)]
go (Just (Lucius, f)) = return [(CompareUsedIdentifiers $ map fst . luciusUsedIdentifiers, f)]
go (Just (Verbatim, f)) = return [(AlwaysOutdated, f)]
go (Just (Messages f, _)) = map ((,) AlwaysOutdated) <$> getFolderContents f
go Nothing = return []
parser = do
ty <- (do _ <- A.string "\nstaticFiles \""
x' <- A.many1 $ A.satisfy (/= '"')
return $ StaticFiles x')
<|> (A.string "$(parseRoutesFile " >> return Verbatim)
<|> (A.string "$(hamletFile " >> return Hamlet)
<|> (A.string "$(ihamletFile " >> return Hamlet)
<|> (A.string "$(whamletFile " >> return Hamlet)
<|> (A.string "$(html " >> return Hamlet)
<|> (A.string "$(widgetFile " >> return Widget)
<|> (A.string "$(Settings.hamletFile " >> return Hamlet)
<|> (A.string "$(Settings.widgetFile " >> return Widget)
<|> (A.string "$(juliusFile " >> return Julius)
<|> (A.string "$(cassiusFile " >> return Cassius)
<|> (A.string "$(luciusFile " >> return Lucius)
<|> (A.string "$(persistFile " >> return Verbatim)
<|> (
A.string "$(persistFileWith " >>
A.many1 (A.satisfy (/= '"')) >>
return Verbatim)
<|> (do
_ <- A.string "\nmkMessage \""
A.skipWhile (/= '"')
_ <- A.string "\" \""
x' <- A.many1 $ A.satisfy (/= '"')
_ <- A.string "\" \""
_y <- A.many1 $ A.satisfy (/= '"')
_ <- A.string "\""
return $ Messages x')
case ty of
Messages{} -> return $ Just (ty, "")
StaticFiles{} -> return $ Just (ty, "")
_ -> do
A.skipWhile isSpace
_ <- A.char '"'
y <- A.many1 $ A.satisfy (/= '"')
_ <- A.char '"'
A.skipWhile isSpace
_ <- A.char ')'
return $ Just (ty, y)
getFolderContents :: FilePath -> IO [FilePath]
getFolderContents fp = do
cs <- getDirectoryContents fp
let notHidden ('.':_) = False
notHidden ('t':"mp") = False
notHidden ('f':"ay") = False
notHidden _ = True
fmap concat $ forM (filter notHidden cs) $ \c -> do
let f = fp ++ '/' : c
isFile <- doesFileExist f
if isFile then return [f] else getFolderContents f

5
yesod-bin/ChangeLog.md
View File

@ -1,3 +1,8 @@
## 1.6.0
* Upgrade to conduit 1.3.0
* Remove configure, build, touch, and test commands
## 1.5.3
* Support typed-process-0.2.0.0

15
yesod-bin/Devel.hs
View File

@ -9,17 +9,15 @@ module Devel
) where
import Control.Applicative ((<|>))
import UnliftIO (race_)
import Control.Concurrent (threadDelay)
import Control.Concurrent.Async (race_)
import Control.Concurrent.STM
import qualified Control.Exception.Safe as Ex
import qualified UnliftIO.Exception as Ex
import Control.Monad (forever, unless, void,
when)
import Data.ByteString (ByteString, isInfixOf)
import qualified Data.ByteString.Lazy as LB
import Data.Conduit (($$), (=$))
import qualified Data.Conduit.Binary as CB
import qualified Data.Conduit.List as CL
import Conduit
import Data.Default.Class (def)
import Data.FileEmbed (embedFile)
import qualified Data.Map as Map
@ -368,9 +366,10 @@ devel opts passThroughArgs = do
-- process is piped to the actual stdout and stderr handles.
withProcess_ procConfig $ \p -> do
let helper getter h =
getter p
$$ CL.iterM (\(str :: ByteString) -> atomically (updateAppPort str buildStarted appPortVar))
=$ CB.sinkHandle h
runConduit
$ getter p
.| iterMC (\(str :: ByteString) -> atomically (updateAppPort str buildStarted appPortVar))
.| sinkHandle h
race_ (helper getStdout stdout) (helper getStderr stderr)
-- Run the inner action with a TVar which will be set to True

17
yesod-bin/HsFile.hs
View File

@ -2,20 +2,17 @@
{-# LANGUAGE OverloadedStrings #-}
module HsFile (mkHsFile) where
import Text.ProjectTemplate (createTemplate)
import Data.Conduit
( ($$), (=$), awaitForever)
import Data.Conduit.Filesystem (sourceDirectory)
import Control.Monad.Trans.Resource (runResourceT)
import qualified Data.Conduit.List as CL
import Conduit
import qualified Data.ByteString as BS
import Control.Monad.IO.Class (liftIO)
import Data.String (fromString)
mkHsFile :: IO ()
mkHsFile = runResourceT $ sourceDirectory "."
$$ readIt
=$ createTemplate
=$ awaitForever (liftIO . BS.putStr)
mkHsFile = runConduitRes
$ sourceDirectory "."
.| readIt
.| createTemplate
.| mapM_C (liftIO . BS.putStr)
where
-- Reads a filepath from upstream and dumps a pair of (filepath, filecontents)
readIt = CL.map $ \i -> (fromString i, liftIO $ BS.readFile i)
readIt = mapC $ \i -> (fromString i, liftIO $ BS.readFile i)

65
yesod-bin/main.hs
View File

@ -2,37 +2,18 @@
{-# LANGUAGE RecordWildCards #-}
module Main (main) where
import Control.Monad (unless)
import Data.Monoid
import Data.Version (showVersion)
import Options.Applicative
import System.Environment (getEnvironment)
import System.Exit (ExitCode (ExitSuccess), exitWith, exitFailure)
import System.Process (rawSystem)
import System.Exit (exitFailure)
import AddHandler (addHandler)
import Devel (DevelOpts (..), devel, develSignal)
import Keter (keter)
import Options (injectDefaults)
import qualified Paths_yesod_bin
import System.IO (hPutStrLn, stderr)
import HsFile (mkHsFile)
#ifndef WINDOWS
import Build (touch)
touch' :: IO ()
touch' = touch
windowsWarning :: String
windowsWarning = ""
#else
touch' :: IO ()
touch' = return ()
windowsWarning :: String
windowsWarning = " (does not work on Windows)"
#endif
data CabalPgm = Cabal | CabalDev deriving (Show, Eq)
@ -91,17 +72,16 @@ main = do
c -> c
})
] optParser'
let cabal = rawSystem' (cabalCommand o)
case optCommand o of
Init _ -> initErrorMsg
HsFiles -> mkHsFile
Configure -> cabal ["configure"]
Build es -> touch' >> cabal ("build":es)
Touch -> touch'
Configure -> cabalErrorMsg
Build _ -> cabalErrorMsg
Touch -> cabalErrorMsg
Keter{..} -> keter (cabalCommand o) _keterNoRebuild _keterNoCopyTo _keterBuildArgs
Version -> putStrLn ("yesod-bin version: " ++ showVersion Paths_yesod_bin.version)
AddHandler{..} -> addHandler addHandlerRoute addHandlerPattern addHandlerMethods
Test -> cabalTest cabal
Test -> cabalErrorMsg
Devel{..} -> devel DevelOpts
{ verbose = optVerbose o
, successHook = develSuccessHook
@ -113,19 +93,6 @@ main = do
} develExtraArgs
DevelSignal -> develSignal
where
cabalTest cabal = do
env <- getEnvironment
case lookup "STACK_EXE" env of
Nothing -> do
touch'
_ <- cabal ["configure", "--enable-tests", "-flibrary-only"]
_ <- cabal ["build"]
cabal ["test"]
Just _ -> do
hPutStrLn stderr "'yesod test' is no longer needed with Stack"
hPutStrLn stderr "Instead, please just run 'stack test'"
exitFailure
initErrorMsg = do
mapM_ putStrLn
[ "The init command has been removed."
@ -136,6 +103,13 @@ main = do
]
exitFailure
cabalErrorMsg = do
mapM_ putStrLn
[ "The configure, build, touch, and test commands have been removed."
, "Please use 'stack' for building your project."
]
exitFailure
optParser' :: ParserInfo Options
optParser' = info (helper <*> optParser) ( fullDesc <> header "Yesod Web Framework command line utility" )
@ -148,17 +122,17 @@ optParser = Options
<> 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"))
(progDesc "DEPRECATED"))
<> command "build" (info (helper <*> (Build <$> extraCabalArgs))
(progDesc $ "Build project (performs TH dependency analysis)" ++ windowsWarning))
(progDesc "DEPRECATED"))
<> command "touch" (info (pure Touch)
(progDesc $ "Touch any files with altered TH dependencies but do not build" ++ windowsWarning))
(progDesc "DEPRECATED"))
<> command "devel" (info (helper <*> develOptions)
(progDesc "Run project with the devel server"))
<> command "devel-signal" (info (helper <*> pure DevelSignal)
(progDesc "Used internally by the devel command"))
<> command "test" (info (pure Test)
(progDesc "Build and run the integration tests"))
(progDesc "DEPRECATED"))
<> command "add-handler" (info (helper <*> addHandlerOptions)
(progDesc ("Add a new handler and module to the project."
++ " Interactively asks for input if you do not specify arguments.")))
@ -217,10 +191,3 @@ addHandlerOptions = AddHandler
-- | Optional @String@ argument
optStr :: Mod OptionFields (Maybe String) -> Parser (Maybe String)
optStr m = option (Just <$> str) $ value Nothing <> m
-- | Like @rawSystem@, but exits if it receives a non-success result.
rawSystem' :: String -> [String] -> IO ()
rawSystem' x y = do
res <- rawSystem x y
unless (res == ExitSuccess) $ exitWith res

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

@ -1,5 +1,5 @@
name: yesod-bin
version: 1.5.3
version: 1.6.0
license: MIT
license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com>
@ -48,17 +48,16 @@ executable yesod
, fsnotify >= 0.0 && < 0.3
, split >= 0.2 && < 0.3
, file-embed
, conduit >= 1.2
, conduit-extra >= 1.2.2
, resourcet >= 0.3 && < 1.2
, conduit >= 1.3
, conduit-extra >= 1.3
, resourcet >= 1.2
, base64-bytestring
, lifted-base
, http-reverse-proxy >= 0.4
, network >= 2.5
, http-client-tls
, http-client >= 0.4.7
, project-template >= 0.1.1
, safe-exceptions
, unliftio
, say
, stm
, transformers
@ -69,13 +68,11 @@ executable yesod
, data-default-class
, streaming-commons
, warp-tls >= 3.0.1
, async
, deepseq
, unliftio
ghc-options: -Wall -threaded -rtsopts
main-is: main.hs
other-modules: Devel
Build
Keter
AddHandler
Paths_yesod_bin

14
yesod-core/ChangeLog.md
View File

@ -1,3 +1,17 @@
## 1.6.0
* Upgrade to conduit 1.3.0
* Switch to `MonadUnliftIO`
* Drop `mwc-random` and `blaze-builder` dependencies
* Strictify some internal data structures
* Add `CI` wrapper to first field in `Header` data constructor
[#1418](https://github.com/yesodweb/yesod/issues/1418)
* Internal only change, users of stable API are unaffected: `WidgetT`
holds its data in an `IORef` so that it is isomorphic to `ReaderT`,
avoiding state-loss issues..
* Overhaul of `HandlerT`/`WidgetT` to no longer be transformers.
* Fix Haddock comment & simplify implementation for `contentTypeTypes` [#1476](https://github.com/yesodweb/yesod/issues/1476)
## 1.4.37.3
* Improve error message when request body is too large [#1477](https://github.com/yesodweb/yesod/pull/1477)

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

@ -31,7 +31,6 @@ module Yesod.Core
-- * Logging
, defaultMakeLogger
, defaultMessageLoggerSource
, defaultShouldLog
, defaultShouldLogIO
, formatLogMessage
, LogLevel (..)
@ -67,11 +66,9 @@ module Yesod.Core
-- * JS loaders
, ScriptLoadPosition (..)
, BottomOfHeadAsync
-- * Subsites
-- * Generalizing type classes
, MonadHandler (..)
, MonadWidget (..)
, getRouteToParent
, defaultLayoutSub
-- * Approot
, guessApproot
, guessApprootOr
@ -95,8 +92,7 @@ module Yesod.Core
, module Text.Blaze.Html
, MonadTrans (..)
, MonadIO (..)
, MonadBase (..)
, MonadBaseControl
, MonadUnliftIO (..)
, MonadResource (..)
, MonadLogger
-- * Commonly referenced functions/datatypes
@ -143,9 +139,7 @@ import qualified Yesod.Core.Internal.Run
import qualified Paths_yesod_core
import Data.Version (showVersion)
import Yesod.Routes.Class
import Control.Monad.IO.Class (MonadIO (..))
import Control.Monad.Base (MonadBase (..))
import Control.Monad.Trans.Control (MonadBaseControl (..))
import UnliftIO (MonadIO (..), MonadUnliftIO (..))
import Control.Monad.Trans.Resource (MonadResource (..))
import Yesod.Core.Internal.LiteApp
@ -185,14 +179,6 @@ maybeAuthorized r isWrite = do
x <- isAuthorized r isWrite
return $ if x == Authorized then Just r else Nothing
getRouteToParent :: Monad m => HandlerT child (HandlerT parent m) (Route child -> Route parent)
getRouteToParent = HandlerT $ return . handlerToParent
defaultLayoutSub :: Yesod parent
=> WidgetT child IO ()
-> HandlerT child (HandlerT parent IO) Html
defaultLayoutSub cwidget = widgetToParentWidget cwidget >>= lift . defaultLayout
showIntegral :: Integral a => a -> String
showIntegral x = show (fromIntegral x :: Integer)

4
yesod-core/Yesod/Core/Class/Breadcrumbs.hs
View File

@ -11,11 +11,11 @@ import Data.Text (Text)
class YesodBreadcrumbs site where
-- | Returns the title and the parent resource, if available. If you return
-- a 'Nothing', then this is considered a top-level page.
breadcrumb :: Route site -> HandlerT site IO (Text , Maybe (Route site))
breadcrumb :: Route site -> HandlerFor site (Text , Maybe (Route site))
-- | Gets the title of the current page and the hierarchy of parent pages,
-- along with their respective titles.
breadcrumbs :: YesodBreadcrumbs site => HandlerT site IO (Text, [(Route site, Text)])
breadcrumbs :: YesodBreadcrumbs site => HandlerFor site (Text, [(Route site, Text)])
breadcrumbs = do
x <- getCurrentRoute
case x of

45
yesod-core/Yesod/Core/Class/Dispatch.hs
View File

@ -6,46 +6,47 @@
{-# LANGUAGE FlexibleContexts #-}
module Yesod.Core.Class.Dispatch where
import Yesod.Routes.Class
import qualified Network.Wai as W
import Yesod.Core.Types
import Yesod.Core.Content
import Yesod.Core.Handler (sendWaiApplication, stripHandlerT)
import Yesod.Core.Content (ToTypedContent (..))
import Yesod.Core.Handler (sendWaiApplication)
import Yesod.Core.Class.Yesod
import Yesod.Core.Class.Handler
-- | This class is automatically instantiated when you use the template haskell
-- mkYesod function. You should never need to deal with it directly.
class Yesod site => YesodDispatch site where
yesodDispatch :: YesodRunnerEnv site -> W.Application
class YesodSubDispatch sub m where
yesodSubDispatch :: YesodSubRunnerEnv sub (HandlerSite m) m
-> W.Application
class YesodSubDispatch sub master where
yesodSubDispatch :: YesodSubRunnerEnv sub master -> W.Application
instance YesodSubDispatch WaiSubsite master where
yesodSubDispatch YesodSubRunnerEnv {..} = app
where
WaiSubsite app = ysreGetSub $ yreSite ysreParentEnv
instance YesodSubDispatch WaiSubsiteWithAuth (HandlerT master IO) where
instance YesodSubDispatch WaiSubsiteWithAuth master where
yesodSubDispatch YesodSubRunnerEnv {..} req =
ysreParentRunner base ysreParentEnv (fmap ysreToParentRoute route) req
ysreParentRunner handlert ysreParentEnv (fmap ysreToParentRoute route) req
where
base = stripHandlerT handlert ysreGetSub ysreToParentRoute route
route = Just $ WaiSubsiteWithAuthRoute (W.pathInfo req) []
WaiSubsiteWithAuth set = ysreGetSub $ yreSite $ ysreParentEnv
handlert = sendWaiApplication $ set
handlert = sendWaiApplication set
-- | A helper function for creating YesodSubDispatch instances, used by the
-- internal generated code. This function has been exported since 1.4.11.
-- It promotes a subsite handler to a wai application.
subHelper :: Monad m -- NOTE: This is incredibly similar in type signature to yesodRunner, should probably be pointed out/explained.
=> HandlerT child (HandlerT parent m) TypedContent
-> YesodSubRunnerEnv child parent (HandlerT parent m)
-> Maybe (Route child)
-> W.Application
subHelper handlert YesodSubRunnerEnv {..} route =
ysreParentRunner base ysreParentEnv (fmap ysreToParentRoute route)
subHelper
:: ToTypedContent content
=> SubHandlerFor child master content
-> YesodSubRunnerEnv child master
-> Maybe (Route child)
-> W.Application
subHelper (SubHandlerFor f) YesodSubRunnerEnv {..} mroute =
ysreParentRunner handler ysreParentEnv (fmap ysreToParentRoute mroute)
where
base = stripHandlerT (fmap toTypedContent handlert) ysreGetSub ysreToParentRoute route
handler = fmap toTypedContent $ HandlerFor $ \hd ->
let rhe = handlerEnv hd
rhe' = rhe
{ rheRoute = mroute
, rheChild = ysreGetSub $ yreSite ysreParentEnv
, rheRouteToMaster = ysreToParentRoute
}
in f hd { handlerEnv = rhe' }

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

@ -5,29 +5,26 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} -- Because of ErrorT
module Yesod.Core.Class.Handler
( MonadHandler (..)
, MonadWidget (..)
, liftHandlerT
, liftWidgetT
) where
import Yesod.Core.Types
import Control.Monad (liftM)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Resource (MonadResource, MonadResourceBase)
import Control.Monad.Logger (MonadLogger)
import Control.Monad.Trans.Resource (MonadResource)
import Control.Monad.Trans.Class (lift)
#if __GLASGOW_HASKELL__ < 710
import Data.Monoid (Monoid, mempty)
import Data.Monoid (Monoid)
#endif
import Data.Conduit.Internal (Pipe, ConduitM)
import Control.Monad.Trans.Identity ( IdentityT)
import Control.Monad.Trans.List ( ListT )
import Control.Monad.Trans.Maybe ( MaybeT )
import Control.Monad.Trans.Error ( ErrorT, Error)
#if MIN_VERSION_transformers(0,4,0)
import Control.Monad.Trans.Except ( ExceptT )
#endif
import Control.Monad.Trans.Reader ( ReaderT )
import Control.Monad.Trans.State ( StateT )
import Control.Monad.Trans.Writer ( WriterT )
@ -36,32 +33,55 @@ import qualified Control.Monad.Trans.RWS.Strict as Strict ( RWST )
import qualified Control.Monad.Trans.State.Strict as Strict ( StateT )
import qualified Control.Monad.Trans.Writer.Strict as Strict ( WriterT )
class MonadResource m => MonadHandler m where
-- FIXME should we just use MonadReader instances instead?
class (MonadResource m, MonadLogger m) => MonadHandler m where
type HandlerSite m
liftHandlerT :: HandlerT (HandlerSite m) IO a -> m a
type SubHandlerSite m
liftHandler :: HandlerFor (HandlerSite m) a -> m a
liftSubHandler :: SubHandlerFor (SubHandlerSite m) (HandlerSite m) a -> m a
replaceToParent :: HandlerData site route -> HandlerData site ()
replaceToParent hd = hd { handlerToParent = const () }
liftHandlerT :: MonadHandler m => HandlerFor (HandlerSite m) a -> m a
liftHandlerT = liftHandler
{-# DEPRECATED liftHandlerT "Use liftHandler instead" #-}
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)" liftHandlerT = id #-}
instance MonadHandler (HandlerFor site) where
type HandlerSite (HandlerFor site) = site
type SubHandlerSite (HandlerFor site) = site
liftHandler = id
{-# INLINE liftHandler #-}
liftSubHandler (SubHandlerFor f) = HandlerFor f
{-# INLINE liftSubHandler #-}
instance MonadResourceBase m => MonadHandler (WidgetT site m) where
type HandlerSite (WidgetT site m) = site
liftHandlerT (HandlerT f) = WidgetT $ liftIO . liftM (, mempty) . f . replaceToParent
{-# RULES "liftHandlerT (WidgetT site IO)" forall f. liftHandlerT (HandlerT f) = WidgetT $ liftM (, mempty) . f #-}
instance MonadHandler (SubHandlerFor sub master) where
type HandlerSite (SubHandlerFor sub master) = master
type SubHandlerSite (SubHandlerFor sub master) = sub
liftHandler (HandlerFor f) = SubHandlerFor $ \hd -> f hd
{ handlerEnv =
let rhe = handlerEnv hd
in rhe
{ rheRoute = fmap (rheRouteToMaster rhe) (rheRoute rhe)
, rheRouteToMaster = id
, rheChild = rheSite rhe
}
}
{-# INLINE liftHandler #-}
liftSubHandler = id
{-# INLINE liftSubHandler #-}
#define GO(T) instance MonadHandler m => MonadHandler (T m) where type HandlerSite (T m) = HandlerSite m; liftHandlerT = lift . liftHandlerT
#define GOX(X, T) instance (X, MonadHandler m) => MonadHandler (T m) where type HandlerSite (T m) = HandlerSite m; liftHandlerT = lift . liftHandlerT
instance MonadHandler (WidgetFor site) where
type HandlerSite (WidgetFor site) = site
type SubHandlerSite (WidgetFor site) = site
liftHandler (HandlerFor f) = WidgetFor $ f . wdHandler
{-# INLINE liftHandler #-}
liftSubHandler (SubHandlerFor f) = WidgetFor $ f . wdHandler
{-# INLINE liftSubHandler #-}
#define GO(T) instance MonadHandler m => MonadHandler (T m) where type HandlerSite (T m) = HandlerSite m; type SubHandlerSite (T m) = SubHandlerSite m; liftHandler = lift . liftHandler; liftSubHandler = lift . liftSubHandler
#define GOX(X, T) instance (X, MonadHandler m) => MonadHandler (T m) where type HandlerSite (T m) = HandlerSite m; type SubHandlerSite (T m) = SubHandlerSite m; liftHandler = lift . liftHandler; liftSubHandler = lift . liftSubHandler
GO(IdentityT)
GO(ListT)
GO(MaybeT)
GOX(Error e, ErrorT e)
#if MIN_VERSION_transformers(0,4,0)
GO(ExceptT e)
#endif
GO(ReaderT r)
GO(StateT s)
GOX(Monoid w, WriterT w)
@ -75,19 +95,21 @@ GO(ConduitM i o)
#undef GOX
class MonadHandler m => MonadWidget m where
liftWidgetT :: WidgetT (HandlerSite m) IO a -> m a
instance MonadResourceBase m => MonadWidget (WidgetT site m) where
liftWidgetT (WidgetT f) = WidgetT $ liftIO . f . replaceToParent
liftWidget :: WidgetFor (HandlerSite m) a -> m a
instance MonadWidget (WidgetFor site) where
liftWidget = id
{-# INLINE liftWidget #-}
#define GO(T) instance MonadWidget m => MonadWidget (T m) where liftWidgetT = lift . liftWidgetT
#define GOX(X, T) instance (X, MonadWidget m) => MonadWidget (T m) where liftWidgetT = lift . liftWidgetT
liftWidgetT :: MonadWidget m => WidgetFor (HandlerSite m) a -> m a
liftWidgetT = liftWidget
{-# DEPRECATED liftWidgetT "Use liftWidget instead" #-}
#define GO(T) instance MonadWidget m => MonadWidget (T m) where liftWidget = lift . liftWidget
#define GOX(X, T) instance (X, MonadWidget m) => MonadWidget (T m) where liftWidget = lift . liftWidget
GO(IdentityT)
GO(ListT)
GO(MaybeT)
GOX(Error e, ErrorT e)
#if MIN_VERSION_transformers(0,4,0)
GO(ExceptT e)
#endif
GO(ReaderT r)
GO(StateT s)
GOX(Monoid w, WriterT w)

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

@ -10,9 +10,8 @@ import Yesod.Core.Handler
import Yesod.Routes.Class
import Blaze.ByteString.Builder (Builder, toByteString)
import Blaze.ByteString.Builder.ByteString (copyByteString)
import Blaze.ByteString.Builder.Char.Utf8 (fromText, fromChar)
import Data.ByteString.Builder (Builder)
import Data.Text.Encoding (encodeUtf8Builder)
import Control.Arrow ((***), second)
import Control.Exception (bracket)
#if __GLASGOW_HASKELL__ < 710
@ -37,9 +36,8 @@ import Data.Text.Lazy.Builder (toLazyText)
import Data.Text.Lazy.Encoding (encodeUtf8)
import Data.Word (Word64)
import Language.Haskell.TH.Syntax (Loc (..))
import Network.HTTP.Types (encodePath, renderQueryText)
import Network.HTTP.Types (encodePath)
import qualified Network.Wai as W
import Data.Default (def)
import Network.Wai.Parse (lbsBackEnd,
tempFileBackEnd)
import Network.Wai.Logger (ZonedDate, clockDateCacher)
@ -52,13 +50,13 @@ import Text.Hamlet
import Text.Julius
import qualified Web.ClientSession as CS
import Web.Cookie (SetCookie (..), parseCookies, sameSiteLax,
sameSiteStrict, SameSiteOption)
sameSiteStrict, SameSiteOption, defaultSetCookie)
import Yesod.Core.Types
import Yesod.Core.Internal.Session
import Yesod.Core.Widget
import Control.Monad.Trans.Class (lift)
import Data.CaseInsensitive (CI)
import qualified Network.Wai.Request
import Data.IORef
-- | Define settings for a Yesod applications. All methods have intelligent
-- defaults, and therefore no implementation is required.
@ -66,27 +64,23 @@ class RenderRoute site => Yesod site where
-- | An absolute URL to the root of the application. Do not include
-- trailing slash.
--
-- Default value: 'ApprootRelative'. This is valid under the following
-- conditions:
-- Default value: 'guessApproot'. If you know your application root
-- statically, it will be more efficient and more reliable to instead use
-- 'ApprootStatic' or 'ApprootMaster'. If you do not need full absolute
-- URLs, you can use 'ApprootRelative' instead.
--
-- * Your application is served from the root of the domain.
--
-- * You do not use any features that require absolute URLs, such as Atom
-- feeds and XML sitemaps.
--
-- If this is not true, you should override with a different
-- implementation.
-- Note: Prior to yesod-core 1.5, the default value was 'ApprootRelative'.
approot :: Approot site
approot = ApprootRelative
approot = guessApproot
-- | Output error response pages.
--
-- Default value: 'defaultErrorHandler'.
errorHandler :: ErrorResponse -> HandlerT site IO TypedContent
errorHandler :: ErrorResponse -> HandlerFor site TypedContent
errorHandler = defaultErrorHandler
-- | Applies some form of layout to the contents of a page.
defaultLayout :: WidgetT site IO () -> HandlerT site IO Html
defaultLayout :: WidgetFor site () -> HandlerFor site Html
defaultLayout w = do
p <- widgetToPageContent w
msgs <- getMessages
@ -103,33 +97,19 @@ class RenderRoute site => Yesod site where
^{pageBody p}
|]
-- | Override the rendering function for a particular URL. One use case for
-- this is to offload static hosting to a different domain name to avoid
-- sending cookies.
urlRenderOverride :: site -> Route site -> Maybe Builder
urlRenderOverride _ _ = Nothing
-- | Override the rendering function for a particular URL and query string
-- parameters. One use case for this is to offload static hosting to a
-- different domain name to avoid sending cookies.
--
--
-- For backward compatibility default implementation is in terms of
-- 'urlRenderOverride', probably ineffective
--
--
-- Since 1.4.23
urlParamRenderOverride :: site
-> Route site
-> [(T.Text, T.Text)] -- ^ query string
-> Maybe Builder
urlParamRenderOverride y route params = addParams params <$> urlRenderOverride y route
where
addParams [] routeBldr = routeBldr
addParams nonEmptyParams routeBldr =
let routeBS = toByteString routeBldr
qsSeparator = fromChar $ if S8.elem '?' routeBS then '&' else '?'
valueToMaybe t = if t == "" then Nothing else Just t
queryText = map (id *** valueToMaybe) nonEmptyParams
in copyByteString routeBS `mappend` qsSeparator `mappend` renderQueryText False queryText
urlParamRenderOverride _ _ _ = Nothing
-- | Determine if a request is authorized or not.
--
@ -138,7 +118,7 @@ class RenderRoute site => Yesod site where
-- If authentication is required, return 'AuthenticationRequired'.
isAuthorized :: Route site
-> Bool -- ^ is this a write request?
-> HandlerT site IO AuthResult
-> HandlerFor site AuthResult
isAuthorized _ _ = return Authorized
-- | Determines whether the current request is a write request. By default,
@ -148,7 +128,7 @@ class RenderRoute site => Yesod site where
--
-- This function is used to determine if a request is authorized; see
-- 'isAuthorized'.
isWriteRequest :: Route site -> HandlerT site IO Bool
isWriteRequest :: Route site -> HandlerFor site Bool
isWriteRequest _ = do
wai <- waiRequest
return $ W.requestMethod wai `notElem`
@ -191,7 +171,7 @@ class RenderRoute site => Yesod site where
-> [(T.Text, T.Text)] -- ^ query string
-> Builder
joinPath _ ar pieces' qs' =
fromText ar `mappend` encodePath pieces qs
encodeUtf8Builder ar `mappend` encodePath pieces qs
where
pieces = if null pieces' then [""] else map addDash pieces'
qs = map (TE.encodeUtf8 *** go) qs'
@ -214,7 +194,7 @@ class RenderRoute site => Yesod site where
addStaticContent :: Text -- ^ filename extension
-> Text -- ^ mime-type
-> L.ByteString -- ^ content
-> HandlerT site IO (Maybe (Either Text (Route site, [(Text, Text)])))
-> HandlerFor site (Maybe (Either Text (Route site, [(Text, Text)])))
addStaticContent _ _ _ = return Nothing
-- | Maximum allowed length of the request body, in bytes.
@ -280,22 +260,11 @@ class RenderRoute site => Yesod site where
-- | Should we log the given log source/level combination.
--
-- Default: the 'defaultShouldLog' function.
shouldLog :: site -> LogSource -> LogLevel -> Bool
shouldLog _ = defaultShouldLog
-- | Should we log the given log source/level combination.
--
-- Note that this is almost identical to @shouldLog@, except the result
-- lives in @IO@. This allows you to dynamically alter the logging level of
-- your application by having this result depend on, e.g., an @IORef@.
--
-- The default implementation simply uses @shouldLog@. Future versions of
-- Yesod will remove @shouldLog@ and use this method exclusively.
-- Default: the 'defaultShouldLogIO' function.
--
-- Since 1.2.4
shouldLogIO :: site -> LogSource -> LogLevel -> IO Bool
shouldLogIO a b c = return (shouldLog a b c)
shouldLogIO _ = defaultShouldLogIO
-- | A Yesod middleware, which will wrap every handler function. This
-- allows you to run code before and after a normal handler.
@ -303,7 +272,7 @@ class RenderRoute site => Yesod site where
-- Default: the 'defaultYesodMiddleware' function.
--
-- Since: 1.1.6
yesodMiddleware :: ToTypedContent res => HandlerT site IO res -> HandlerT site IO res
yesodMiddleware :: ToTypedContent res => HandlerFor site res -> HandlerFor site res
yesodMiddleware = defaultYesodMiddleware
-- | How to allocate an @InternalState@ for each request.
@ -324,7 +293,7 @@ class RenderRoute site => Yesod site where
-- primarily for wrapping up error messages for better display.
--
-- @since 1.4.30
defaultMessageWidget :: Html -> HtmlUrl (Route site) -> WidgetT site IO ()
defaultMessageWidget :: Html -> HtmlUrl (Route site) -> WidgetFor site ()
defaultMessageWidget title body = do
setTitle title
toWidget
@ -332,7 +301,6 @@ class RenderRoute site => Yesod site where
<h1>#{title}
^{body}
|]
{-# DEPRECATED urlRenderOverride "Use urlParamRenderOverride instead" #-}
-- | Default implementation of 'makeLogger'. Sends to stdout and
-- automatically flushes on each write.
@ -369,21 +337,14 @@ defaultMessageLoggerSource ckLoggable logger loc source level msg = do
-- above 'LevelInfo'.
--
-- Since 1.4.10
defaultShouldLog :: LogSource -> LogLevel -> Bool
defaultShouldLog _ level = level >= LevelInfo
-- | A default implementation of 'shouldLogIO' that can be used with
-- 'defaultMessageLoggerSource'. Just uses 'defaultShouldLog'.
--
-- Since 1.4.10
defaultShouldLogIO :: LogSource -> LogLevel -> IO Bool
defaultShouldLogIO a b = return $ defaultShouldLog a b
defaultShouldLogIO _ level = return $ level >= LevelInfo
-- | Default implementation of 'yesodMiddleware'. Adds the response header
-- \"Vary: Accept, Accept-Language\" and performs authorization checks.
--
-- Since 1.2.0
defaultYesodMiddleware :: Yesod site => HandlerT site IO res -> HandlerT site IO res
defaultYesodMiddleware :: Yesod site => HandlerFor site res -> HandlerFor site res
defaultYesodMiddleware handler = do
addHeader "Vary" "Accept, Accept-Language"
authorizationCheck
@ -443,8 +404,8 @@ sameSiteSession s = (fmap . fmap) secureSessionCookies
--
-- Since 1.4.7
sslOnlyMiddleware :: Int -- ^ minutes
-> HandlerT site IO res
-> HandlerT site IO res
-> HandlerFor site res
-> HandlerFor site res
sslOnlyMiddleware timeout handler = do
addHeader "Strict-Transport-Security"
$ T.pack $ concat [ "max-age="
@ -457,7 +418,7 @@ sslOnlyMiddleware timeout handler = do
-- 'isWriteRequest'.
--
-- Since 1.2.0
authorizationCheck :: Yesod site => HandlerT site IO ()
authorizationCheck :: Yesod site => HandlerFor site ()
authorizationCheck = getCurrentRoute >>= maybe (return ()) checkUrl
where
checkUrl url = do
@ -481,7 +442,7 @@ authorizationCheck = getCurrentRoute >>= maybe (return ()) checkUrl
-- | Calls 'csrfCheckMiddleware' with 'isWriteRequest', 'defaultCsrfHeaderName', and 'defaultCsrfParamName' as parameters.
--
-- Since 1.4.14
defaultCsrfCheckMiddleware :: Yesod site => HandlerT site IO res -> HandlerT site IO res
defaultCsrfCheckMiddleware :: Yesod site => HandlerFor site res -> HandlerFor site res
defaultCsrfCheckMiddleware handler =
csrfCheckMiddleware
handler
@ -495,11 +456,11 @@ defaultCsrfCheckMiddleware handler =
-- For details, see the "AJAX CSRF protection" section of "Yesod.Core.Handler".
--
-- Since 1.4.14
csrfCheckMiddleware :: HandlerT site IO res
-> HandlerT site IO Bool -- ^ Whether or not to perform the CSRF check.
csrfCheckMiddleware :: HandlerFor site res
-> HandlerFor site Bool -- ^ Whether or not to perform the CSRF check.
-> CI S8.ByteString -- ^ The header name to lookup the CSRF token from.
-> Text -- ^ The POST parameter name to lookup the CSRF token from.
-> HandlerT site IO res
-> HandlerFor site res
csrfCheckMiddleware handler shouldCheckFn headerName paramName = do
shouldCheck <- shouldCheckFn
when shouldCheck (checkCsrfHeaderOrParam headerName paramName)
@ -510,7 +471,7 @@ csrfCheckMiddleware handler shouldCheckFn headerName paramName = do
-- The cookie's path is set to @/@, making it valid for your whole website.
--
-- Since 1.4.14
defaultCsrfSetCookieMiddleware :: HandlerT site IO res -> HandlerT site IO res
defaultCsrfSetCookieMiddleware :: HandlerFor site res -> HandlerFor site res
defaultCsrfSetCookieMiddleware handler = setCsrfCookie >> handler
-- | Takes a 'SetCookie' and overrides its value with a CSRF token, then sets the cookie. See 'setCsrfCookieWithCookie'.
@ -520,7 +481,7 @@ defaultCsrfSetCookieMiddleware handler = setCsrfCookie >> handler
-- Make sure to set the 'setCookiePath' to the root path of your application, otherwise you'll generate a new CSRF token for every path of your app. If your app is run from from e.g. www.example.com\/app1, use @app1@. The vast majority of sites will just use @/@.
--
-- Since 1.4.14
csrfSetCookieMiddleware :: HandlerT site IO res -> SetCookie -> HandlerT site IO res
csrfSetCookieMiddleware :: HandlerFor site res -> SetCookie -> HandlerFor site res
csrfSetCookieMiddleware handler cookie = setCsrfCookieWithCookie cookie >> handler
-- | Calls 'defaultCsrfSetCookieMiddleware' and 'defaultCsrfCheckMiddleware'.
@ -540,21 +501,26 @@ csrfSetCookieMiddleware handler cookie = setCsrfCookieWithCookie cookie >> handl
-- @
--
-- Since 1.4.14
defaultCsrfMiddleware :: Yesod site => HandlerT site IO res -> HandlerT site IO res
defaultCsrfMiddleware :: Yesod site => HandlerFor site res -> HandlerFor site res
defaultCsrfMiddleware = defaultCsrfSetCookieMiddleware . defaultCsrfCheckMiddleware
-- | Convert a widget to a 'PageContent'.
widgetToPageContent :: Yesod site
=> WidgetT site IO ()
-> HandlerT site IO (PageContent (Route site))
widgetToPageContent w = do
master <- getYesod
hd <- HandlerT return
((), GWData (Body body) (Last mTitle) scripts' stylesheets' style jscript (Head head')) <- lift $ unWidgetT w hd
let title = maybe mempty unTitle mTitle
scripts = runUniqueList scripts'
stylesheets = runUniqueList stylesheets'
=> WidgetFor site ()
-> HandlerFor site (PageContent (Route site))
widgetToPageContent w = HandlerFor $ \hd -> do
master <- unHandlerFor getYesod hd
ref <- newIORef mempty
unWidgetFor w WidgetData
{ wdRef = ref
, wdHandler = hd
}
GWData (Body body) (Last mTitle) scripts' stylesheets' style jscript (Head head') <- readIORef ref
let title = maybe mempty unTitle mTitle
scripts = runUniqueList scripts'
stylesheets = runUniqueList stylesheets'
flip unHandlerFor hd $ do
render <- getUrlRenderParams
let renderLoc x =
case x of
@ -642,7 +608,7 @@ widgetToPageContent w = do
runUniqueList (UniqueList x) = nub $ x []
-- | The default error handler for 'errorHandler'.
defaultErrorHandler :: Yesod site => ErrorResponse -> HandlerT site IO TypedContent
defaultErrorHandler :: Yesod site => ErrorResponse -> HandlerFor site TypedContent
defaultErrorHandler NotFound = selectRep $ do
provideRep $ defaultLayout $ do
r <- waiRequest
@ -866,7 +832,7 @@ loadClientSession key getCachedDate sessionName req = load
save date sess' = do
-- We should never cache the IV! Be careful!
iv <- liftIO CS.randomIV
return [AddCookie def
return [AddCookie defaultSetCookie
{ setCookieName = sessionName
, setCookieValue = encodeClientSession key iv date host sess'
, setCookiePath = Just "/"

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

@ -53,31 +53,26 @@ import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
import Data.Text.Lazy (Text, pack)
import qualified Data.Text as T
import Blaze.ByteString.Builder (Builder, fromByteString, fromLazyByteString)
import Data.Text.Encoding (encodeUtf8Builder)
import qualified Data.Text.Lazy as TL
import Data.ByteString.Builder (Builder, byteString, lazyByteString, stringUtf8)
#if __GLASGOW_HASKELL__ < 710
import Data.Monoid (mempty)
#endif
import Text.Hamlet (Html)
import Text.Blaze.Html.Renderer.Utf8 (renderHtmlBuilder)
import Data.Conduit (Source, Flush (Chunk), ResumableSource, mapOutput)
import Data.Conduit (Flush (Chunk), SealedConduitT, mapOutput)
import Control.Monad (liftM)
import Control.Monad.Trans.Resource (ResourceT)
import Data.Conduit.Internal (ResumableSource (ResumableSource))
import qualified Data.Conduit.Internal as CI
import qualified Data.Aeson as J
#if MIN_VERSION_aeson(1, 0, 0)
#elif MIN_VERSION_aeson(0, 7, 0)
import Data.Aeson.Encode (encodeToTextBuilder)
#else
import Data.Aeson.Encode (fromValue)
#endif
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)
import Data.Word8 (_semicolon, _slash)
import Control.Arrow (second)
-- | Zero-length enumerator.
emptyContent :: Content
@ -99,15 +94,15 @@ instance ToContent Content where
instance ToContent Builder where
toContent = flip ContentBuilder Nothing
instance ToContent B.ByteString where
toContent bs = ContentBuilder (fromByteString bs) $ Just $ B.length bs
toContent bs = ContentBuilder (byteString bs) $ Just $ B.length bs
instance ToContent L.ByteString where
toContent = flip ContentBuilder Nothing . fromLazyByteString
toContent = flip ContentBuilder Nothing . lazyByteString
instance ToContent T.Text where
toContent = toContent . Blaze.fromText
toContent = toContent . encodeUtf8Builder
instance ToContent Text where
toContent = toContent . Blaze.fromLazyText
toContent = toContent . foldMap encodeUtf8Builder . TL.toChunks
instance ToContent String where
toContent = toContent . Blaze.fromString
toContent = toContent . stringUtf8
instance ToContent Html where
toContent bs = ContentBuilder (renderHtmlBuilder bs) Nothing
instance ToContent () where
@ -123,12 +118,12 @@ instance ToContent Javascript where
toContent = toContent . toLazyText . unJavascript
instance ToFlushBuilder builder => ToContent (CI.Pipe () () builder () (ResourceT IO) ()) where
toContent src = ContentSource $ CI.ConduitM (CI.mapOutput toFlushBuilder src >>=)
toContent src = ContentSource $ CI.ConduitT (CI.mapOutput toFlushBuilder src >>=)
instance ToFlushBuilder builder => ToContent (Source (ResourceT IO) builder) where
instance ToFlushBuilder builder => ToContent (CI.ConduitT () builder (ResourceT IO) ()) where
toContent src = ContentSource $ mapOutput toFlushBuilder src
instance ToFlushBuilder builder => ToContent (ResumableSource (ResourceT IO) builder) where
toContent (ResumableSource src _) = toContent src
instance ToFlushBuilder builder => ToContent (SealedConduitT () builder (ResourceT IO) ()) where
toContent (CI.SealedConduitT src) = toContent src
-- | A class for all data which can be sent in a streaming response. Note that
-- for textual data, instances must use UTF-8 encoding.
@ -137,16 +132,16 @@ instance ToFlushBuilder builder => ToContent (ResumableSource (ResourceT IO) bui
class ToFlushBuilder a where toFlushBuilder :: a -> Flush Builder
instance ToFlushBuilder (Flush Builder) where toFlushBuilder = id
instance ToFlushBuilder Builder where toFlushBuilder = Chunk
instance ToFlushBuilder (Flush B.ByteString) where toFlushBuilder = fmap fromByteString
instance ToFlushBuilder B.ByteString where toFlushBuilder = Chunk . fromByteString
instance ToFlushBuilder (Flush L.ByteString) where toFlushBuilder = fmap fromLazyByteString
instance ToFlushBuilder L.ByteString where toFlushBuilder = Chunk . fromLazyByteString
instance ToFlushBuilder (Flush Text) where toFlushBuilder = fmap Blaze.fromLazyText
instance ToFlushBuilder Text where toFlushBuilder = Chunk . Blaze.fromLazyText
instance ToFlushBuilder (Flush T.Text) where toFlushBuilder = fmap Blaze.fromText
instance ToFlushBuilder T.Text where toFlushBuilder = Chunk . Blaze.fromText
instance ToFlushBuilder (Flush String) where toFlushBuilder = fmap Blaze.fromString
instance ToFlushBuilder String where toFlushBuilder = Chunk . Blaze.fromString
instance ToFlushBuilder (Flush B.ByteString) where toFlushBuilder = fmap byteString
instance ToFlushBuilder B.ByteString where toFlushBuilder = Chunk . byteString
instance ToFlushBuilder (Flush L.ByteString) where toFlushBuilder = fmap lazyByteString
instance ToFlushBuilder L.ByteString where toFlushBuilder = Chunk . lazyByteString
instance ToFlushBuilder (Flush Text) where toFlushBuilder = fmap (foldMap encodeUtf8Builder . TL.toChunks)
instance ToFlushBuilder Text where toFlushBuilder = Chunk . foldMap encodeUtf8Builder . TL.toChunks
instance ToFlushBuilder (Flush T.Text) where toFlushBuilder = fmap encodeUtf8Builder
instance ToFlushBuilder T.Text where toFlushBuilder = Chunk . encodeUtf8Builder
instance ToFlushBuilder (Flush String) where toFlushBuilder = fmap stringUtf8
instance ToFlushBuilder String where toFlushBuilder = Chunk . stringUtf8
instance ToFlushBuilder (Flush Html) where toFlushBuilder = fmap renderHtmlBuilder
instance ToFlushBuilder Html where toFlushBuilder = Chunk . renderHtmlBuilder
@ -228,13 +223,13 @@ typeOctet = "application/octet-stream"
simpleContentType :: ContentType -> ContentType
simpleContentType = fst . B.break (== _semicolon)
-- Give just the media types as a pair.
-- | Give just the media types as a pair.
--
-- For example, \"text/html; charset=utf-8\" returns ("text", "html")
contentTypeTypes :: ContentType -> (B.ByteString, B.ByteString)
contentTypeTypes ct = (main, fst $ B.break (== _semicolon) (tailEmpty sub))
contentTypeTypes = second tailEmpty . B.break (== _slash) . simpleContentType
where
tailEmpty x = if B.null x then "" else B.tail x
(main, sub) = B.break (== _slash) ct
instance HasContentType a => HasContentType (DontFullyEvaluate a) where
getContentType = getContentType . liftM unDontFullyEvaluate
@ -243,34 +238,18 @@ instance ToContent a => ToContent (DontFullyEvaluate a) where
toContent (DontFullyEvaluate a) = ContentDontEvaluate $ toContent a
instance ToContent J.Value where
#if MIN_VERSION_aeson(1, 0, 0)
toContent = flip ContentBuilder Nothing
. J.fromEncoding
. J.toEncoding
#else
toContent = flip ContentBuilder Nothing
. Blaze.fromLazyText
. toLazyText
#if MIN_VERSION_aeson(0, 7, 0)
. encodeToTextBuilder
#else
. fromValue
#endif
#endif
#if MIN_VERSION_aeson(0, 11, 0)
instance ToContent J.Encoding where
toContent = flip ContentBuilder Nothing . J.fromEncoding
#endif
instance HasContentType J.Value where
getContentType _ = typeJson
#if MIN_VERSION_aeson(0, 11, 0)
instance HasContentType J.Encoding where
getContentType _ = typeJson
#endif
instance HasContentType Html where
getContentType _ = typeHtml
@ -307,10 +286,8 @@ instance ToTypedContent RepXml where
toTypedContent (RepXml c) = TypedContent typeXml c
instance ToTypedContent J.Value where
toTypedContent v = TypedContent typeJson (toContent v)
#if MIN_VERSION_aeson(0, 11, 0)
instance ToTypedContent J.Encoding where
toTypedContent e = TypedContent typeJson (toContent e)
#endif
instance ToTypedContent Html where
toTypedContent h = TypedContent typeHtml (toContent h)
instance ToTypedContent T.Text where

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

@ -35,7 +35,6 @@ module Yesod.Core.Dispatch
-- * WAI subsites
, WaiSubsite (..)
, WaiSubsiteWithAuth (..)
, subHelper
) where
import Prelude hiding (exp)
@ -53,8 +52,9 @@ import Data.Text (Text)
import Data.Monoid (mappend)
#endif
import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Char8 as S8
import qualified Blaze.ByteString.Builder
import Data.ByteString.Builder (byteString, toLazyByteString)
import Network.HTTP.Types (status301, status307)
import Yesod.Routes.Parse
import Yesod.Core.Types
@ -63,6 +63,7 @@ import Yesod.Core.Class.Dispatch
import Yesod.Core.Internal.Run
import Safe (readMay)
import System.Environment (getEnvironment)
import qualified System.Random as Random
import Control.AutoUpdate (mkAutoUpdate, defaultUpdateSettings, updateAction, updateFreq)
import Yesod.Core.Internal.Util (getCurrentMaxExpiresRFC1123)
@ -78,7 +79,6 @@ import Control.Monad.Logger
import Control.Monad (when)
import qualified Paths_yesod_core
import Data.Version (showVersion)
import qualified System.Random.MWC as MWC
-- | Convert the given argument into a WAI application, executable with any WAI
-- handler. This function will provide no middlewares; if you want commonly
@ -87,16 +87,18 @@ toWaiAppPlain :: YesodDispatch site => site -> IO W.Application
toWaiAppPlain site = do
logger <- makeLogger site
sb <- makeSessionBackend site
gen <- MWC.createSystemRandom
getMaxExpires <- getGetMaxExpires
return $ toWaiAppYre YesodRunnerEnv
{ yreLogger = logger
, yreSite = site
, yreSessionBackend = sb
, yreGen = gen
, yreGen = defaultGen
, yreGetMaxExpires = getMaxExpires
}
defaultGen :: IO Int
defaultGen = Random.getStdRandom Random.next
-- | Pure low level function to construct WAI application. Usefull
-- when you need not standard way to run your app, or want to embed it
-- inside another app.
@ -115,7 +117,7 @@ toWaiAppYre yre req =
sendRedirect y segments' env sendResponse =
sendResponse $ W.responseLBS status
[ ("Content-Type", "text/plain")
, ("Location", Blaze.ByteString.Builder.toByteString dest')
, ("Location", BL.toStrict $ toLazyByteString dest')
] "Redirecting"
where
-- Ensure that non-GET requests get redirected correctly. See:
@ -129,7 +131,7 @@ toWaiAppYre yre req =
if S.null (W.rawQueryString env)
then dest
else dest `mappend`
Blaze.ByteString.Builder.fromByteString (W.rawQueryString env)
byteString (W.rawQueryString env)
-- | Same as 'toWaiAppPlain', but provides a default set of middlewares. This
-- set may change with future releases, but currently covers:
@ -151,13 +153,12 @@ toWaiApp site = do
toWaiAppLogger :: YesodDispatch site => Logger -> site -> IO W.Application
toWaiAppLogger logger site = do
sb <- makeSessionBackend site
gen <- MWC.createSystemRandom
getMaxExpires <- getGetMaxExpires
let yre = YesodRunnerEnv
{ yreLogger = logger
, yreSite = site
, yreSessionBackend = sb
, yreGen = gen
, yreGen = defaultGen
, yreGetMaxExpires = getMaxExpires
}
messageLoggerSource

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

@ -27,6 +27,7 @@
module Yesod.Core.Handler
( -- * Handler monad
HandlerT
, HandlerFor
-- ** Read information from handler
, getYesod
, getsYesod
@ -146,6 +147,10 @@ module Yesod.Core.Handler
, setMessage
, setMessageI
, getMessage
-- * Subsites
, getSubYesod
, getRouteToParent
, getSubCurrentRoute
-- * Helpers for specific content
-- ** Hamlet
, hamletToRepHtml
@ -161,7 +166,6 @@ module Yesod.Core.Handler
-- * Per-request caching
, cached
, cachedBy
, stripHandlerT
-- * AJAX CSRF protection
-- $ajaxCSRFOverview
@ -193,13 +197,14 @@ import Control.Applicative ((<$>))
import Data.Monoid (mempty, mappend)
#endif
import Control.Applicative ((<|>))
import qualified Data.CaseInsensitive as CI
import Control.Exception (evaluate, SomeException, throwIO)
import Control.Exception.Lifted (handle)
import Control.Exception (handle)
import Control.Monad (void, liftM, unless)
import qualified Control.Monad.Trans.Writer as Writer
import Control.Monad.IO.Class (MonadIO, liftIO)
import UnliftIO (MonadIO, liftIO, MonadUnliftIO, withRunInIO)
import qualified Network.HTTP.Types as H
import qualified Network.Wai as W
@ -228,40 +233,41 @@ import Data.Monoid (Endo (..))
import Data.Text (Text)
import qualified Network.Wai.Parse as NWP
import Text.Shakespeare.I18N (RenderMessage (..))
import Web.Cookie (SetCookie (..))
import Web.Cookie (SetCookie (..), defaultSetCookie)
import Yesod.Core.Content (ToTypedContent (..), simpleContentType, contentTypeTypes, HasContentType (..), ToContent (..), ToFlushBuilder (..))
import Yesod.Core.Internal.Util (formatRFC1123)
import Text.Blaze.Html (preEscapedToHtml, toHtml)
import qualified Data.IORef.Lifted as I
import qualified Data.IORef as I
import Data.Maybe (listToMaybe, mapMaybe)
import Data.Typeable (Typeable)
import Web.PathPieces (PathPiece(..))
import Yesod.Core.Class.Handler
import Yesod.Core.Types
import Yesod.Routes.Class (Route)
import Blaze.ByteString.Builder (Builder)
import Data.ByteString.Builder (Builder)
import Safe (headMay)
import Data.CaseInsensitive (CI, original)
import qualified Data.Conduit.List as CL
import Control.Monad.Trans.Resource (MonadResource, InternalState, runResourceT, withInternalState, getInternalState, liftResourceT, resourceForkIO)
import qualified System.PosixCompat.Files as PC
import Control.Monad.Trans.Control (control, MonadBaseControl)
import Data.Conduit (Source, transPipe, Flush (Flush), yield, Producer, Sink)
import Data.Conduit (ConduitT, transPipe, Flush (Flush), yield, Void)
import qualified Yesod.Core.TypeCache as Cache
import qualified Data.Word8 as W8
import qualified Data.Foldable as Fold
import Data.Default
import Control.Monad.Logger (MonadLogger, logWarnS)
type HandlerT site (m :: * -> *) = HandlerFor site
{-# DEPRECATED HandlerT "Use HandlerFor directly" #-}
get :: MonadHandler m => m GHState
get = liftHandlerT $ HandlerT $ I.readIORef . handlerState
get = liftHandler $ HandlerFor $ I.readIORef . handlerState
put :: MonadHandler m => GHState -> m ()
put x = liftHandlerT $ HandlerT $ flip I.writeIORef x . handlerState
put x = liftHandler $ HandlerFor $ flip I.writeIORef x . handlerState
modify :: MonadHandler m => (GHState -> GHState) -> m ()
modify f = liftHandlerT $ HandlerT $ flip I.modifyIORef f . handlerState
modify f = liftHandler $ HandlerFor $ flip I.modifyIORef f . handlerState
tell :: MonadHandler m => Endo [Header] -> m ()
tell hs = modify $ \g -> g { ghsHeaders = ghsHeaders g `mappend` hs }
@ -273,14 +279,14 @@ hcError :: MonadHandler m => ErrorResponse -> m a
hcError = handlerError . HCError
getRequest :: MonadHandler m => m YesodRequest
getRequest = liftHandlerT $ HandlerT $ return . handlerRequest
getRequest = liftHandler $ HandlerFor $ return . handlerRequest
runRequestBody :: MonadHandler m => m RequestBodyContents
runRequestBody = do
HandlerData
{ handlerEnv = RunHandlerEnv {..}
, handlerRequest = req
} <- liftHandlerT $ HandlerT return
} <- liftHandler $ HandlerFor return
let len = W.requestBodyLength $ reqWaiRequest req
upload = rheUpload len
x <- get
@ -319,8 +325,8 @@ rbHelper' backend mkFI req =
| otherwise = a'
go = decodeUtf8With lenientDecode
askHandlerEnv :: MonadHandler m => m (RunHandlerEnv (HandlerSite m))
askHandlerEnv = liftHandlerT $ HandlerT $ return . handlerEnv
askHandlerEnv :: MonadHandler m => m (RunHandlerEnv (HandlerSite m) (HandlerSite m))
askHandlerEnv = liftHandler $ HandlerFor $ return . handlerEnv
-- | Get the master site application argument.
getYesod :: MonadHandler m => m (HandlerSite m)
@ -396,9 +402,9 @@ getCurrentRoute = rheRoute <$> askHandlerEnv
-- This allows the inner 'GHandler' to outlive the outer
-- 'GHandler' (e.g., on the @forkIO@ example above, a response
-- may be sent to the client without killing the new thread).
handlerToIO :: (MonadIO m1, MonadIO m2) => HandlerT site m1 (HandlerT site IO a -> m2 a)
handlerToIO :: MonadIO m => HandlerFor site (HandlerFor site a -> m a)
handlerToIO =
HandlerT $ \oldHandlerData -> do
HandlerFor $ \oldHandlerData -> do
-- Take just the bits we need from oldHandlerData.
let newReq = oldReq { reqWaiRequest = newWaiReq }
where
@ -420,7 +426,7 @@ handlerToIO =
liftIO $ evaluate (newReq `seq` oldEnv `seq` newState `seq` ())
-- Return GHandler running function.
return $ \(HandlerT f) ->
return $ \(HandlerFor f) ->
liftIO $
runResourceT $ withInternalState $ \resState -> do
-- The state IORef needs to be created here, otherwise it
@ -431,7 +437,6 @@ handlerToIO =
{ handlerRequest = newReq
, handlerEnv = oldEnv
, handlerState = newStateIORef
, handlerToParent = const ()
, handlerResource = resState
}
liftIO (f newHandlerData)
@ -442,12 +447,13 @@ handlerToIO =
-- for correctness and efficiency
--
-- @since 1.2.8
forkHandler :: (SomeException -> HandlerT site IO ()) -- ^ error handler
-> HandlerT site IO ()
-> HandlerT site IO ()
forkHandler :: (SomeException -> HandlerFor site ()) -- ^ error handler
-> HandlerFor site ()
-> HandlerFor site ()
forkHandler onErr handler = do
yesRunner <- handlerToIO
void $ liftResourceT $ resourceForkIO $ yesRunner $ handle onErr handler
void $ liftResourceT $ resourceForkIO $
liftIO $ handle (yesRunner . onErr) (yesRunner handler)
-- | Redirect to the given route.
-- HTTP status code 303 for HTTP 1.1 clients and 302 for HTTP 1.0
@ -635,11 +641,7 @@ sendResponseStatus s = handlerError . HCContent s . toTypedContent
--
-- @since 1.4.18
sendStatusJSON :: (MonadHandler m, ToJSON c) => H.Status -> c -> m a
#if MIN_VERSION_aeson(0, 11, 0)
sendStatusJSON s v = sendResponseStatus s (toEncoding v)
#else
sendStatusJSON s v = sendResponseStatus s (toJSON v)
#endif
-- | Send a 201 "Created" response with the given route as the Location
-- response header.
@ -668,10 +670,10 @@ sendWaiApplication = handlerError . HCWaiApp
--
-- @since 1.2.16
sendRawResponseNoConduit
:: (MonadHandler m, MonadBaseControl IO m)
:: (MonadHandler m, MonadUnliftIO m)
=> (IO S8.ByteString -> (S8.ByteString -> IO ()) -> m ())
-> m a
sendRawResponseNoConduit raw = control $ \runInIO ->
sendRawResponseNoConduit raw = withRunInIO $ \runInIO ->
liftIO $ throwIO $ HCWai $ flip W.responseRaw fallback
$ \src sink -> void $ runInIO (raw src sink)
where
@ -683,10 +685,11 @@ sendRawResponseNoConduit raw = control $ \runInIO ->
-- Warp).
--
-- @since 1.2.7
sendRawResponse :: (MonadHandler m, MonadBaseControl IO m)
=> (Source IO S8.ByteString -> Sink S8.ByteString IO () -> m ())
-> m a
sendRawResponse raw = control $ \runInIO ->
sendRawResponse
:: (MonadHandler m, MonadUnliftIO m)
=> (ConduitT () S8.ByteString IO () -> ConduitT S8.ByteString Void IO () -> m ())
-> m a
sendRawResponse raw = withRunInIO $ \runInIO ->
liftIO $ throwIO $ HCWai $ flip W.responseRaw fallback
$ \src sink -> void $ runInIO $ raw (src' src) (CL.mapM_ sink)
where
@ -783,7 +786,7 @@ setLanguage = setSession langKey
--
-- @since 1.2.0
addHeader :: MonadHandler m => Text -> Text -> m ()
addHeader a = addHeaderInternal . Header (encodeUtf8 a) . encodeUtf8
addHeader a = addHeaderInternal . Header (CI.mk $ encodeUtf8 a) . encodeUtf8
-- | Deprecated synonym for addHeader.
setHeader :: MonadHandler m => Text -> Text -> m ()
@ -801,10 +804,10 @@ replaceOrAddHeader :: MonadHandler m => Text -> Text -> m ()
replaceOrAddHeader a b =
modify $ \g -> g {ghsHeaders = replaceHeader (ghsHeaders g)}
where
repHeader = Header (encodeUtf8 a) (encodeUtf8 b)
repHeader = Header (CI.mk $ encodeUtf8 a) (encodeUtf8 b)
sameHeaderName :: Header -> Header -> Bool
sameHeaderName (Header n1 _) (Header n2 _) = T.toLower (decodeUtf8 n1) == T.toLower (decodeUtf8 n2)
sameHeaderName (Header n1 _) (Header n2 _) = n1 == n2
sameHeaderName _ _ = False
replaceIndividualHeader :: [Header] -> [Header]
@ -1341,7 +1344,7 @@ provideRepType ct handler =
-- | Stream in the raw request body without any parsing.
--
-- @since 1.2.0
rawRequestBody :: MonadHandler m => Source m S.ByteString
rawRequestBody :: MonadHandler m => ConduitT i S.ByteString m ()
rawRequestBody = do
req <- lift waiRequest
let loop = do
@ -1353,7 +1356,7 @@ rawRequestBody = do
-- | Stream the data from the file. Since Yesod 1.2, this has been generalized
-- to work in any @MonadResource@.
fileSource :: MonadResource m => FileInfo -> Source m S.ByteString
fileSource :: MonadResource m => FileInfo -> ConduitT () S.ByteString m ()
fileSource = transPipe liftResourceT . fileSourceRaw
-- | Provide a pure value for the response body.
@ -1374,78 +1377,59 @@ respond ct = return . TypedContent ct . toContent
--
-- @since 1.2.0
respondSource :: ContentType
-> Source (HandlerT site IO) (Flush Builder)
-> HandlerT site IO TypedContent
respondSource ctype src = HandlerT $ \hd ->
-> ConduitT () (Flush Builder) (HandlerFor site) ()
-> HandlerFor site TypedContent
respondSource ctype src = HandlerFor $ \hd ->
-- Note that this implementation relies on the fact that the ResourceT
-- environment provided by the server is the same one used in HandlerT.
-- This is a safe assumption assuming the HandlerT is run correctly.
return $ TypedContent ctype $ ContentSource
$ transPipe (lift . flip unHandlerT hd) src
$ transPipe (lift . flip unHandlerFor hd) src
-- | In a streaming response, send a single chunk of data. This function works
-- on most datatypes, such as @ByteString@ and @Html@.
--
-- @since 1.2.0
sendChunk :: Monad m => ToFlushBuilder a => a -> Producer m (Flush Builder)
sendChunk :: Monad m => ToFlushBuilder a => a -> ConduitT i (Flush Builder) m ()
sendChunk = yield . toFlushBuilder
-- | In a streaming response, send a flush command, causing all buffered data
-- to be immediately sent to the client.
--
-- @since 1.2.0
sendFlush :: Monad m => Producer m (Flush Builder)
sendFlush :: Monad m => ConduitT i (Flush Builder) m ()
sendFlush = yield Flush
-- | Type-specialized version of 'sendChunk' for strict @ByteString@s.
--
-- @since 1.2.0
sendChunkBS :: Monad m => S.ByteString -> Producer m (Flush Builder)
sendChunkBS :: Monad m => S.ByteString -> ConduitT i (Flush Builder) m ()
sendChunkBS = sendChunk
-- | Type-specialized version of 'sendChunk' for lazy @ByteString@s.
--
-- @since 1.2.0
sendChunkLBS :: Monad m => L.ByteString -> Producer m (Flush Builder)
sendChunkLBS :: Monad m => L.ByteString -> ConduitT i (Flush Builder) m ()
sendChunkLBS = sendChunk
-- | Type-specialized version of 'sendChunk' for strict @Text@s.
--
-- @since 1.2.0
sendChunkText :: Monad m => T.Text -> Producer m (Flush Builder)
sendChunkText :: Monad m => T.Text -> ConduitT i (Flush Builder) m ()
sendChunkText = sendChunk
-- | Type-specialized version of 'sendChunk' for lazy @Text@s.
--
-- @since 1.2.0
sendChunkLazyText :: Monad m => TL.Text -> Producer m (Flush Builder)
sendChunkLazyText :: Monad m => TL.Text -> ConduitT i (Flush Builder) m ()
sendChunkLazyText = sendChunk
-- | Type-specialized version of 'sendChunk' for @Html@s.
--
-- @since 1.2.0
sendChunkHtml :: Monad m => Html -> Producer m (Flush Builder)
sendChunkHtml :: Monad m => Html -> ConduitT i (Flush Builder) m ()
sendChunkHtml = sendChunk
-- | Converts a child handler to a parent handler
--
-- Exported since 1.4.11
stripHandlerT :: HandlerT child (HandlerT parent m) a
-> (parent -> child)
-> (Route child -> Route parent)
-> Maybe (Route child)
-> HandlerT parent m a
stripHandlerT (HandlerT f) getSub toMaster newRoute = HandlerT $ \hd -> do
let env = handlerEnv hd
($ hd) $ unHandlerT $ f hd
{ handlerEnv = env
{ rheSite = getSub $ rheSite env
, rheRoute = newRoute
, rheRender = \url params -> rheRender env (toMaster url) params
}
, handlerToParent = toMaster
}
-- $ajaxCSRFOverview
-- When a user has authenticated with your site, all requests made from the browser to your server will include the session information that you use to verify that the user is logged in.
-- Unfortunately, this allows attackers to make unwanted requests on behalf of the user by e.g. submitting an HTTP request to your site when the user visits theirs.
@ -1494,7 +1478,10 @@ defaultCsrfCookieName = "XSRF-TOKEN"
--
-- @since 1.4.14
setCsrfCookie :: MonadHandler m => m ()
setCsrfCookie = setCsrfCookieWithCookie def { setCookieName = defaultCsrfCookieName, setCookiePath = Just "/" }
setCsrfCookie = setCsrfCookieWithCookie defaultSetCookie
{ setCookieName = defaultCsrfCookieName
, setCookiePath = Just "/"
}
-- | Takes a 'SetCookie' and overrides its value with a CSRF token, then sets the cookie.
--
@ -1610,3 +1597,12 @@ csrfErrorMessage expectedLocations = T.intercalate "\n"
formatValue maybeText = case maybeText of
Nothing -> "(which is not currently set)"
Just t -> T.concat ["(which has the current, incorrect value: '", t, "')"]
getSubYesod :: MonadHandler m => m (SubHandlerSite m)
getSubYesod = liftSubHandler $ SubHandlerFor $ return . rheChild . handlerEnv
getRouteToParent :: MonadHandler m => m (Route (SubHandlerSite m) -> Route (HandlerSite m))
getRouteToParent = liftSubHandler $ SubHandlerFor $ return . rheRouteToMaster . handlerEnv
getSubCurrentRoute :: MonadHandler m => m (Maybe (Route (SubHandlerSite m)))
getSubCurrentRoute = liftSubHandler $ SubHandlerFor $ return . rheRoute . handlerEnv

4
yesod-core/Yesod/Core/Internal/LiteApp.hs
View File

@ -46,8 +46,8 @@ instance Monoid LiteApp where
mempty = LiteApp $ \_ _ -> Nothing
mappend (LiteApp x) (LiteApp y) = LiteApp $ \m ps -> x m ps <|> y m ps
type LiteHandler = HandlerT LiteApp IO
type LiteWidget = WidgetT LiteApp IO
type LiteHandler = HandlerFor LiteApp
type LiteWidget = WidgetFor LiteApp
liteApp :: Writer LiteApp () -> LiteApp
liteApp = execWriter

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

@ -34,18 +34,13 @@ import qualified Data.Set as Set
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8With, decodeUtf8)
import Data.Text.Encoding.Error (lenientDecode)
import Data.Conduit
import Data.Conduit.List (sourceList)
import Data.Conduit.Binary (sourceFile, sinkFile)
import Conduit
import Data.Word (Word8, Word64)
import Control.Monad.Trans.Resource (runResourceT, ResourceT)
import Control.Exception (throwIO)
import Control.Monad ((<=<), liftM)
import Yesod.Core.Types
import qualified Data.Map as Map
import Data.IORef
import qualified System.Random.MWC as MWC
import Control.Monad.Primitive (PrimMonad, PrimState)
import qualified Data.Vector.Storable as V
import Data.ByteString.Internal (ByteString (PS))
import qualified Data.Word8 as Word8
@ -83,7 +78,7 @@ parseWaiRequest :: W.Request
-> SessionMap
-> Bool
-> Maybe Word64 -- ^ max body size
-> Either (IO YesodRequest) (MWC.GenIO -> IO YesodRequest)
-> Either (IO YesodRequest) (IO Int -> 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
@ -163,16 +158,21 @@ addTwoLetters (toAdd, exist) (l:ls) =
-- | Generate a random String of alphanumerical characters
-- (a-z, A-Z, and 0-9) of the given length using the given
-- random number generator.
randomString :: PrimMonad m => Int -> MWC.Gen (PrimState m) -> m Text
randomString :: Monad m => Int -> m Int -> m Text
randomString len gen =
liftM (decodeUtf8 . fromByteVector) $ V.replicateM len asciiChar
where
asciiChar = liftM toAscii $ MWC.uniformR (0, 61) gen
toAscii i
| i < 26 = i + Word8._A
| i < 52 = i + Word8._a - 26
| otherwise = i + Word8._0 - 52
asciiChar =
let loop = do
x <- gen
let y = fromIntegral $ x `mod` 64
case () of
()
| y < 26 -> return $ y + Word8._A
| y < 52 -> return $ y + Word8._a - 26
| y < 62 -> return $ y + Word8._0 - 52
| otherwise -> loop
in loop
fromByteVector :: V.Vector Word8 -> ByteString
fromByteVector v =
@ -183,13 +183,13 @@ fromByteVector v =
mkFileInfoLBS :: Text -> Text -> L.ByteString -> FileInfo
mkFileInfoLBS name ct lbs =
FileInfo name ct (sourceList $ L.toChunks lbs) (`L.writeFile` lbs)
FileInfo name ct (sourceLazy lbs) (`L.writeFile` lbs)
mkFileInfoFile :: Text -> Text -> FilePath -> FileInfo
mkFileInfoFile name ct fp = FileInfo name ct (sourceFile fp) (\dst -> runResourceT $ sourceFile fp $$ sinkFile dst)
mkFileInfoFile name ct fp = FileInfo name ct (sourceFile fp) (\dst -> runConduitRes $ sourceFile fp .| sinkFile dst)
mkFileInfoSource :: Text -> Text -> Source (ResourceT IO) ByteString -> FileInfo
mkFileInfoSource name ct src = FileInfo name ct src (\dst -> runResourceT $ src $$ sinkFile dst)
mkFileInfoSource :: Text -> Text -> ConduitT () ByteString (ResourceT IO) () -> FileInfo
mkFileInfoSource name ct src = FileInfo name ct src (\dst -> runConduitRes $ src .| sinkFile dst)
tokenKey :: IsString a => a
tokenKey = "_TOKEN"

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

@ -6,29 +6,24 @@ module Yesod.Core.Internal.Response where
import Data.ByteString (ByteString)
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as BL
import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI
import Network.Wai
import Control.Monad (mplus)
import Control.Monad.Trans.Resource (runInternalState, InternalState)
import Network.Wai.Internal
#if !MIN_VERSION_base(4, 6, 0)
import Prelude hiding (catch)
#endif
import Web.Cookie (renderSetCookie)
import Yesod.Core.Content
import Yesod.Core.Types
import qualified Network.HTTP.Types as H
import qualified Data.Text as T
import Control.Exception (SomeException, handle)
import Blaze.ByteString.Builder (fromLazyByteString,
toLazyByteString, toByteString)
import Data.ByteString.Builder (lazyByteString, toLazyByteString)
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 (..), ($$), transPipe)
import qualified Data.Conduit.List as CL
import Conduit
yarToResponse :: YesodResponse
-> (SessionMap -> IO [Header]) -- ^ save session
@ -56,9 +51,9 @@ yarToResponse (YRPlain s' hs ct c newSess) saveSession yreq _req is sendResponse
sendResponse $ ResponseBuilder s hs' b
go (ContentFile fp p) = sendResponse $ ResponseFile s finalHeaders fp p
go (ContentSource body) = sendResponse $ responseStream s finalHeaders
$ \sendChunk flush ->
$ \sendChunk flush -> runConduit $
transPipe (`runInternalState` is) body
$$ CL.mapM_ (\mchunk ->
.| mapM_C (\mchunk ->
case mchunk of
Flush -> flush
Chunk builder -> sendChunk builder)
@ -86,7 +81,7 @@ defaultStatus = H.mkStatus (-1) "INVALID DEFAULT STATUS"
headerToPair :: Header
-> (CI ByteString, ByteString)
headerToPair (AddCookie sc) =
("Set-Cookie", toByteString $ renderSetCookie sc)
("Set-Cookie", BL.toStrict $ toLazyByteString $ renderSetCookie sc)
headerToPair (DeleteCookie key path) =
( "Set-Cookie"
, S.concat
@ -96,14 +91,14 @@ headerToPair (DeleteCookie key path) =
, "; expires=Thu, 01-Jan-1970 00:00:00 GMT"
]
)
headerToPair (Header key value) = (CI.mk key, value)
headerToPair (Header key value) = (key, value)
evaluateContent :: Content -> IO (Either ErrorResponse Content)
evaluateContent (ContentBuilder b mlen) = handle f $ do
let lbs = toLazyByteString b
len = L.length lbs
mlen' = mlen `mplus` Just (fromIntegral len)
len `seq` return (Right $ ContentBuilder (fromLazyByteString lbs) mlen')
len `seq` return (Right $ ContentBuilder (lazyByteString lbs) mlen')
where
f :: SomeException -> IO (Either ErrorResponse Content)
f = return . Left . InternalError . T.pack . show

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

@ -14,9 +14,8 @@ import Data.Monoid (Monoid, mempty)
import Control.Applicative ((<$>))
#endif
import Yesod.Core.Internal.Response
import Blaze.ByteString.Builder (toByteString)
import Control.Exception (fromException, evaluate)
import qualified Control.Exception as E
import Data.ByteString.Builder (toLazyByteString)
import qualified Data.ByteString.Lazy as BL
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Logger (LogLevel (LevelError), LogSource,
liftLoc)
@ -44,46 +43,29 @@ import Yesod.Core.Internal.Request (parseWaiRequest,
import Yesod.Core.Internal.Util (getCurrentMaxExpiresRFC1123)
import Yesod.Routes.Class (Route, renderRoute)
import Control.DeepSeq (($!!), NFData)
import UnliftIO.Exception
-- | Catch all synchronous exceptions, ignoring asynchronous
-- exceptions.
--
-- Ideally we'd use this from a different library
catchSync :: IO a -> (E.SomeException -> IO a) -> IO a
catchSync thing after = thing `E.catch` \e ->
if isAsyncException e
then E.throwIO e
else after e
-- | Determine if an exception is asynchronous
--
-- Also worth being upstream
isAsyncException :: E.SomeException -> Bool
isAsyncException e =
case fromException e of
Just E.SomeAsyncException{} -> True
Nothing -> False
-- | Convert an exception into an ErrorResponse
toErrorHandler :: E.SomeException -> IO ErrorResponse
toErrorHandler e0 = flip catchSync errFromShow $
-- | Convert a synchronous exception into an ErrorResponse
toErrorHandler :: SomeException -> IO ErrorResponse
toErrorHandler e0 = handleAny errFromShow $
case fromException e0 of
Just (HCError x) -> evaluate $!! x
_
| isAsyncException e0 -> E.throwIO e0
| otherwise -> errFromShow e0
_ -> errFromShow e0
-- | Generate an @ErrorResponse@ based on the shown version of the exception
errFromShow :: E.SomeException -> IO ErrorResponse
errFromShow x = evaluate $!! InternalError $! T.pack $! show x
errFromShow :: SomeException -> IO ErrorResponse
errFromShow x = do
text <- evaluate (T.pack $ show x) `catchAny` \_ ->
return (T.pack "Yesod.Core.Internal.Run.errFromShow: show of an exception threw an exception")
return $ InternalError text
-- | Do a basic run of a handler, getting some contents and the final
-- @GHState@. The @GHState@ unfortunately may contain some impure
-- exceptions, but all other synchronous exceptions will be caught and
-- represented by the @HandlerContents@.
basicRunHandler :: ToTypedContent c
=> RunHandlerEnv site
-> HandlerT site IO c
=> RunHandlerEnv site site
-> HandlerFor site c
-> YesodRequest
-> InternalState
-> IO (GHState, HandlerContents)
@ -94,9 +76,9 @@ basicRunHandler rhe handler yreq resState = do
-- Run the handler itself, capturing any runtime exceptions and
-- converting them into a @HandlerContents@
contents' <- catchSync
contents' <- catchAny
(do
res <- unHandlerT handler (hd istate)
res <- unHandlerFor handler (hd istate)
tc <- evaluate (toTypedContent res)
-- Success! Wrap it up in an @HCContent@
return (HCContent defaultStatus tc))
@ -121,12 +103,11 @@ basicRunHandler rhe handler yreq resState = do
{ handlerRequest = yreq
, handlerEnv = rhe
, handlerState = istate
, handlerToParent = const ()
, handlerResource = resState
}
-- | Convert an @ErrorResponse@ into a @YesodResponse@
handleError :: RunHandlerEnv site
handleError :: RunHandlerEnv sub site
-> YesodRequest
-> InternalState
-> Map.Map Text S8.ByteString
@ -135,7 +116,7 @@ handleError :: RunHandlerEnv site
-> IO YesodResponse
handleError rhe yreq resState finalSession headers e0 = do
-- Find any evil hidden impure exceptions
e <- (evaluate $!! e0) `catchSync` errFromShow
e <- (evaluate $!! e0) `catchAny` errFromShow
-- Generate a response, leveraging the updated session and
-- response headers
@ -200,15 +181,15 @@ evalFallback :: (Monoid w, NFData w)
=> HandlerContents
-> w
-> IO (w, HandlerContents)
evalFallback contents val = catchSync
evalFallback contents val = catchAny
(fmap (, contents) (evaluate $!! val))
(fmap ((mempty, ) . HCError) . toErrorHandler)
-- | Function used internally by Yesod in the process of converting a
-- 'HandlerT' into an 'Application'. Should not be needed by users.
runHandler :: ToTypedContent c
=> RunHandlerEnv site
-> HandlerT site IO c
=> RunHandlerEnv site site
-> HandlerFor site c
-> YesodApp
runHandler rhe@RunHandlerEnv {..} handler yreq = withInternalState $ \resState -> do
-- Get the raw state and original contents
@ -218,13 +199,14 @@ runHandler rhe@RunHandlerEnv {..} handler yreq = withInternalState $ \resState -
-- propagating exceptions into the contents
(finalSession, contents1) <- evalFallback contents0 (ghsSession state)
(headers, contents2) <- evalFallback contents1 (appEndo (ghsHeaders state) [])
contents3 <- (evaluate contents2) `catchAny` (fmap HCError . toErrorHandler)
-- Convert the HandlerContents into the final YesodResponse
handleContents
(handleError rhe yreq resState finalSession headers)
finalSession
headers
contents2
contents3
safeEh :: (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
-> ErrorResponse
@ -263,7 +245,7 @@ runFakeHandler :: (Yesod site, MonadIO m) =>
SessionMap
-> (site -> Logger)
-> site
-> HandlerT site IO a
-> HandlerFor site a
-> m (Either ErrorResponse a)
runFakeHandler fakeSessionMap logger site handler = liftIO $ do
ret <- I.newIORef (Left $ InternalError "runFakeHandler: no result")
@ -273,6 +255,8 @@ runFakeHandler fakeSessionMap logger site handler = liftIO $ do
RunHandlerEnv
{ rheRender = yesodRender site $ resolveApproot site fakeWaiRequest
, rheRoute = Nothing
, rheRouteToMaster = id
, rheChild = site
, rheSite = site
, rheUpload = fileUpload site
, rheLog = messageLoggerSource site $ logger site
@ -322,7 +306,7 @@ runFakeHandler fakeSessionMap logger site handler = liftIO $ do
I.readIORef ret
yesodRunner :: (ToTypedContent res, Yesod site)
=> HandlerT site IO res
=> HandlerFor site res
-> YesodRunnerEnv site
-> Maybe (Route site)
-> Application
@ -347,6 +331,8 @@ yesodRunner handler' YesodRunnerEnv {..} route req sendResponse
rheSafe = RunHandlerEnv
{ rheRender = yesodRender yreSite ra
, rheRoute = route
, rheRouteToMaster = id
, rheChild = yreSite
, rheSite = yreSite
, rheUpload = fileUpload yreSite
, rheLog = log'
@ -372,7 +358,7 @@ yesodRender :: Yesod y
-> [(Text, Text)] -- ^ url query string
-> Text
yesodRender y ar url params =
decodeUtf8With lenientDecode $ toByteString $
decodeUtf8With lenientDecode $ BL.toStrict $ toLazyByteString $
fromMaybe
(joinPath y ar ps
$ params ++ params')

99
yesod-core/Yesod/Core/Internal/TH.hs
View File

@ -16,56 +16,63 @@ import Language.Haskell.TH.Syntax
import qualified Network.Wai as W
import Data.ByteString.Lazy.Char8 ()
#if MIN_VERSION_base(4,8,0)
import Data.List (foldl', uncons)
#else
import Data.List (foldl')
#endif
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative ((<$>))
#endif
import Control.Monad (replicateM, void)
import Data.Either (partitionEithers)
import Text.Parsec (parse, many1, many, eof, try, option, sepBy1)
import Text.ParserCombinators.Parsec.Char (alphaNum, spaces, string, char)
import Yesod.Routes.TH
import Yesod.Routes.Parse
import Yesod.Core.Types
import Yesod.Core.Content
import Yesod.Core.Class.Dispatch
import Yesod.Core.Internal.Run
-- | Generates URL datatype and site function for the given 'Resource's. This
-- is used for creating sites, /not/ subsites. See 'mkYesodSub' for the latter.
-- is used for creating sites, /not/ subsites. See 'mkYesodSubData' and 'mkYesodSubDispatch' for the latter.
-- Use 'parseRoutes' to create the 'Resource's.
--
-- Contexts and type variables in the name of the datatype are parsed.
-- For example, a datatype @App a@ with typeclass constraint @MyClass a@ can be written as @\"(MyClass a) => App a\"@.
mkYesod :: String -- ^ name of the argument datatype
-> [ResourceTree String]
-> Q [Dec]
mkYesod name = fmap (uncurry (++)) . mkYesodGeneral name [] False return
mkYesod name = fmap (uncurry (++)) . mkYesodWithParser name False return
mkYesodWith :: String
-> [Either String [String]]
{-# DEPRECATED mkYesodWith "Contexts and type variables are now parsed from the name in `mkYesod`. <https://github.com/yesodweb/yesod/pull/1366>" #-}
-- | Similar to 'mkYesod', except contexts and type variables are not parsed.
-- Instead, they are explicitly provided.
-- You can write @(MyClass a) => App a@ with @mkYesodWith [[\"MyClass\",\"a\"]] \"App\" [\"a\"] ...@.
mkYesodWith :: [[String]] -- ^ list of contexts
-> String -- ^ name of the argument datatype
-> [String] -- ^ list of type variables
-> [ResourceTree String]
-> Q [Dec]
mkYesodWith name args = fmap (uncurry (++)) . mkYesodGeneral name args False return
mkYesodWith cxts name args = fmap (uncurry (++)) . mkYesodGeneral cxts name args False return
-- | Sometimes, you will want to declare your routes in one file and define
-- your handlers elsewhere. For example, this is the only way to break up a
-- monolithic file into smaller parts. Use this function, paired with
-- 'mkYesodDispatch', to do just that.
mkYesodData :: String -> [ResourceTree String] -> Q [Dec]
mkYesodData name = mkYesodDataGeneral name False
mkYesodData name resS = fst <$> mkYesodWithParser name False return resS
mkYesodSubData :: String -> [ResourceTree String] -> Q [Dec]
mkYesodSubData name = mkYesodDataGeneral name True
mkYesodSubData name resS = fst <$> mkYesodWithParser name True return resS
mkYesodDataGeneral :: String -> Bool -> [ResourceTree String] -> Q [Dec]
mkYesodDataGeneral name isSub res = do
-- | Parses contexts and type arguments out of name before generating TH.
mkYesodWithParser :: String -- ^ foundation type
-> Bool -- ^ is this a subsite
-> (Exp -> Q Exp) -- ^ unwrap handler
-> [ResourceTree String]
-> Q([Dec],[Dec])
mkYesodWithParser name isSub f resS = do
let (name', rest, cxt) = case parse parseName "" name of
Left err -> error $ show err
Right a -> a
fst <$> mkYesodGeneral' cxt name' (fmap Left rest) isSub return res
mkYesodGeneral cxt name' rest isSub f resS
where
parseName = do
@ -99,36 +106,25 @@ mkYesodDataGeneral name isSub res = do
-- | See 'mkYesodData'.
mkYesodDispatch :: String -> [ResourceTree String] -> Q [Dec]
mkYesodDispatch name = fmap snd . mkYesodGeneral name [] False return
mkYesodDispatch name = fmap snd . mkYesodWithParser name False return
-- | Get the Handler and Widget type synonyms for the given site.
masterTypeSyns :: [Name] -> Type -> [Dec]
masterTypeSyns :: [Name] -> Type -> [Dec] -- FIXME remove from here, put into the scaffolding itself?
masterTypeSyns vs site =
[ TySynD (mkName "Handler") (fmap PlainTV vs)
$ ConT ''HandlerT `AppT` site `AppT` ConT ''IO
$ ConT ''HandlerFor `AppT` site
, TySynD (mkName "Widget") (fmap PlainTV vs)
$ ConT ''WidgetT `AppT` site `AppT` ConT ''IO `AppT` ConT ''()
$ ConT ''WidgetFor `AppT` site `AppT` ConT ''()
]
-- | 'Left' arguments indicate a monomorphic type, a 'Right' argument
-- indicates a polymorphic type, and provides the list of classes
-- the type must be instance of.
mkYesodGeneral :: String -- ^ foundation type
-> [Either String [String]] -- ^ arguments for the type
-> Bool -- ^ is this a subsite
-> (Exp -> Q Exp) -- ^ unwrap handler
-> [ResourceTree String]
-> Q([Dec],[Dec])
mkYesodGeneral = mkYesodGeneral' []
mkYesodGeneral' :: [[String]] -- ^ Appliction context. Used in RenderRoute, RouteAttrs, and ParseRoute instances.
mkYesodGeneral :: [[String]] -- ^ Appliction context. Used in RenderRoute, RouteAttrs, and ParseRoute instances.
-> String -- ^ foundation type
-> [Either String [String]] -- ^ arguments for the type
-> [String] -- ^ arguments for the type
-> Bool -- ^ is this a subsite
-> (Exp -> Q Exp) -- ^ unwrap handler
-> [ResourceTree String]
-> Q([Dec],[Dec])
mkYesodGeneral' appCxt' namestr args isSub f resS = do
mkYesodGeneral appCxt' namestr mtys isSub f resS = do
let appCxt = fmap (\(c:rest) ->
#if MIN_VERSION_template_haskell(2,10,0)
foldl' (\acc v -> acc `AppT` nameToType v) (ConT $ mkName c) rest
@ -151,36 +147,21 @@ mkYesodGeneral' appCxt' namestr args isSub f resS = do
DataD _ _ vs _ _ -> length vs
NewtypeD _ _ vs _ _ -> length vs
#endif
TySynD _ vs _ -> length vs
_ -> 0
_ -> 0
_ -> return 0
let name = mkName namestr
(mtys,_) = partitionEithers args
-- Generate as many variable names as the arity indicates
vns <- replicateM (arity - length mtys) $ newName "t"
-- Base type (site type with variables)
let (argtypes,cxt) = (\(ns,r,cs) -> (ns ++ fmap VarT r, cs)) $
foldr (\arg (xs,vns',cs) ->
case arg of
Left t ->
( nameToType t:xs, vns', cs )
Right ts ->
let (n, ns) = maybe (error "mkYesodGeneral: Should be unreachable.") id $ uncons vns' in
( VarT n : xs, ns
, fmap (\t ->
#if MIN_VERSION_template_haskell(2,10,0)
AppT (ConT $ mkName t) (VarT n)
#else
ClassP (mkName t) [VarT n]
#endif
) ts ++ cs )
) ([],vns,[]) args
let argtypes = fmap nameToType mtys ++ fmap VarT vns
site = foldl' AppT (ConT name) argtypes
res = map (fmap (parseType . dropBracket)) resS
renderRouteDec <- mkRenderRouteInstance' appCxt site res
routeAttrsDec <- mkRouteAttrsInstance' appCxt site res
dispatchDec <- mkDispatchInstance site cxt f res
parseRoute <- mkParseRouteInstance' appCxt site res
renderRouteDec <- mkRenderRouteInstance appCxt site res
routeAttrsDec <- mkRouteAttrsInstance appCxt site res
dispatchDec <- mkDispatchInstance site appCxt f res
parseRoute <- mkParseRouteInstance appCxt site res
let rname = mkName $ "resources" ++ namestr
eres <- lift resS
let resourcesDec =
@ -196,12 +177,6 @@ mkYesodGeneral' appCxt' namestr args isSub f resS = do
]
return (dataDec, dispatchDec)
#if !MIN_VERSION_base(4,8,0)
where
uncons (h:t) = Just (h,t)
uncons _ = Nothing
#endif
mkMDS :: (Exp -> Q Exp) -> Q Exp -> MkDispatchSettings a site b
mkMDS f rh = MkDispatchSettings
{ mdsRunHandler = rh
@ -242,7 +217,7 @@ mkDispatchInstance master cxt f res = do
mkYesodSubDispatch :: [ResourceTree a] -> Q Exp
mkYesodSubDispatch res = do
clause' <- mkDispatchClause (mkMDS return [|subHelper . fmap toTypedContent|]) res
clause' <- mkDispatchClause (mkMDS return [|subHelper|]) res
inner <- newName "inner"
let innerFun = FunD inner [clause']
helper <- newName "helper"

7
yesod-core/Yesod/Core/Internal/Util.hs
View File

@ -13,12 +13,7 @@ import Data.Serialize (Get, Put, Serialize (..))
import qualified Data.Text as T
import Data.Time (Day (ModifiedJulianDay, toModifiedJulianDay),
DiffTime, UTCTime (..), formatTime,
getCurrentTime, addUTCTime)
#if MIN_VERSION_time(1,5,0)
import Data.Time (defaultTimeLocale)
#else
import System.Locale (defaultTimeLocale)
#endif
getCurrentTime, addUTCTime, defaultTimeLocale)
putTime :: UTCTime -> Put
putTime (UTCTime d t) =

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

@ -6,9 +6,7 @@ module Yesod.Core.Json
defaultLayoutJson
, jsonToRepJson
, returnJson
#if MIN_VERSION_aeson(0, 11, 0)
, returnJsonEncoding
#endif
, provideJson
-- * Convert to a JSON value
@ -29,20 +27,18 @@ module Yesod.Core.Json
-- * Convenience functions
, jsonOrRedirect
#if MIN_VERSION_aeson(0, 11, 0)
, jsonEncodingOrRedirect
#endif
, acceptsJson
) where
import Yesod.Core.Handler (HandlerT, getRequest, invalidArgs, redirect, selectRep, provideRep, rawRequestBody, ProvidedRep, lookupHeader)
import Yesod.Core.Handler (HandlerFor, getRequest, invalidArgs, redirect, selectRep, provideRep, rawRequestBody, ProvidedRep, lookupHeader)
import Control.Monad.Trans.Writer (Writer)
import Data.Monoid (Endo)
import Yesod.Core.Content (TypedContent)
import Yesod.Core.Types (reqAccept)
import Yesod.Core.Class.Yesod (defaultLayout, Yesod)
import Yesod.Core.Class.Handler
import Yesod.Core.Widget (WidgetT)
import Yesod.Core.Widget (WidgetFor)
import Yesod.Routes.Class
import qualified Data.Aeson as J
import qualified Data.Aeson.Parser as JP
@ -62,16 +58,12 @@ import Control.Monad (liftM)
--
-- @since 0.3.0
defaultLayoutJson :: (Yesod site, J.ToJSON a)
=> WidgetT site IO () -- ^ HTML
-> HandlerT site IO a -- ^ JSON
-> HandlerT site IO TypedContent
=> WidgetFor site () -- ^ HTML
-> HandlerFor site a -- ^ JSON
-> HandlerFor site TypedContent
defaultLayoutJson w json = selectRep $ do
provideRep $ defaultLayout w
#if MIN_VERSION_aeson(0, 11, 0)
provideRep $ fmap J.toEncoding json
#else
provideRep $ fmap J.toJSON json
#endif
-- | Wraps a data type in a 'RepJson'. The data type must
-- support conversion to JSON via 'J.ToJSON'.
@ -87,24 +79,18 @@ jsonToRepJson = return . J.toJSON
returnJson :: (Monad m, J.ToJSON a) => a -> m J.Value
returnJson = return . J.toJSON
#if MIN_VERSION_aeson(0, 11, 0)
-- | Convert a value to a JSON representation via aeson\'s 'J.toEncoding' function.
--
-- @since 1.4.21
returnJsonEncoding :: (Monad m, J.ToJSON a) => a -> m J.Encoding
returnJsonEncoding = return . J.toEncoding
#endif
-- | Provide a JSON representation for usage with 'selectReps', using aeson\'s
-- 'J.toJSON' (aeson >= 0.11: 'J.toEncoding') function to perform the conversion.
--
-- @since 1.2.1
provideJson :: (Monad m, J.ToJSON a) => a -> Writer (Endo [ProvidedRep m]) ()
#if MIN_VERSION_aeson(0, 11, 0)
provideJson = provideRep . return . J.toEncoding
#else
provideJson = provideRep . return . J.toJSON
#endif
-- | Parse the request body to a data type as a JSON value. The
-- data type must support conversion from JSON via 'J.FromJSON'.
@ -118,7 +104,7 @@ provideJson = provideRep . return . J.toJSON
-- @since 0.3.0
parseJsonBody :: (MonadHandler m, J.FromJSON a) => m (J.Result a)
parseJsonBody = do
eValue <- rawRequestBody $$ runCatchC (sinkParser JP.value')
eValue <- runConduit $ rawRequestBody .| runCatchC (sinkParser JP.value')
return $ case eValue of
Left e -> J.Error $ show e
Right value -> J.fromJSON value
@ -173,7 +159,6 @@ jsonOrRedirect :: (MonadHandler m, J.ToJSON a)
-> m J.Value
jsonOrRedirect = jsonOrRedirect' J.toJSON
#if MIN_VERSION_aeson(0, 11, 0)
-- | jsonEncodingOrRedirect simplifies the scenario where a POST handler sends a different
-- response based on Accept headers:
--
@ -187,7 +172,6 @@ jsonEncodingOrRedirect :: (MonadHandler m, J.ToJSON a)
-> a -- ^ Data to send via JSON
-> m J.Encoding
jsonEncodingOrRedirect = jsonOrRedirect' J.toEncoding
#endif
jsonOrRedirect' :: MonadHandler m
=> (a -> b)

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

@ -1,4 +1,5 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TupleSections #-}
@ -9,8 +10,7 @@
{-# LANGUAGE UndecidableInstances #-}
module Yesod.Core.Types where
import qualified Blaze.ByteString.Builder as BBuilder
import qualified Blaze.ByteString.Builder.Char.Utf8
import qualified Data.ByteString.Builder as BB
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative (Applicative (..))
import Control.Applicative ((<$>))
@ -18,18 +18,16 @@ import Data.Monoid (Monoid (..))
#endif
import Control.Arrow (first)
import Control.Exception (Exception)
import Control.Monad (liftM, ap)
import Control.Monad.Base (MonadBase (liftBase))
import Control.Monad.Catch (MonadMask (..), MonadCatch (..))
import Control.Monad (ap)
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, MonadThrow (..), monadThrow, ResourceT)
import Control.Monad.Trans.Resource (MonadResource (..), InternalState, runInternalState, MonadThrow (..), ResourceT)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy as L
import Data.Conduit (Flush, Source)
import Data.IORef (IORef)
import Data.CaseInsensitive (CI)
import Data.Conduit (Flush, ConduitT)
import Data.IORef (IORef, modifyIORef')
import Data.Map (Map, unionWith)
import qualified Data.Map as Map
import Data.Monoid (Endo (..), Last (..))
@ -49,27 +47,21 @@ import Network.Wai (FilePart,
import qualified Network.Wai as W
import qualified Network.Wai.Parse as NWP
import System.Log.FastLogger (LogStr, LoggerSet, toLogStr, pushLogStr)
import qualified System.Random.MWC as MWC
import Network.Wai.Logger (DateCacheGetter)
import Text.Blaze.Html (Html, toHtml)
import Text.Hamlet (HtmlUrl)
import Text.Julius (JavascriptUrl)
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 (..))
#if !MIN_VERSION_base(4, 6, 0)
import Prelude hiding (catch)
#endif
import Data.Monoid ((<>))
import Control.DeepSeq (NFData (rnf))
import Control.DeepSeq.Generics (genericRnf)
import Data.Conduit.Lazy (MonadActive, monadActive)
import Yesod.Core.TypeCache (TypeMap, KeyedTypeMap)
#if MIN_VERSION_monad_logger(0, 3, 10)
import Control.Monad.Logger (MonadLoggerIO (..))
#endif
import Data.Semigroup (Semigroup)
import UnliftIO (MonadUnliftIO (..), UnliftIO (..))
-- Sessions
type SessionMap = Map Text ByteString
@ -82,7 +74,7 @@ newtype SessionBackend = SessionBackend
-> IO (SessionMap, SaveSession) -- ^ Return the session data and a function to save the session
}
data SessionCookie = SessionCookie (Either UTCTime ByteString) ByteString SessionMap
data SessionCookie = SessionCookie !(Either UTCTime ByteString) !ByteString !SessionMap
deriving (Show, Read)
instance Serialize SessionCookie where
put (SessionCookie a b c) = do
@ -140,13 +132,13 @@ type RequestBodyContents =
data FileInfo = FileInfo
{ fileName :: !Text
, fileContentType :: !Text
, fileSourceRaw :: !(Source (ResourceT IO) ByteString)
, fileSourceRaw :: !(ConduitT () ByteString (ResourceT IO) ())
, fileMove :: !(FilePath -> IO ())
}
data FileUpload = FileUploadMemory !(NWP.BackEnd L.ByteString)
| FileUploadDisk !(InternalState -> NWP.BackEnd FilePath)
| FileUploadSource !(NWP.BackEnd (Source (ResourceT IO) ByteString))
| FileUploadSource !(NWP.BackEnd (ConduitT () ByteString (ResourceT IO) ()))
-- | How to determine the root of the application for constructing URLs.
--
@ -160,13 +152,13 @@ data Approot master = ApprootRelative -- ^ No application root.
type ResolvedApproot = Text
data AuthResult = Authorized | AuthenticationRequired | Unauthorized Text
data AuthResult = Authorized | AuthenticationRequired | Unauthorized !Text
deriving (Eq, Show, Read)
data ScriptLoadPosition master
= BottomOfBody
| BottomOfHeadBlocking
| BottomOfHeadAsync (BottomOfHeadAsync master)
| BottomOfHeadAsync !(BottomOfHeadAsync master)
type BottomOfHeadAsync master
= [Text] -- ^ urls to load asynchronously
@ -179,14 +171,16 @@ type Texts = [Text]
newtype WaiSubsite = WaiSubsite { runWaiSubsite :: W.Application }
-- | Like 'WaiSubsite', but applies parent site's middleware and isAuthorized.
--
--
-- @since 1.4.34
newtype WaiSubsiteWithAuth = WaiSubsiteWithAuth { runWaiSubsiteWithAuth :: W.Application }
data RunHandlerEnv site = RunHandlerEnv
data RunHandlerEnv child site = RunHandlerEnv
{ rheRender :: !(Route site -> [(Text, Text)] -> Text)
, rheRoute :: !(Maybe (Route site))
, rheRoute :: !(Maybe (Route child))
, rheRouteToMaster :: !(Route child -> Route site)
, rheSite :: !site
, rheChild :: !child
, rheUpload :: !(RequestBodyLength -> FileUpload)
, rheLog :: !(Loc -> LogSource -> LogLevel -> LogStr -> IO ())
, rheOnError :: !(ErrorResponse -> YesodApp)
@ -196,11 +190,10 @@ data RunHandlerEnv site = RunHandlerEnv
, rheMaxExpires :: !Text
}
data HandlerData site parentRoute = HandlerData
data HandlerData child site = HandlerData
{ handlerRequest :: !YesodRequest
, handlerEnv :: !(RunHandlerEnv site)
, handlerEnv :: !(RunHandlerEnv child site)
, handlerState :: !(IORef GHState)
, handlerToParent :: !(Route site -> parentRoute)
, handlerResource :: !InternalState
}
@ -208,40 +201,38 @@ data YesodRunnerEnv site = YesodRunnerEnv
{ yreLogger :: !Logger
, yreSite :: !site
, yreSessionBackend :: !(Maybe SessionBackend)
, yreGen :: !MWC.GenIO
, yreGetMaxExpires :: IO Text
, yreGen :: !(IO Int)
-- ^ Generate a random number
, yreGetMaxExpires :: !(IO Text)
}
data YesodSubRunnerEnv sub parent parentMonad = YesodSubRunnerEnv
{ ysreParentRunner :: !(ParentRunner parent parentMonad)
data YesodSubRunnerEnv sub parent = YesodSubRunnerEnv
{ ysreParentRunner :: !(ParentRunner parent)
, ysreGetSub :: !(parent -> sub)
, ysreToParentRoute :: !(Route sub -> Route parent)
, ysreParentEnv :: !(YesodRunnerEnv parent) -- FIXME maybe get rid of this and remove YesodRunnerEnv in ParentRunner?
}
type ParentRunner parent m
= m TypedContent
type ParentRunner parent
= HandlerFor parent TypedContent
-> YesodRunnerEnv parent
-> Maybe (Route parent)
-> W.Application
-- | A generic handler monad, which can have a different subsite and master
-- site. We define a newtype for better error message.
newtype HandlerT site m a = HandlerT
{ unHandlerT :: HandlerData site (MonadRoute m) -> m a
newtype HandlerFor site a = HandlerFor
{ unHandlerFor :: HandlerData site site -> IO a
}
type family MonadRoute (m :: * -> *)
type instance MonadRoute IO = ()
type instance MonadRoute (HandlerT site m) = (Route site)
deriving Functor
data GHState = GHState
{ ghsSession :: SessionMap
, ghsRBC :: Maybe RequestBodyContents
, ghsIdent :: Int
, ghsCache :: TypeMap
, ghsCacheBy :: KeyedTypeMap
, ghsHeaders :: Endo [Header]
{ ghsSession :: !SessionMap
, ghsRBC :: !(Maybe RequestBodyContents)
, ghsIdent :: !Int
, ghsCache :: !TypeMap
, ghsCacheBy :: !KeyedTypeMap
, ghsHeaders :: !(Endo [Header])
}
-- | An extension of the basic WAI 'W.Application' datatype to provide extra
@ -252,24 +243,32 @@ type YesodApp = YesodRequest -> ResourceT IO YesodResponse
-- | A generic widget, allowing specification of both the subsite and master
-- site datatypes. While this is simply a @WriterT@, we define a newtype for
-- better error messages.
newtype WidgetT site m a = WidgetT
{ unWidgetT :: HandlerData site (MonadRoute m) -> m (a, GWData (Route site))
newtype WidgetFor site a = WidgetFor
{ unWidgetFor :: WidgetData site -> IO a
}
deriving Functor
instance (a ~ (), Monad m) => Monoid (WidgetT site m a) where
data WidgetData site = WidgetData
{ wdRef :: {-# UNPACK #-} !(IORef (GWData (Route site)))
, wdHandler :: {-# UNPACK #-} !(HandlerData site site)
}
instance a ~ () => Monoid (WidgetFor site a) where
mempty = return ()
mappend x y = x >> y
instance (a ~ (), Monad m) => Semigroup (WidgetT site m a)
instance a ~ () => Semigroup (WidgetFor site a)
-- | A 'String' can be trivially promoted to a widget.
--
-- For example, in a yesod-scaffold site you could use:
--
-- @getHomeR = do defaultLayout "Widget text"@
instance (Monad m, a ~ ()) => IsString (WidgetT site m a) where
instance a ~ () => IsString (WidgetFor site a) where
fromString = toWidget . toHtml . T.pack
where toWidget x = WidgetT $ const $ return ((), GWData (Body (const x))
mempty mempty mempty mempty mempty mempty)
where toWidget x = tellWidget mempty { gwdBody = Body (const x) }
tellWidget :: GWData (Route site) -> WidgetFor site ()
tellWidget d = WidgetFor $ \wd -> modifyIORef' (wdRef wd) (<> d)
type RY master = Route master -> [(Text, Text)] -> Text
@ -287,13 +286,13 @@ newtype CssBuilder = CssBuilder { unCssBuilder :: TBuilder.Builder }
--
-- > PageContent url -> HtmlUrl url
data PageContent url = PageContent
{ pageTitle :: Html
, pageHead :: HtmlUrl url
, pageBody :: HtmlUrl url
{ pageTitle :: !Html
, pageHead :: !(HtmlUrl url)
, pageBody :: !(HtmlUrl url)
}
data Content = ContentBuilder !BBuilder.Builder !(Maybe Int) -- ^ The content and optional content length.
| ContentSource !(Source (ResourceT IO) (Flush BBuilder.Builder))
data Content = ContentBuilder !BB.Builder !(Maybe Int) -- ^ The content and optional content length.
| ContentSource !(ConduitT () (Flush BB.Builder) (ResourceT IO) ())
| ContentFile !FilePath !(Maybe FilePart)
| ContentDontEvaluate !Content
@ -316,11 +315,11 @@ newtype DontFullyEvaluate a = DontFullyEvaluate { unDontFullyEvaluate :: a }
-- | Responses to indicate some form of an error occurred.
data ErrorResponse =
NotFound
| InternalError Text
| InvalidArgs [Text]
| InternalError !Text
| InvalidArgs ![Text]
| NotAuthenticated
| PermissionDenied Text
| BadMethod H.Method
| PermissionDenied !Text
| BadMethod !H.Method
deriving (Show, Eq, Typeable, Generic)
instance NFData ErrorResponse where
rnf = genericRnf
@ -328,9 +327,11 @@ instance NFData ErrorResponse where
----- header stuff
-- | Headers to be added to a 'Result'.
data Header =
AddCookie SetCookie
| DeleteCookie ByteString ByteString
| Header ByteString ByteString
AddCookie !SetCookie
| DeleteCookie !ByteString !ByteString
-- ^ name and path
| Header !(CI ByteString) !ByteString
-- ^ key and value
deriving (Eq, Show)
-- FIXME In the next major version bump, let's just add strictness annotations
@ -341,16 +342,16 @@ instance NFData Header where
rnf (DeleteCookie x y) = x `seq` y `seq` ()
rnf (Header x y) = x `seq` y `seq` ()
data Location url = Local url | Remote Text
data Location url = Local !url | Remote !Text
deriving (Show, Eq)
-- | A diff list that does not directly enforce uniqueness.
-- When creating a widget Yesod will use nub to make it unique.
newtype UniqueList x = UniqueList ([x] -> [x])
data Script url = Script { scriptLocation :: Location url, scriptAttributes :: [(Text, Text)] }
data Script url = Script { scriptLocation :: !(Location url), scriptAttributes :: ![(Text, Text)] }
deriving (Show, Eq)
data Stylesheet url = Stylesheet { styleLocation :: Location url, styleAttributes :: [(Text, Text)] }
data Stylesheet url = Stylesheet { styleLocation :: !(Location url), styleAttributes :: ![(Text, Text)] }
deriving (Show, Eq)
newtype Title = Title { unTitle :: Html }
@ -386,13 +387,13 @@ instance Monoid (GWData a) where
instance Semigroup (GWData a)
data HandlerContents =
HCContent H.Status !TypedContent
| HCError ErrorResponse
| HCSendFile ContentType FilePath (Maybe FilePart)
| HCRedirect H.Status Text
| HCCreated Text
| HCWai W.Response
| HCWaiApp W.Application
HCContent !H.Status !TypedContent
| HCError !ErrorResponse
| HCSendFile !ContentType !FilePath !(Maybe FilePart)
| HCRedirect !H.Status !Text
| HCCreated !Text
| HCWai !W.Response
| HCWaiApp !W.Application
deriving Typeable
instance Show HandlerContents where
@ -405,150 +406,70 @@ instance Show HandlerContents where
show (HCWaiApp _) = "HCWaiApp"
instance Exception HandlerContents
-- Instances for WidgetT
instance Monad m => Functor (WidgetT site m) where
fmap = liftM
instance Monad m => Applicative (WidgetT site m) where
pure = return
-- Instances for WidgetFor
instance Applicative (WidgetFor site) where
pure = WidgetFor . const . pure
(<*>) = ap
instance Monad m => Monad (WidgetT site m) where
return a = WidgetT $ const $ return (a, mempty)
WidgetT x >>= f = WidgetT $ \r -> do
(a, wa) <- x r
(b, wb) <- unWidgetT (f a) r
return (b, wa `mappend` wb)
instance MonadIO m => MonadIO (WidgetT site m) where
liftIO = lift . liftIO
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
#if MIN_VERSION_monad_control(1,0,0)
type StM (WidgetT site m) a = StM m (a, GWData (Route site))
liftBaseWith f = WidgetT $ \reader' ->
liftBaseWith $ \runInBase ->
fmap (\x -> (x, mempty))
(f $ runInBase . flip unWidgetT reader')
restoreM = WidgetT . const . restoreM
#else
data StM (WidgetT site m) a = StW (StM m (a, GWData (Route site)))
liftBaseWith f = WidgetT $ \reader' ->
liftBaseWith $ \runInBase ->
fmap (\x -> (x, mempty))
(f $ fmap StW . runInBase . flip unWidgetT reader')
restoreM (StW base) = WidgetT $ const $ restoreM base
#endif
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 Monad (WidgetFor site) where
return = pure
WidgetFor x >>= f = WidgetFor $ \wd -> do
a <- x wd
unWidgetFor (f a) wd
instance MonadIO (WidgetFor site) where
liftIO = WidgetFor . const
-- | @since 1.4.38
instance MonadUnliftIO (WidgetFor site) where
{-# INLINE askUnliftIO #-}
askUnliftIO = WidgetFor $ \wd ->
return (UnliftIO (flip unWidgetFor wd))
instance MonadReader (WidgetData site) (WidgetFor site) where
ask = WidgetFor return
local f (WidgetFor g) = WidgetFor $ g . f
instance MonadTrans (WidgetT site) where
lift = WidgetT . const . liftM (, mempty)
instance MonadThrow m => MonadThrow (WidgetT site m) where
throwM = lift . throwM
instance MonadThrow (WidgetFor site) where
throwM = liftIO . throwM
instance MonadCatch m => MonadCatch (HandlerT site m) where
catch (HandlerT m) c = HandlerT $ \r -> m r `catch` \e -> unHandlerT (c e) r
instance MonadMask m => MonadMask (HandlerT site m) where
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
instance MonadMask m => MonadMask (WidgetT site m) where
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)
instance MonadResource (WidgetFor site) where
liftResourceT f = WidgetFor $ runInternalState f . handlerResource . wdHandler
-- CPP to avoid a redundant constraints warning
#if MIN_VERSION_base(4,9,0)
instance (MonadIO m, MonadBase IO m, MonadThrow m) => MonadResource (WidgetT site m) where
#else
instance (Applicative m, MonadIO m, MonadBase IO m, MonadThrow m) => MonadResource (WidgetT site m) where
#endif
liftResourceT f = WidgetT $ \hd -> liftIO $ (, mempty) <$> runInternalState f (handlerResource hd)
instance MonadLogger (WidgetFor site) where
monadLoggerLog a b c d = WidgetFor $ \wd ->
rheLog (handlerEnv $ wdHandler wd) a b c (toLogStr d)
instance MonadIO m => MonadLogger (WidgetT site m) where
monadLoggerLog a b c d = WidgetT $ \hd ->
liftIO $ (, mempty) <$> rheLog (handlerEnv hd) a b c (toLogStr d)
#if MIN_VERSION_monad_logger(0, 3, 10)
instance MonadIO m => MonadLoggerIO (WidgetT site m) where
askLoggerIO = WidgetT $ \hd -> return (rheLog (handlerEnv hd), mempty)
#endif
instance MonadActive m => MonadActive (WidgetT site m) where
monadActive = lift monadActive
instance MonadActive m => MonadActive (HandlerT site m) where
monadActive = lift monadActive
instance MonadTrans (HandlerT site) where
lift = HandlerT . const
instance MonadLoggerIO (WidgetFor site) where
askLoggerIO = WidgetFor $ return . rheLog . handlerEnv . wdHandler
-- Instances for HandlerT
instance Monad m => Functor (HandlerT site m) where
fmap = liftM
instance Monad m => Applicative (HandlerT site m) where
pure = return
instance Applicative (HandlerFor site) where
pure = HandlerFor . const . return
(<*>) = ap
instance Monad m => Monad (HandlerT site m) where
return = HandlerT . const . return
HandlerT x >>= f = HandlerT $ \r -> x r >>= \x' -> unHandlerT (f x') r
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
-- @resourceForkIO@.
--
-- Using fork usually leads to an exception that says
-- \"Control.Monad.Trans.Resource.register\': The mutable state is being accessed
-- after cleanup. Please contact the maintainers.\"
instance MonadBaseControl b m => MonadBaseControl b (HandlerT site m) where
#if MIN_VERSION_monad_control(1,0,0)
type StM (HandlerT site m) a = StM m a
liftBaseWith f = HandlerT $ \reader' ->
liftBaseWith $ \runInBase ->
f $ runInBase . (\(HandlerT r) -> r reader')
restoreM = HandlerT . const . restoreM
#else
data StM (HandlerT site m) a = StH (StM m a)
liftBaseWith f = HandlerT $ \reader' ->
liftBaseWith $ \runInBase ->
f $ fmap StH . runInBase . (\(HandlerT r) -> r reader')
restoreM (StH base) = HandlerT $ const $ restoreM base
#endif
instance Monad (HandlerFor site) where
return = pure
HandlerFor x >>= f = HandlerFor $ \r -> x r >>= \x' -> unHandlerFor (f x') r
instance MonadIO (HandlerFor site) where
liftIO = HandlerFor . const
instance MonadReader (HandlerData site site) (HandlerFor site) where
ask = HandlerFor return
local f (HandlerFor g) = HandlerFor $ g . f
instance MonadThrow m => MonadThrow (HandlerT site m) where
throwM = lift . monadThrow
-- | @since 1.4.38
instance MonadUnliftIO (HandlerFor site) where
{-# INLINE askUnliftIO #-}
askUnliftIO = HandlerFor $ \r ->
return (UnliftIO (flip unHandlerFor r))
instance (MonadIO m, MonadBase IO m, MonadThrow m) => MonadResource (HandlerT site m) where
liftResourceT f = HandlerT $ \hd -> liftIO $ runInternalState f (handlerResource hd)
instance MonadThrow (HandlerFor site) where
throwM = liftIO . throwM
instance MonadIO m => MonadLogger (HandlerT site m) where
monadLoggerLog a b c d = HandlerT $ \hd ->
liftIO $ rheLog (handlerEnv hd) a b c (toLogStr d)
instance MonadResource (HandlerFor site) where
liftResourceT f = HandlerFor $ runInternalState f . handlerResource
#if MIN_VERSION_monad_logger(0, 3, 10)
instance MonadIO m => MonadLoggerIO (HandlerT site m) where
askLoggerIO = HandlerT $ \hd -> return (rheLog (handlerEnv hd))
#endif
instance MonadLogger (HandlerFor site) where
monadLoggerLog a b c d = HandlerFor $ \hd ->
rheLog (handlerEnv hd) a b c (toLogStr d)
instance MonadLoggerIO (HandlerFor site) where
askLoggerIO = HandlerFor $ \hd -> return (rheLog (handlerEnv hd))
instance Monoid (UniqueList x) where
mempty = UniqueList id
@ -556,7 +477,7 @@ instance Monoid (UniqueList x) where
instance Semigroup (UniqueList x)
instance IsString Content where
fromString = flip ContentBuilder Nothing . Blaze.ByteString.Builder.Char.Utf8.fromString
fromString = flip ContentBuilder Nothing . BB.stringUtf8
instance RenderRoute WaiSubsite where
data Route WaiSubsite = WaiSubsiteRoute [Text] [(Text, Text)]
@ -580,3 +501,42 @@ data Logger = Logger
loggerPutStr :: Logger -> LogStr -> IO ()
loggerPutStr (Logger ls _) = pushLogStr ls
-- | A handler monad for subsite
--
-- @since 1.6.0
newtype SubHandlerFor sub master a = SubHandlerFor
{ unSubHandlerFor :: HandlerData sub master -> IO a
}
deriving Functor
instance Applicative (SubHandlerFor child master) where
pure = SubHandlerFor . const . return
(<*>) = ap
instance Monad (SubHandlerFor child master) where
return = pure
SubHandlerFor x >>= f = SubHandlerFor $ \r -> x r >>= \x' -> unSubHandlerFor (f x') r
instance MonadIO (SubHandlerFor child master) where
liftIO = SubHandlerFor . const
instance MonadReader (HandlerData child master) (SubHandlerFor child master) where
ask = SubHandlerFor return
local f (SubHandlerFor g) = SubHandlerFor $ g . f
-- | @since 1.4.38
instance MonadUnliftIO (SubHandlerFor child master) where
{-# INLINE askUnliftIO #-}
askUnliftIO = SubHandlerFor $ \r ->
return (UnliftIO (flip unSubHandlerFor r))
instance MonadThrow (SubHandlerFor child master) where
throwM = liftIO . throwM
instance MonadResource (SubHandlerFor child master) where
liftResourceT f = SubHandlerFor $ runInternalState f . handlerResource
instance MonadLogger (SubHandlerFor child master) where
monadLoggerLog a b c d = SubHandlerFor $ \sd ->
rheLog (handlerEnv sd) a b c (toLogStr d)
instance MonadLoggerIO (SubHandlerFor child master) where
askLoggerIO = SubHandlerFor $ return . rheLog . handlerEnv

5
yesod-core/Yesod/Core/Unsafe.hs
View File

@ -19,7 +19,10 @@ import Control.Monad.IO.Class (MonadIO)
--
-- > unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger
fakeHandlerGetLogger :: (Yesod site, MonadIO m)
=> (site -> Logger) -> site -> HandlerT site IO a -> m a
=> (site -> Logger)
-> site
-> HandlerFor site a
-> m a
fakeHandlerGetLogger getLogger app f =
runFakeHandler mempty getLogger app f
>>= either (error . ("runFakeHandler issue: " `mappend`) . show)

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

@ -14,6 +14,7 @@
module Yesod.Core.Widget
( -- * Datatype
WidgetT
, WidgetFor
, PageContent (..)
-- * Special Hamlet quasiquoter/TH for Widgets
, whamlet
@ -43,7 +44,6 @@ module Yesod.Core.Widget
, addScriptRemoteAttrs
, addScriptEither
-- * Subsites
, widgetToParentWidget
, handlerToWidget
-- * Internal
, whamletFileWithSettings
@ -60,8 +60,6 @@ import Yesod.Core.Handler (getMessageRender, getUrlRenderParams)
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative ((<$>))
#endif
import Control.Monad (liftM)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Text.Shakespeare.I18N (RenderMessage)
import Data.Text (Text)
import qualified Data.Map as Map
@ -77,6 +75,9 @@ import qualified Data.Text.Lazy.Builder as TB
import Yesod.Core.Types
import Yesod.Core.Class.Handler
type WidgetT site (m :: * -> *) = WidgetFor site
{-# DEPRECATED WidgetT "Use WidgetFor directly" #-}
preEscapedLazyText :: TL.Text -> Html
preEscapedLazyText = preEscapedToMarkup
@ -97,8 +98,8 @@ 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 (site' ~ site, a ~ ()) => ToWidget site' (WidgetFor site a) where
toWidget = liftWidget
instance ToWidget site Html where
toWidget = toWidget . const
-- | @since 1.4.28
@ -268,45 +269,10 @@ ihamletToHtml ih = do
return $ ih (toHtml . mrender) urender
tell :: MonadWidget m => GWData (Route (HandlerSite m)) -> m ()
tell w = liftWidgetT $ WidgetT $ const $ return ((), w)
tell = liftWidget . tellWidget
toUnique :: x -> UniqueList x
toUnique = UniqueList . (:)
handlerToWidget :: Monad m => HandlerT site m a -> WidgetT site m a
handlerToWidget (HandlerT f) = WidgetT $ liftM (, mempty) . f
widgetToParentWidget :: MonadIO m
=> WidgetT child IO a
-> HandlerT child (HandlerT parent m) (WidgetT parent m a)
widgetToParentWidget (WidgetT f) = HandlerT $ \hd -> do
(a, gwd) <- liftIO $ f hd { handlerToParent = const () }
return $ WidgetT $ const $ return (a, liftGWD (handlerToParent hd) gwd)
liftGWD :: (child -> parent) -> GWData child -> GWData parent
liftGWD tp gwd = GWData
{ gwdBody = fixBody $ gwdBody gwd
, gwdTitle = gwdTitle gwd
, gwdScripts = fixUnique fixScript $ gwdScripts gwd
, gwdStylesheets = fixUnique fixStyle $ gwdStylesheets gwd
, gwdCss = fixCss <$> gwdCss gwd
, gwdJavascript = fixJS <$> gwdJavascript gwd
, gwdHead = fixHead $ gwdHead gwd
}
where
fixRender f route = f (tp route)
fixBody (Body h) = Body $ h . fixRender
fixHead (Head h) = Head $ h . fixRender
fixUnique go (UniqueList f) = UniqueList (map go (f []) ++)
fixScript (Script loc attrs) = Script (fixLoc loc) attrs
fixStyle (Stylesheet loc attrs) = Stylesheet (fixLoc loc) attrs
fixLoc (Local url) = Local $ tp url
fixLoc (Remote t) = Remote t
fixCss f = f . fixRender
fixJS f = f . fixRender
handlerToWidget :: HandlerFor site a -> WidgetFor site a
handlerToWidget (HandlerFor f) = WidgetFor $ f . wdHandler

8
yesod-core/Yesod/Routes/TH/ParseRoute.hs
View File

@ -3,7 +3,6 @@
module Yesod.Routes.TH.ParseRoute
( -- ** ParseRoute
mkParseRouteInstance
, mkParseRouteInstance'
) where
import Yesod.Routes.TH.Types
@ -12,11 +11,8 @@ import Data.Text (Text)
import Yesod.Routes.Class
import Yesod.Routes.TH.Dispatch
mkParseRouteInstance :: Type -> [ResourceTree a] -> Q Dec
mkParseRouteInstance = mkParseRouteInstance' []
mkParseRouteInstance' :: Cxt -> Type -> [ResourceTree a] -> Q Dec
mkParseRouteInstance' cxt typ ress = do
mkParseRouteInstance :: Cxt -> Type -> [ResourceTree a] -> Q Dec
mkParseRouteInstance cxt typ ress = do
cls <- mkDispatchClause
MkDispatchSettings
{ mdsRunHandler = [|\_ _ x _ -> x|]

11
yesod-core/Yesod/Routes/TH/RenderRoute.hs
View File

@ -2,7 +2,6 @@
module Yesod.Routes.TH.RenderRoute
( -- ** RenderRoute
mkRenderRouteInstance
, mkRenderRouteInstance'
, mkRouteCons
, mkRenderRouteClauses
) where
@ -148,14 +147,8 @@ mkRenderRouteClauses =
-- This includes both the 'Route' associated type and the
-- 'renderRoute' method. This function uses both 'mkRouteCons' and
-- 'mkRenderRouteClasses'.
mkRenderRouteInstance :: Type -> [ResourceTree Type] -> Q [Dec]
mkRenderRouteInstance = mkRenderRouteInstance' []
-- | A more general version of 'mkRenderRouteInstance' which takes an
-- additional context.
mkRenderRouteInstance' :: Cxt -> Type -> [ResourceTree Type] -> Q [Dec]
mkRenderRouteInstance' cxt typ ress = do
mkRenderRouteInstance :: Cxt -> Type -> [ResourceTree Type] -> Q [Dec]
mkRenderRouteInstance cxt typ ress = do
cls <- mkRenderRouteClauses ress
(cons, decs) <- mkRouteCons ress
#if MIN_VERSION_template_haskell(2,12,0)

8
yesod-core/Yesod/Routes/TH/RouteAttrs.hs
View File

@ -3,7 +3,6 @@
{-# LANGUAGE RecordWildCards #-}
module Yesod.Routes.TH.RouteAttrs
( mkRouteAttrsInstance
, mkRouteAttrsInstance'
) where
import Yesod.Routes.TH.Types
@ -15,11 +14,8 @@ import Data.Text (pack)
import Control.Applicative ((<$>))
#endif
mkRouteAttrsInstance :: Type -> [ResourceTree a] -> Q Dec
mkRouteAttrsInstance = mkRouteAttrsInstance' []
mkRouteAttrsInstance' :: Cxt -> Type -> [ResourceTree a] -> Q Dec
mkRouteAttrsInstance' cxt typ ress = do
mkRouteAttrsInstance :: Cxt -> Type -> [ResourceTree a] -> Q Dec
mkRouteAttrsInstance cxt typ ress = do
clauses <- mapM (goTree id) ress
return $ instanceD cxt (ConT ''RouteAttrs `AppT` typ)
[ FunD 'routeAttrs $ concat clauses

8
yesod-core/bench/widget.hs
View File

@ -5,22 +5,20 @@
{-# LANGUAGE QuasiQuotes #-}
module Main where
import Criterion.Main
import Gauge.Main
import Text.Hamlet
import qualified Data.ByteString.Lazy as L
import qualified Text.Blaze.Html.Renderer.Utf8 as Utf8
import Data.Monoid (mconcat)
import Text.Blaze.Html5 (table, tr, td)
import Text.Blaze.Html (toHtml)
import Yesod.Core.Widget
import Yesod.Core.Types
import Data.Int
main :: IO ()
main = defaultMain
[ bench "bigTable html" $ nf bigTableHtml bigTableData
, bench "bigTable hamlet" $ nf bigTableHamlet bigTableData
, bench "bigTable widget" $ nfIO (bigTableWidget bigTableData)
--, bench "bigTable widget" $ nfIO (bigTableWidget bigTableData)
, bench "bigTable blaze" $ nf bigTableBlaze bigTableData
]
where
@ -49,6 +47,7 @@ bigTableHamlet rows = L.length $ Utf8.renderHtml $ ($ id) [hamlet|
<td>#{show cell}
|]
{-
bigTableWidget :: Show a => [[a]] -> IO Int64
bigTableWidget rows = fmap (L.length . Utf8.renderHtml . ($ render)) (run [whamlet|
<table>
@ -62,6 +61,7 @@ bigTableWidget rows = fmap (L.length . Utf8.renderHtml . ($ render)) (run [whaml
run (WidgetT w) = do
(_, GWData { gwdBody = Body x }) <- w undefined
return x
-}
bigTableBlaze :: Show a => [[a]] -> Int64
bigTableBlaze t = L.length $ Utf8.renderHtml $ table $ Data.Monoid.mconcat $ map row t

6
yesod-core/test/Hierarchy.hs
View File

@ -113,9 +113,9 @@ do
-- /#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
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|]
, mdsSubDispatcher = [|subDispatch|]

14
yesod-core/test/RouteSpec.hs
View File

@ -30,11 +30,7 @@ data MyApp = MyApp
data MySub = MySub
instance RenderRoute MySub where
data
#if MIN_VERSION_base(4,5,0)
Route
#else
YRC.Route
#endif
MySub = MySubRoute ([Text], [(Text, Text)])
deriving (Show, Eq, Read)
renderRoute (MySubRoute x) = x
@ -47,11 +43,7 @@ getMySub MyApp = MySub
data MySubParam = MySubParam Int
instance RenderRoute MySubParam where
data
#if MIN_VERSION_base(4,5,0)
Route
#else
YRC.Route
#endif
MySubParam = ParamRoute Char
deriving (Show, Eq, Read)
renderRoute (ParamRoute x) = ([singleton x], [])
@ -80,9 +72,9 @@ do
[ ResourceLeaf $ Resource "ChildR" [] (Methods Nothing ["GET"]) ["child"] True
]
ress = resParent : resLeaves
rrinst <- mkRenderRouteInstance (ConT ''MyApp) ress
rainst <- mkRouteAttrsInstance (ConT ''MyApp) ress
prinst <- mkParseRouteInstance (ConT ''MyApp) ress
rrinst <- mkRenderRouteInstance [] (ConT ''MyApp) ress
rainst <- mkRouteAttrsInstance [] (ConT ''MyApp) ress
prinst <- mkParseRouteInstance [] (ConT ''MyApp) ress
dispatch <- mkDispatchClause MkDispatchSettings
{ mdsRunHandler = [|runHandler|]
, mdsSubDispatcher = [|subDispatch dispatcher|]

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

@ -15,7 +15,7 @@ import Network.Wai
import Network.Wai.Test
import Yesod.Core
import Data.IORef.Lifted
import UnliftIO.IORef
import Data.Typeable (Typeable)
import qualified Data.ByteString.Lazy.Char8 as L8

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

@ -22,7 +22,7 @@ import qualified Data.Text.Encoding as TE
import Control.Arrow ((***))
import Network.HTTP.Types (encodePath)
import Data.Monoid (mappend)
import Blaze.ByteString.Builder.Char.Utf8 (fromText)
import Data.Text.Encoding (encodeUtf8Builder)
data Subsite = Subsite
@ -64,7 +64,7 @@ instance Yesod Y where
corrected = filter (not . TS.null) s
joinPath Y ar pieces' qs' =
fromText ar `Data.Monoid.mappend` encodePath pieces qs
encodeUtf8Builder ar `Data.Monoid.mappend` encodePath pieces qs
where
pieces = if null pieces' then [""] else pieces'
qs = map (TE.encodeUtf8 *** go) qs'

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

@ -14,11 +14,13 @@ import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Char8 as S8
import Control.Exception (SomeException, try)
import Network.HTTP.Types (Status, mkStatus)
import Blaze.ByteString.Builder (Builder, fromByteString, toLazyByteString)
import Data.ByteString.Builder (Builder, toLazyByteString)
import Data.Monoid (mconcat)
import Data.Text (Text, pack)
import Control.Monad (forM_)
import qualified Control.Exception.Lifted as E
import Control.Monad.Trans.State (StateT (..))
import Control.Monad.Trans.Reader (ReaderT (..))
import qualified UnliftIO.Exception as E
data App = App
@ -99,7 +101,7 @@ getFileBadNameR :: Handler TypedContent
getFileBadNameR = return $ TypedContent "ignored" $ ContentFile (error "filebadname") Nothing
goodBuilderContent :: Builder
goodBuilderContent = Data.Monoid.mconcat $ replicate 100 $ fromByteString "This is a test\n"
goodBuilderContent = Data.Monoid.mconcat $ replicate 100 $ "This is a test\n"
getGoodBuilderR :: Handler TypedContent
getGoodBuilderR = return $ TypedContent "text/plain" $ toContent goodBuilderContent
@ -217,6 +219,6 @@ caseGoodBuilder = runner $ do
caseError :: Int -> IO ()
caseError i = runner $ do
res <- request defaultRequest { pathInfo = ["error", pack $ show i] }
assertStatus 500 res `E.catch` \e -> do
ReaderT $ \r -> StateT $ \s -> runStateT (runReaderT (assertStatus 500 res) r) s `E.catch` \e -> do
liftIO $ print res
E.throwIO (e :: E.SomeException)

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

@ -10,9 +10,11 @@ import Data.Map (singleton)
import Yesod.Core
import Data.Word (Word64)
import System.IO.Unsafe (unsafePerformIO)
import qualified System.Random.MWC as MWC
import Control.Monad.ST
import Control.Monad (replicateM)
import System.Random
gen :: IO Int
gen = getStdRandom next
randomStringSpecs :: Spec
randomStringSpecs = describe "Yesod.Internal.Request.randomString" $ do
@ -21,21 +23,19 @@ randomStringSpecs = describe "Yesod.Internal.Request.randomString" $ do
-- NOTE: this testcase may break on other systems/architectures if
-- mkStdGen is not identical everywhere (is it?).
_looksRandom :: Bool
_looksRandom = runST $ do
gen <- MWC.create
_looksRandom :: IO ()
_looksRandom = do
s <- randomString 20 gen
return $ s == "VH9SkhtptqPs6GqtofVg"
s `shouldBe` "VH9SkhtptqPs6GqtofVg"
noRepeat :: Int -> Int -> Bool
noRepeat len n = runST $ do
gen <- MWC.create
noRepeat :: Int -> Int -> IO ()
noRepeat len n = do
ss <- replicateM n $ randomString len gen
return $ length (nub ss) == n
length (nub ss) `shouldBe` n
-- For convenience instead of "(undefined :: StdGen)".
g :: MWC.GenIO
g :: IO Int
g = error "test/YesodCoreTest/InternalRequest.g"
parseWaiRequest' :: Request

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

@ -13,7 +13,7 @@ import Yesod.Core
import Network.Wai
import Network.Wai.Test
import Data.Text (Text)
import Blaze.ByteString.Builder (toByteString)
import Data.ByteString.Builder (toLazyByteString)
data Y = Y
mkYesod "Y" [parseRoutes|
@ -86,7 +86,7 @@ case_blanks = runner $ do
liftIO $ do
let go r =
let (ps, qs) = renderRoute r
in toByteString $ joinPath Y "" ps qs
in toLazyByteString $ joinPath Y "" ps qs
(go $ TextR "-") `shouldBe` "/single/--"
(go $ TextR "") `shouldBe` "/single/-"
(go $ TextsR ["", "-", "foo", "", "bar"]) `shouldBe` "/multi/-/--/foo/-/bar"

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

@ -1,5 +1,6 @@
{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances, ViewPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-} -- the module name is a lie!!!
module YesodCoreTest.NoOverloadedStrings
( noOverloadedTest
@ -20,19 +21,19 @@ import qualified Data.ByteString.Lazy.Char8 as L8
getSubsite :: a -> Subsite
getSubsite _ = Subsite $(mkYesodSubDispatch resourcesSubsite)
getBarR :: Monad m => m T.Text
getBarR :: MonadHandler m => m T.Text
getBarR = return $ T.pack "BarR"
getBazR :: Yesod master => HandlerT Subsite (HandlerT master IO) Html
getBazR = lift $ defaultLayout [whamlet|Used Default Layout|]
getBazR :: (MonadHandler m, Yesod (HandlerSite m)) => m Html
getBazR = liftHandler $ defaultLayout [whamlet|Used Default Layout|]
getBinR :: Yesod master => HandlerT Subsite (HandlerT master IO) Html
getBinR :: (MonadHandler m, Yesod (HandlerSite m), SubHandlerSite m ~ Subsite) => m Html
getBinR = do
widget <- widgetToParentWidget [whamlet|
routeToParent <- getRouteToParent
liftHandler $ defaultLayout [whamlet|
<p>Used defaultLayoutT
<a href=@{BazR}>Baz
<a href=@{routeToParent BazR}>Baz
|]
lift $ defaultLayout widget
getOnePiecesR :: Monad m => Int -> m ()
getOnePiecesR _ = return ()

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

@ -10,7 +10,7 @@ module YesodCoreTest.NoOverloadedStringsSub where
import Yesod.Core
import Yesod.Core.Types
data Subsite = Subsite (forall master. Yesod master => YesodSubRunnerEnv Subsite master (HandlerT master IO) -> Application)
data Subsite = Subsite (forall master. Yesod master => YesodSubRunnerEnv Subsite master -> Application)
mkYesodSubData "Subsite" [parseRoutes|
/bar BarR GET
@ -21,7 +21,7 @@ mkYesodSubData "Subsite" [parseRoutes|
/has-three-pieces/#Int/#Int/#Int ThreePiecesR GET
|]
instance Yesod master => YesodSubDispatch Subsite (HandlerT master IO) where
instance Yesod master => YesodSubDispatch Subsite master where
yesodSubDispatch ysre =
f ysre
where

25
yesod-core/test/YesodCoreTest/RawResponse.hs
View File

@ -22,7 +22,6 @@ import Control.Monad.Trans.Resource (register)
import Data.IORef
import Data.Streaming.Network (bindPortTCP)
import Network.HTTP.Types (status200)
import Blaze.ByteString.Builder (fromByteString)
mkYesod "App" [parseRoutes|
/ HomeR GET
@ -40,22 +39,22 @@ getHomeR = do
_ <- 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
runConduit $ yield (S8.pack $ show val) .| sink
runConduit $ src .| CL.map (S8.map toUpper) .| sink
getWaiStreamR :: Handler ()
getWaiStreamR = sendWaiResponse $ responseStream status200 [] $ \send flush -> do
flush
send $ fromByteString "hello"
send "hello"
flush
send $ fromByteString " world"
send " world"
getWaiAppStreamR :: Handler ()
getWaiAppStreamR = sendWaiApplication $ \_ f -> f $ responseStream status200 [] $ \send flush -> do
flush
send $ fromByteString "hello"
send "hello"
flush
send $ fromByteString " world"
send " world"
getFreePort :: IO Int
getFreePort = do
@ -77,18 +76,18 @@ specs = do
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")
runConduit $ yield "GET / HTTP/1.1\r\n\r\nhello" .| appSink ad
runConduit (appSource ad .| CB.take 6) >>= (`shouldBe` "0HELLO")
runConduit $ yield "WORLd" .| appSink ad
runConduit (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
runConduit $ yield req .| appSink ad
runConduit $ appSource ad .| CB.lines .| do
let loop = do
x <- await
case x of

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

@ -42,11 +42,11 @@ postPostR = do
return $ RepPlain $ toContent $ T.concat val
postConsumeR = do
body <- rawRequestBody $$ consume
body <- runConduit $ rawRequestBody .| consume
return $ RepPlain $ toContent $ S.concat body
postPartialConsumeR = do
body <- rawRequestBody $$ isolate 5 =$ consume
body <- runConduit $ rawRequestBody .| isolate 5 .| consume
return $ RepPlain $ toContent $ S.concat body
postUnusedR = return $ RepPlain ""

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

@ -1,5 +1,5 @@
name: yesod-core
version: 1.4.37.3
version: 1.6.0
license: MIT
license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com>
@ -21,17 +21,16 @@ extra-source-files:
README.md
library
build-depends: base >= 4.7 && < 5
, time >= 1.1.4
build-depends: base >= 4.9 && < 5
, time >= 1.5
, wai >= 3.0
, wai-extra >= 3.0.7
, bytestring >= 0.10
, bytestring >= 0.10.2
, text >= 0.7
, template-haskell
, path-pieces >= 0.1.2 && < 0.3
, shakespeare >= 2.0
, blaze-builder >= 0.2.1.4 && < 0.5
, transformers >= 0.2.2
, transformers >= 0.4
, mtl
, clientsession >= 0.9.1 && < 0.10
, random >= 1.0.0.2 && < 1.2
@ -39,37 +38,32 @@ library
, old-locale >= 1.0.0.2 && < 1.1
, containers >= 0.2
, unordered-containers >= 0.2
, monad-control >= 0.3 && < 1.1
, transformers-base >= 0.4
, cookie >= 0.4.2 && < 0.5
, cookie >= 0.4.3 && < 0.5
, http-types >= 0.7
, case-insensitive >= 0.2
, parsec >= 2 && < 3.2
, directory >= 1
, vector >= 0.9 && < 0.13
, aeson >= 0.5
, aeson >= 1.0
, fast-logger >= 2.2
, wai-logger >= 0.2
, monad-logger >= 0.3.1 && < 0.4
, conduit >= 1.2
, resourcet >= 0.4.9 && < 1.2
, lifted-base >= 0.1.2
, monad-logger >= 0.3.10 && < 0.4
, conduit >= 1.3
, resourcet >= 1.2
, blaze-html >= 0.5
, blaze-markup >= 0.7.1
, data-default
, safe
, warp >= 3.0.2
, unix-compat
, conduit-extra
, exceptions >= 0.6
, deepseq >= 1.3
, deepseq-generics
, mwc-random
, primitive
, word8
, auto-update
, semigroups
, byteable
, unliftio
exposed-modules: Yesod.Core
Yesod.Core.Content
@ -189,13 +183,11 @@ test-suite tests
,text
,http-types
, random
, blaze-builder
,HUnit
,QuickCheck >= 2 && < 3
,transformers
, conduit
, containers
, lifted-base
, resourcet
, network
, async
@ -203,8 +195,8 @@ test-suite tests
, shakespeare
, streaming-commons
, wai-extra
, mwc-random
, cookie >= 0.4.1 && < 0.5
, unliftio
ghc-options: -Wall
extensions: TemplateHaskell
@ -212,7 +204,7 @@ benchmark widgets
type: exitcode-stdio-1.0
hs-source-dirs: bench
build-depends: base
, criterion
, gauge
, bytestring
, text
, transformers

4
yesod-eventsource/ChangeLog.md
View File

@ -1,3 +1,7 @@
## 1.6.0
* Upgrade to yesod-core 1.6.0
## 1.4.1
* Fix warnings

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

@ -13,7 +13,7 @@ import Control.Monad (when)
import Data.Functor ((<$>))
import Data.Monoid (Monoid (..))
import Yesod.Core
import qualified Data.Conduit as C
import Data.Conduit
import qualified Network.Wai as W
import qualified Network.Wai.EventSource as ES
import qualified Network.Wai.EventSource.EventStream as ES
@ -32,32 +32,35 @@ prepareForEventSource = do
-- | (Internal) Source with a event stream content-type.
respondEventStream :: C.Source (HandlerT site IO) (C.Flush Builder)
-> HandlerT site IO TypedContent
respondEventStream :: ConduitT () (Flush Builder) (HandlerFor site) ()
-> HandlerFor site TypedContent
respondEventStream = respondSource "text/event-stream"
-- | Returns a Server-Sent Event stream from a 'C.Source' of
-- | Returns a Server-Sent Event stream from a 'Source' of
-- 'ES.ServerEvent'@s@. The HTTP socket is flushed after every
-- event. The connection is closed either when the 'C.Source'
-- event. The connection is closed either when the 'Source'
-- finishes outputting data or a 'ES.CloseEvent' is outputted,
-- whichever comes first.
repEventSource :: (EventSourcePolyfill -> C.Source (HandlerT site IO) ES.ServerEvent)
-> HandlerT site IO TypedContent
repEventSource :: (EventSourcePolyfill -> ConduitT () ES.ServerEvent (HandlerFor site) ())
-> HandlerFor site TypedContent
repEventSource src =
prepareForEventSource >>=
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
:: Monad m
=> ConduitT () ES.ServerEvent m ()
-> ConduitT () (Flush Builder) m ()
sourceToSource src =
src C.$= C.awaitForever eventToFlushBuilder
src .| awaitForever eventToFlushBuilder
where
eventToFlushBuilder event =
case ES.eventToBuilder event of
Nothing -> return ()
Just x -> C.yield (C.Chunk x) >> C.yield C.Flush
Just x -> yield (Chunk x) >> yield Flush
-- | Return a Server-Sent Event stream given a 'HandlerT' action
@ -68,8 +71,8 @@ sourceToSource src =
-- The connection is closed as soon as an 'ES.CloseEvent' is
-- outputted, after which no other events are sent to the client.
pollingEventSource :: s
-> (EventSourcePolyfill -> s -> HandlerT site IO ([ES.ServerEvent], s))
-> HandlerT site IO TypedContent
-> (EventSourcePolyfill -> s -> HandlerFor site ([ES.ServerEvent], s))
-> HandlerFor site TypedContent
pollingEventSource initial act = do
polyfill <- prepareForEventSource
let -- Get new events to be sent.
@ -79,8 +82,8 @@ pollingEventSource initial act = do
[] -> getEvents s'
_ -> do
let (builder, continue) = joinEvents evs mempty
C.yield (C.Chunk builder)
C.yield C.Flush
yield (Chunk builder)
yield Flush
when continue (getEvents s')
-- Join all events in a single Builder. Returns @False@
@ -103,7 +106,7 @@ pollingEventSource initial act = do
-- outputted, after which no other events are sent to the client.
ioToRepEventSource :: s
-> (EventSourcePolyfill -> s -> IO ([ES.ServerEvent], s))
-> HandlerT site IO TypedContent
-> HandlerFor site TypedContent
ioToRepEventSource initial act = pollingEventSource initial act'
where act' p s = liftIO (act p s)

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

@ -1,5 +1,5 @@
name: yesod-eventsource
version: 1.4.1
version: 1.6.0
license: MIT
license-file: LICENSE
author: Felipe Lessa <felipe.lessa@gmail.com>
@ -15,8 +15,8 @@ extra-source-files: README.md ChangeLog.md
library
build-depends: base >= 4 && < 5
, yesod-core == 1.4.*
, conduit >= 0.5 && < 1.3
, yesod-core == 1.6.*
, conduit >= 1.3
, wai >= 1.3
, wai-eventsource >= 1.3
, wai-extra

4
yesod-form/ChangeLog.md
View File

@ -1,3 +1,7 @@
## 1.6.0
* Upgrade to yesod-core 1.6.0
## 1.4.16
* Korean translation

2
yesod-form/Yesod/Form/Bootstrap3.hs
View File

@ -186,7 +186,7 @@ renderBootstrap3 formLayout aform fragment = do
-- | (Internal) Render a help widget for tooltips and errors.
helpWidget :: FieldView site -> WidgetT site IO ()
helpWidget :: FieldView site -> WidgetFor site ()
helpWidget view = [whamlet|
$maybe tt <- fvTooltip view
<span .help-block>#{tt}

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

@ -161,10 +161,9 @@ $newline never
}
where showVal = either id (pack . show)
-- | An alias for 'timeFieldTypeText'.
-- | An alias for 'timeFieldTypeTime'.
timeField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m TimeOfDay
timeField = timeFieldTypeText
{-# DEPRECATED timeField "'timeField' currently defaults to an input of type=\"text\". In the next major release, it will default to type=\"time\". To opt in to the new functionality, use 'timeFieldTypeTime'. To keep the existing behavior, use 'timeFieldTypeText'. See 'https://github.com/yesodweb/yesod/pull/874' for details." #-}
timeField = timeFieldTypeTime
-- | Creates an input with @type="time"@. <http://caniuse.com/#search=time%20input%20type Browsers not supporting this type> will fallback to a text field, and Yesod will parse the time as described in 'timeFieldTypeText'.
--
@ -175,6 +174,8 @@ timeFieldTypeTime :: Monad m => RenderMessage (HandlerSite m) FormMessage => Fie
timeFieldTypeTime = timeFieldOfType "time"
-- | Creates an input with @type="text"@, parsing the time from an [H]H:MM[:SS] format, with an optional AM or PM (if not given, AM is assumed for compatibility with the 24 hour clock system).
--
-- This function exists for backwards compatibility with the old implementation of 'timeField', which used to use @type="text"@. Consider using 'timeField' or 'timeFieldTypeTime' for improved UX and validation from the browser.
--
-- Add the @time@ package and import the "Data.Time.LocalTime" module to use this function.
--
@ -420,15 +421,15 @@ urlField = Field
-- > areq (selectFieldList [("Value 1" :: Text, "value1"),("Value 2", "value2")]) "Which value?" Nothing
selectFieldList :: (Eq a, RenderMessage site FormMessage, RenderMessage site msg)
=> [(msg, a)]
-> Field (HandlerT site IO) a
-> Field (HandlerFor site) a
selectFieldList = selectField . optionsPairs
-- | Creates a @\<select>@ tag for selecting one option. Example usage:
--
-- > areq (selectField $ optionsPairs [(MsgValue1, "value1"),(MsgValue2, "value2")]) "Which value?" Nothing
selectField :: (Eq a, RenderMessage site FormMessage)
=> HandlerT site IO (OptionList a)
-> Field (HandlerT site IO) a
=> HandlerFor site (OptionList a)
-> Field (HandlerFor site) a
selectField = selectFieldHelper
(\theId name attrs inside -> [whamlet|
$newline never
@ -446,13 +447,13 @@ $newline never
-- | Creates a @\<select>@ tag for selecting multiple options.
multiSelectFieldList :: (Eq a, RenderMessage site msg)
=> [(msg, a)]
-> Field (HandlerT site IO) [a]
-> Field (HandlerFor site) [a]
multiSelectFieldList = multiSelectField . optionsPairs
-- | Creates a @\<select>@ tag for selecting multiple options.
multiSelectField :: Eq a
=> HandlerT site IO (OptionList a)
-> Field (HandlerT site IO) [a]
=> HandlerFor site (OptionList a)
-> Field (HandlerFor site) [a]
multiSelectField ioptlist =
Field parse view UrlEncoded
where
@ -478,18 +479,18 @@ multiSelectField ioptlist =
-- | Creates an input with @type="radio"@ for selecting one option.
radioFieldList :: (Eq a, RenderMessage site FormMessage, RenderMessage site msg)
=> [(msg, a)]
-> Field (HandlerT site IO) a
-> Field (HandlerFor site) a
radioFieldList = radioField . optionsPairs
-- | Creates an input with @type="checkbox"@ for selecting multiple options.
checkboxesFieldList :: (Eq a, RenderMessage site msg) => [(msg, a)]
-> Field (HandlerT site IO) [a]
-> Field (HandlerFor site) [a]
checkboxesFieldList = checkboxesField . optionsPairs
-- | Creates an input with @type="checkbox"@ for selecting multiple options.
checkboxesField :: Eq a
=> HandlerT site IO (OptionList a)
-> Field (HandlerT site IO) [a]
=> HandlerFor site (OptionList a)
-> Field (HandlerFor site) [a]
checkboxesField ioptlist = (multiSelectField ioptlist)
{ fieldView =
\theId name attrs val _isReq -> do
@ -506,8 +507,8 @@ checkboxesField ioptlist = (multiSelectField ioptlist)
}
-- | Creates an input with @type="radio"@ for selecting one option.
radioField :: (Eq a, RenderMessage site FormMessage)
=> HandlerT site IO (OptionList a)
-> Field (HandlerT site IO) a
=> HandlerFor site (OptionList a)
-> Field (HandlerFor site) a
radioField = selectFieldHelper
(\theId _name _attrs inside -> [whamlet|
$newline never
@ -663,7 +664,7 @@ optionsPersist :: ( YesodPersist site
=> [Filter a]
-> [SelectOpt a]
-> (a -> msg)
-> HandlerT site IO (OptionList (Entity a))
-> HandlerFor site (OptionList (Entity a))
#else
optionsPersist :: ( YesodPersist site, PersistEntity a
, PersistQuery (PersistEntityBackend a)
@ -674,7 +675,7 @@ optionsPersist :: ( YesodPersist site, PersistEntity a
=> [Filter a]
-> [SelectOpt a]
-> (a -> msg)
-> HandlerT site IO (OptionList (Entity a))
-> HandlerFor site (OptionList (Entity a))
#endif
optionsPersist filts ords toDisplay = fmap mkOptionList $ do
mr <- getMessageRender
@ -701,7 +702,7 @@ optionsPersistKey
=> [Filter a]
-> [SelectOpt a]
-> (a -> msg)
-> HandlerT site IO (OptionList (Key a))
-> HandlerFor site (OptionList (Key a))
#else
optionsPersistKey
:: (YesodPersist site
@ -714,7 +715,7 @@ optionsPersistKey
=> [Filter a]
-> [SelectOpt a]
-> (a -> msg)
-> HandlerT site IO (OptionList (Key a))
-> HandlerFor site (OptionList (Key a))
#endif
optionsPersistKey filts ords toDisplay = fmap mkOptionList $ do
@ -728,11 +729,11 @@ optionsPersistKey filts ords toDisplay = fmap mkOptionList $ do
selectFieldHelper
:: (Eq a, RenderMessage site FormMessage)
=> (Text -> Text -> [(Text, Text)] -> WidgetT site IO () -> WidgetT site IO ())
-> (Text -> Text -> Bool -> WidgetT site IO ())
-> (Text -> Text -> [(Text, Text)] -> Text -> Bool -> Text -> WidgetT site IO ())
-> HandlerT site IO (OptionList a)
-> Field (HandlerT site IO) a
=> (Text -> Text -> [(Text, Text)] -> WidgetFor site () -> WidgetFor site ())
-> (Text -> Text -> Bool -> WidgetFor site ())
-> (Text -> Text -> [(Text, Text)] -> Text -> Bool -> Text -> WidgetFor site ())
-> HandlerFor site (OptionList a)
-> Field (HandlerFor site) a
selectFieldHelper outside onOpt inside opts' = Field
{ fieldParse = \x _ -> do
opts <- opts'

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

@ -385,8 +385,8 @@ getHelper form env = do
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 ()))
-> (Html -> MForm m (FormResult a, WidgetFor (HandlerSite m) ()))
-> (Html -> MForm m (FormResult a, WidgetFor (HandlerSite m) ()))
identifyForm identVal form = \fragment -> do
-- Create hidden <input>.
let fragment' =
@ -418,7 +418,7 @@ identifyFormKey = "_formid"
type FormRender m a =
AForm m a
-> Html
-> MForm m (FormResult a, WidgetT (HandlerSite m) IO ())
-> MForm m (FormResult a, WidgetFor (HandlerSite m) ())
renderTable, renderDivs, renderDivsNoLabels :: Monad m => FormRender m a
-- | Render a form into a series of tr tags. Note that, in order to allow

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

@ -53,16 +53,16 @@ class YesodJquery a where
urlJqueryUiDateTimePicker :: a -> Either (Route a) Text
urlJqueryUiDateTimePicker _ = Right "http://github.com/gregwebs/jquery.ui.datetimepicker/raw/master/jquery.ui.datetimepicker.js"
jqueryDayField :: (RenderMessage site FormMessage, YesodJquery site) => JqueryDaySettings -> Field (HandlerT site IO) Day
jqueryDayField :: (RenderMessage site FormMessage, YesodJquery site) => JqueryDaySettings -> Field (HandlerFor site) Day
jqueryDayField = flip jqueryDayField' "date"
-- | Use jQuery's datepicker as the underlying implementation.
--
-- Since 1.4.3
jqueryDatePickerDayField :: (RenderMessage site FormMessage, YesodJquery site) => JqueryDaySettings -> Field (HandlerT site IO) Day
jqueryDatePickerDayField :: (RenderMessage site FormMessage, YesodJquery site) => JqueryDaySettings -> Field (HandlerFor site) Day
jqueryDatePickerDayField = flip jqueryDayField' "text"
jqueryDayField' :: (RenderMessage site FormMessage, YesodJquery site) => JqueryDaySettings -> Text -> Field (HandlerT site IO) Day
jqueryDayField' :: (RenderMessage site FormMessage, YesodJquery site) => JqueryDaySettings -> Text -> Field (HandlerFor site) Day
jqueryDayField' jds inputType = Field
{ fieldParse = parseHelper $ maybe
(Left MsgInvalidDay)
@ -107,13 +107,13 @@ $(function(){
]
jqueryAutocompleteField :: (RenderMessage site FormMessage, YesodJquery site)
=> Route site -> Field (HandlerT site IO) Text
=> Route site -> Field (HandlerFor site) Text
jqueryAutocompleteField = jqueryAutocompleteField' 2
jqueryAutocompleteField' :: (RenderMessage site FormMessage, YesodJquery site)
=> Int -- ^ autocomplete minimum length
-> Route site
-> Field (HandlerT site IO) Text
-> Field (HandlerFor site) Text
jqueryAutocompleteField' minLen src = Field
{ fieldParse = parseHelper $ Right
, fieldView = \theId name attrs val isReq -> do

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

@ -44,17 +44,17 @@ up i = do
-- | Generate a form that accepts 0 or more values from the user, allowing the
-- user to specify that a new row is necessary.
inputList :: (xml ~ WidgetT site IO (), RenderMessage site FormMessage)
inputList :: (xml ~ WidgetFor site (), RenderMessage site FormMessage)
=> Html
-- ^ label for the form
-> ([[FieldView site]] -> xml)
-- ^ how to display the rows, usually either 'massDivs' or 'massTable'
-> (Maybe a -> AForm (HandlerT site IO) a)
-> (Maybe a -> AForm (HandlerFor site) a)
-- ^ display a single row of the form, where @Maybe a@ gives the
-- previously submitted value
-> Maybe [a]
-- ^ default initial values for the form
-> AForm (HandlerT site IO) [a]
-> AForm (HandlerFor site) [a]
inputList label fixXml single mdef = formToAForm $ do
theId <- lift newIdent
down 1
@ -94,9 +94,9 @@ $newline never
, fvRequired = False
}])
withDelete :: (xml ~ WidgetT site IO (), RenderMessage site FormMessage)
=> AForm (HandlerT site IO) a
-> MForm (HandlerT site IO) (Either xml (FormResult a, [FieldView site]))
withDelete :: (xml ~ WidgetFor site (), RenderMessage site FormMessage)
=> AForm (HandlerFor site) a
-> MForm (HandlerFor site) (Either xml (FormResult a, [FieldView site]))
withDelete af = do
down 1
deleteName <- newFormIdent
@ -129,7 +129,7 @@ fixme eithers =
massDivs, massTable
:: [[FieldView site]]
-> WidgetT site IO ()
-> WidgetFor site ()
massDivs viewss = [whamlet|
$newline never
$forall views <- viewss

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

@ -29,7 +29,7 @@ class Yesod a => YesodNic a where
urlNicEdit :: a -> Either (Route a) Text
urlNicEdit _ = Right "http://js.nicedit.com/nicEdit-latest.js"
nicHtmlField :: YesodNic site => Field (HandlerT site IO) Html
nicHtmlField :: YesodNic site => Field (HandlerFor site) Html
nicHtmlField = Field
{ fieldParse = \e _ -> return . Right . fmap (preEscapedToMarkup . sanitizeBalance) . listToMaybe $ e
, fieldView = \theId name attrs val _isReq -> do

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

@ -189,7 +189,7 @@ data FieldView site = FieldView
{ fvLabel :: Html
, fvTooltip :: Maybe Html
, fvId :: Text
, fvInput :: WidgetT site IO ()
, fvInput :: WidgetFor site ()
, fvErrors :: Maybe Html
, fvRequired :: Bool
}
@ -200,7 +200,7 @@ type FieldViewFunc m a
-> [(Text, Text)] -- ^ Attributes
-> Either Text a -- ^ Either (invalid text) or (legitimate result)
-> Bool -- ^ Required?
-> WidgetT (HandlerSite m) IO ()
-> WidgetFor (HandlerSite m) ()
data Field m a = Field
{ fieldParse :: [Text] -> [FileInfo] -> m (Either (SomeMessage (HandlerSite m)) (Maybe a))

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

@ -1,5 +1,5 @@
name: yesod-form
version: 1.4.16
version: 1.6.0
license: MIT
license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com>
@ -20,8 +20,8 @@ flag network-uri
library
build-depends: base >= 4 && < 5
, yesod-core >= 1.4.14 && < 1.5
, yesod-persistent >= 1.4 && < 1.5
, yesod-core >= 1.6 && < 1.7
, yesod-persistent >= 1.6 && < 1.7
, time >= 1.1.4
, shakespeare >= 2.0
, persistent

4
yesod-newsfeed/ChangeLog.md
View File

@ -1,5 +1,9 @@
# Changelog
## 1.6.1
* Upgrade to yesod-core 1.6.0
## 1.6
* Create new datatype `EntryEnclosure` for self-documentation of `feedEntryEnclosure`.

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

@ -1,5 +1,5 @@
name: yesod-newsfeed
version: 1.6
version: 1.6.1.0
license: MIT
license-file: LICENSE
author: Michael Snoyman, Patrick Brisbin
@ -15,7 +15,7 @@ extra-source-files: README.md ChangeLog.md
library
build-depends: base >= 4 && < 5
, yesod-core >= 1.4 && < 1.5
, yesod-core >= 1.6 && < 1.7
, time >= 1.1.4
, shakespeare >= 2.0
, bytestring >= 0.9.1.4

4
yesod-persistent/ChangeLog.md
View File

@ -1,3 +1,7 @@
## 1.6.0
* Upgrade to yesod-core 1.6.0
## 1.4.3
* Fix overly powerful constraints on get404 and getBy404.

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

@ -37,11 +37,11 @@ import qualified Database.Persist.Sql as SQL
unSqlPersistT :: a -> a
unSqlPersistT = id
type YesodDB site = ReaderT (YesodPersistBackend site) (HandlerT site IO)
type YesodDB site = ReaderT (YesodPersistBackend site) (HandlerFor site)
class Monad (YesodDB site) => YesodPersist site where
type YesodPersistBackend site
runDB :: YesodDB site a -> HandlerT site IO a
runDB :: YesodDB site a -> HandlerFor site a
-- | Helper for creating 'runDB'.
--
@ -49,8 +49,8 @@ class Monad (YesodDB site) => YesodPersist site where
defaultRunDB :: PersistConfig c
=> (site -> c)
-> (site -> PersistConfigPool c)
-> PersistConfigBackend c (HandlerT site IO) a
-> HandlerT site IO a
-> PersistConfigBackend c (HandlerFor site) a
-> HandlerFor site a
defaultRunDB getConfig getPool f = do
master <- getYesod
Database.Persist.runPool
@ -74,10 +74,10 @@ class YesodPersist site => YesodPersistRunner site where
-- least, a rollback will be used instead.
--
-- Since 1.2.0
getDBRunner :: HandlerT site IO (DBRunner site, HandlerT site IO ())
getDBRunner :: HandlerFor site (DBRunner site, HandlerFor site ())
newtype DBRunner site = DBRunner
{ runDBRunner :: forall a. YesodDB site a -> HandlerT site IO a
{ runDBRunner :: forall a. YesodDB site a -> HandlerFor site a
}
-- | Helper for implementing 'getDBRunner'.
@ -86,11 +86,11 @@ newtype DBRunner site = DBRunner
#if MIN_VERSION_persistent(2,5,0)
defaultGetDBRunner :: (SQL.IsSqlBackend backend, YesodPersistBackend site ~ backend)
=> (site -> Pool backend)
-> HandlerT site IO (DBRunner site, HandlerT site IO ())
-> HandlerFor site (DBRunner site, HandlerFor site ())
#else
defaultGetDBRunner :: YesodPersistBackend site ~ SQL.SqlBackend
=> (site -> Pool SQL.SqlBackend)
-> HandlerT site IO (DBRunner site, HandlerT site IO ())
-> HandlerFor site (DBRunner site, HandlerFor site ())
#endif
defaultGetDBRunner getPool = do
pool <- fmap getPool getYesod
@ -118,8 +118,8 @@ defaultGetDBRunner getPool = do
--
-- Since 1.2.0
runDBSource :: YesodPersistRunner site
=> Source (YesodDB site) a
-> Source (HandlerT site IO) a
=> ConduitT () a (YesodDB site) ()
-> ConduitT () a (HandlerFor site) ()
runDBSource src = do
(dbrunner, cleanup) <- lift getDBRunner
transPipe (runDBRunner dbrunner) src
@ -128,8 +128,8 @@ runDBSource src = do
-- | Extends 'respondSource' to create a streaming database response body.
respondSourceDB :: YesodPersistRunner site
=> ContentType
-> Source (YesodDB site) (Flush Builder)
-> HandlerT site IO TypedContent
-> ConduitT () (Flush Builder) (YesodDB site) ()
-> HandlerFor site TypedContent
respondSourceDB ctype = respondSource ctype . runDBSource
-- | Get the given entity by ID, or return a 404 not found if it doesn't exist.

2
yesod-persistent/test/Yesod/PersistSpec.hs
View File

@ -45,7 +45,7 @@ getHomeR = do
insert_ $ Person "Charlie"
insert_ $ Person "Alice"
insert_ $ Person "Bob"
respondSourceDB typePlain $ selectSource [] [Asc PersonName] $= awaitForever toBuilder
respondSourceDB typePlain $ selectSource [] [Asc PersonName] .| awaitForever toBuilder
where
toBuilder (Entity _ (Person name)) = do
yield $ Chunk $ fromText name

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

@ -1,5 +1,5 @@
name: yesod-persistent
version: 1.4.3
version: 1.6.0
license: MIT
license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com>
@ -15,8 +15,8 @@ extra-source-files: README.md ChangeLog.md
library
build-depends: base >= 4 && < 5
, yesod-core >= 1.4.0 && < 1.5
, persistent >= 2.1 && < 2.8
, yesod-core >= 1.6 && < 1.7
, persistent >= 2.8 && < 2.9
, persistent-template >= 2.1 && < 2.8
, transformers >= 0.2.2
, blaze-builder
@ -36,7 +36,7 @@ test-suite test
, hspec
, wai-extra
, yesod-core
, persistent-sqlite
, persistent-sqlite >= 2.8
, yesod-persistent
, conduit
, blaze-builder

3
yesod-sitemap/ChangeLog.md
View File

@ -0,0 +1,3 @@
## 1.6.0
* Upgrade to yesod-core 1.6.0

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

@ -74,19 +74,19 @@ robots smurl = do
-- | Serve a stream of @SitemapUrl@s as a sitemap.
--
-- Since 1.2.0
sitemap :: Source (HandlerT site IO) (SitemapUrl (Route site))
-> HandlerT site IO TypedContent
sitemap :: ConduitT () (SitemapUrl (Route site)) (HandlerFor site) ()
-> HandlerFor site TypedContent
sitemap urls = do
render <- getUrlRender
respondSource typeXml $ do
yield Flush
urls $= sitemapConduit render $= renderBuilder def $= CL.map Chunk
urls .| sitemapConduit render .| renderBuilder def .| CL.map Chunk
-- | Convenience wrapper for @sitemap@ for the case when the input is an
-- in-memory list.
--
-- Since 1.2.0
sitemapList :: [SitemapUrl (Route site)] -> HandlerT site IO TypedContent
sitemapList :: [SitemapUrl (Route site)] -> HandlerFor site TypedContent
sitemapList = sitemap . mapM_ yield
-- | Convert a stream of @SitemapUrl@s to XML @Event@s using the given URL
@ -97,7 +97,7 @@ sitemapList = sitemap . mapM_ yield
-- Since 1.2.0
sitemapConduit :: Monad m
=> (a -> Text)
-> Conduit (SitemapUrl a) m Event
-> ConduitT (SitemapUrl a) Event m ()
sitemapConduit render = do
yield EventBeginDocument
element "urlset" [] $ awaitForever goUrl

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

@ -1,5 +1,5 @@
name: yesod-sitemap
version: 1.4.0.1
version: 1.6.0
license: MIT
license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com>
@ -15,7 +15,7 @@ extra-source-files: README.md ChangeLog.md
library
build-depends: base >= 4 && < 5
, yesod-core >= 1.4 && < 1.5
, yesod-core >= 1.6 && < 1.7
, time >= 1.1.4
, xml-conduit >= 1.0
, text

4
yesod-static/ChangeLog.md
View File

@ -1,3 +1,7 @@
## 1.6.0
* Upgrade to yesod-core 1.6.0
## 1.5.3.1
* Switch to cryptonite

7
yesod-static/Yesod/EmbeddedStatic.hs
View File

@ -57,10 +57,7 @@ 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
, YesodSubDispatch(..)
)
import Yesod.Core (YesodSubDispatch(..))
import Yesod.Core.Types
( YesodSubRunnerEnv(..)
, YesodRunnerEnv(..)
@ -81,7 +78,7 @@ import Yesod.EmbeddedStatic.Generators
embeddedResourceR :: [T.Text] -> [(T.Text, T.Text)] -> Route EmbeddedStatic
embeddedResourceR = EmbeddedResourceR
instance YesodSubDispatch EmbeddedStatic (HandlerT master IO) where
instance YesodSubDispatch EmbeddedStatic master where
yesodSubDispatch YesodSubRunnerEnv {..} req = resp
where
master = yreSite ysreParentEnv

12
yesod-static/Yesod/EmbeddedStatic/Generators.hs
View File

@ -24,9 +24,9 @@ module Yesod.EmbeddedStatic.Generators (
-- * Util
, pathToName
-- * Custom Generators
-- $example
) where
@ -34,7 +34,6 @@ import Control.Applicative as A ((<$>), (<*>))
import Control.Exception (try, SomeException)
import Control.Monad (forM, when)
import Data.Char (isDigit, isLower)
import Data.Conduit (($$))
import Data.Default (def)
import Data.Maybe (isNothing)
import Language.Haskell.TH
@ -44,8 +43,7 @@ import System.FilePath ((</>))
import Text.Jasmine (minifym)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BL
import qualified Data.Conduit.List as C
import Data.Conduit.Binary (sourceHandle)
import Conduit
import qualified Data.Text as T
import qualified System.Process as Proc
import System.Exit (ExitCode (ExitSuccess))
@ -208,13 +206,13 @@ compressTool f opts ct = do
}
(Just hin, Just hout, _, ph) <- Proc.createProcess p
(compressed, (), code) <- runConcurrently $ (,,)
A.<$> Concurrently (sourceHandle hout $$ C.consume)
A.<$> Concurrently (runConduit $ sourceHandle hout .| sinkLazy)
A.<*> Concurrently (BL.hPut hin ct >> hClose hin)
A.<*> Concurrently (Proc.waitForProcess ph)
if code == ExitSuccess
then do
putStrLn $ "Compressed successfully with " ++ f
return $ BL.fromChunks compressed
return compressed
else error $ "compressTool: compression failed with " ++ f

4
yesod-static/Yesod/EmbeddedStatic/Internal.hs
View File

@ -25,7 +25,7 @@ import Network.Wai
import Network.Wai.Application.Static (defaultWebAppSettings, staticApp)
import WaiAppStatic.Types
import Yesod.Core
( HandlerT
( HandlerFor
, ParseRoute(..)
, RenderRoute(..)
, getYesod
@ -136,7 +136,7 @@ develApp settings extra req sendResponse = do
-- | 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)])))
-> HandlerFor site (Maybe (Either T.Text (Route site, [(T.Text, T.Text)])))
-- | Helper for embedStaticContent and embedLicensedStaticContent.
staticContentHelper :: (site -> EmbeddedStatic)

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

@ -68,7 +68,6 @@ import qualified System.FilePath as FP
import Control.Monad
import Data.FileEmbed (embedDir)
import Control.Monad.Trans.Resource (runResourceT)
import Yesod.Core
import Yesod.Core.Types
@ -78,7 +77,6 @@ import Language.Haskell.TH.Syntax as TH
import Crypto.Hash.Conduit (hashFile, sinkHash)
import Crypto.Hash (MD5, Digest)
import Control.Monad.Catch (MonadThrow)
import Control.Monad.Trans.State
import qualified Data.ByteArray as ByteArray
@ -94,11 +92,7 @@ import Data.List (foldl')
import qualified Data.ByteString as S
import System.PosixCompat.Files (getFileStatus, modificationTime)
import System.Posix.Types (EpochTime)
import Data.Conduit
import Data.Conduit.List (sourceList, consume)
import Data.Conduit.Binary (sourceFile)
import qualified Data.Conduit.Text as CT
import Data.Functor.Identity (runIdentity)
import Conduit
import System.FilePath ((</>), (<.>), takeDirectory)
import qualified System.FilePath as F
import qualified Data.Text.Lazy as TL
@ -175,12 +169,10 @@ instance RenderRoute Static where
instance ParseRoute Static where
parseRoute (x, y) = Just $ StaticRoute x y
instance (MonadThrow m, MonadIO m, MonadBaseControl IO m)
=> YesodSubDispatch Static (HandlerT master m) where
instance YesodSubDispatch Static master where
yesodSubDispatch YesodSubRunnerEnv {..} req =
ysreParentRunner base ysreParentEnv (fmap ysreToParentRoute route) req
ysreParentRunner handlert ysreParentEnv (fmap ysreToParentRoute route) req
where
base = stripHandlerT handlert ysreGetSub ysreToParentRoute route
route = Just $ StaticRoute (pathInfo req) []
Static set = ysreGetSub $ yreSite $ ysreParentEnv
@ -425,8 +417,8 @@ base64md5File = fmap (base64 . encode) . hashFile
base64md5 :: L.ByteString -> String
base64md5 lbs =
base64 $ encode
$ runIdentity
$ sourceList (L.toChunks lbs) $$ sinkHash
$ runConduitPure
$ Conduit.sourceLazy lbs .| sinkHash
where
encode d = ByteArray.convert (d :: Digest MD5)
@ -461,8 +453,11 @@ combineStatics' :: CombineType
-> [Route Static] -- ^ files to combine
-> Q Exp
combineStatics' combineType CombineSettings {..} routes = do
texts <- qRunIO $ runResourceT $ mapM_ yield fps $$ awaitForever readUTFFile =$ consume
ltext <- qRunIO $ preProcess $ TL.fromChunks texts
texts <- qRunIO $ runConduitRes
$ yieldMany fps
.| awaitForever readUTFFile
.| sinkLazy
ltext <- qRunIO $ preProcess texts
bs <- qRunIO $ postProcess fps $ TLE.encodeUtf8 ltext
let hash' = base64md5 bs
suffix = csCombinedFolder </> hash' <.> extension
@ -476,7 +471,7 @@ combineStatics' combineType CombineSettings {..} routes = do
fps :: [FilePath]
fps = map toFP routes
toFP (StaticRoute pieces _) = csStaticDir </> F.joinPath (map T.unpack pieces)
readUTFFile fp = sourceFile fp =$= CT.decode CT.utf8
readUTFFile fp = sourceFile fp .| decodeUtf8C
postProcess =
case combineType of
JS -> csJsPostProcess

10
yesod-static/yesod-static.cabal
View File

@ -1,5 +1,5 @@
name: yesod-static
version: 1.5.3.1
version: 1.6.0
license: MIT
license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com>
@ -29,7 +29,7 @@ library
build-depends: base >= 4 && < 5
, containers >= 0.2
, old-time >= 1.0
, yesod-core >= 1.4 && < 1.5
, yesod-core >= 1.6 && < 1.7
, base64-bytestring >= 0.1.0.1
, byteable >= 0.1
, bytestring >= 0.9.1.4
@ -42,8 +42,7 @@ library
, file-embed >= 0.0.4.1 && < 0.5
, http-types >= 0.7
, unix-compat >= 0.2
, conduit >= 0.5
, conduit-extra
, conduit >= 1.3
, cryptonite-conduit >= 0.1
, cryptonite >= 0.11
, memory
@ -92,7 +91,7 @@ test-suite tests
YesodStaticTest
build-depends: base
, hspec >= 1.3
, yesod-test >= 1.4
, yesod-test >= 1.6
, wai-extra
, HUnit
@ -124,7 +123,6 @@ test-suite tests
, unordered-containers
, async
, process
, conduit-extra
, exceptions
ghc-options: -Wall -threaded

4
yesod-test/ChangeLog.md
View File

@ -1,3 +1,7 @@
## 1.6.0
* Upgrade to yesod-core 1.6.0
## 1.5.9.1
* Fixes a Haddock syntax error in 1.5.9 [#1473](https://github.com/yesodweb/yesod/pull/1473)

90
yesod-test/Yesod/Test.hs
View File

@ -6,6 +6,7 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-|
Yesod.Test is a pragmatic framework for testing web applications built
@ -63,6 +64,7 @@ module Yesod.Test
, addFile
, setRequestBody
, RequestBuilder
, SIO
, setUrl
, clickOn
@ -135,7 +137,8 @@ import qualified Network.Socket.Internal as Sock
import Data.CaseInsensitive (CI)
import Network.Wai
import Network.Wai.Test hiding (assertHeader, assertNoHeader, request)
import qualified Control.Monad.Trans.State as ST
import Control.Monad.Trans.Reader (ReaderT (..))
import Conduit (MonadThrow)
import Control.Monad.IO.Class
import System.IO
import Yesod.Core.Unsafe (runFakeHandler)
@ -147,6 +150,7 @@ import Text.XML.Cursor hiding (element)
import qualified Text.XML.Cursor as C
import qualified Text.HTML.DOM as HD
import Control.Monad.Trans.Writer
import Data.IORef
import qualified Data.Map as M
import qualified Web.Cookie as Cookie
import qualified Blaze.ByteString.Builder as Builder
@ -180,7 +184,7 @@ data YesodExampleData site = YesodExampleData
-- | A single test case, to be run with 'yit'.
--
-- Since 1.2.0
type YesodExample site = ST.StateT (YesodExampleData site) IO
type YesodExample site = SIO (YesodExampleData site)
-- | Mapping from cookie name to value.
--
@ -203,13 +207,13 @@ data YesodSpecTree site
--
-- Since 1.2.0
getTestYesod :: YesodExample site site
getTestYesod = fmap yedSite ST.get
getTestYesod = fmap yedSite getSIO
-- | Get the most recently provided response value, if available.
--
-- Since 1.2.0
getResponse :: YesodExample site (Maybe SResponse)
getResponse = fmap yedResponse ST.get
getResponse = fmap yedResponse getSIO
data RequestBuilderData site = RequestBuilderData
{ rbdPostData :: RBDPostData
@ -232,7 +236,7 @@ data RequestPart
-- | The 'RequestBuilder' state monad constructs a URL encoded string of arguments
-- to send with your requests. Some of the functions that run on it use the current
-- response to analyze the forms that the server is expecting to receive.
type RequestBuilder site = ST.StateT (RequestBuilderData site) IO
type RequestBuilder site = SIO (RequestBuilderData site)
-- | Start describing a Tests suite keeping cookies and a reference to the tested 'Application'
-- and 'ConnectionPool'
@ -249,7 +253,7 @@ yesodSpec site yspecs =
unYesod (YesodSpecGroup x y) = Hspec.specGroup x $ map unYesod y
unYesod (YesodSpecItem x y) = Hspec.specItem x $ do
app <- toWaiAppPlain site
ST.evalStateT y YesodExampleData
evalSIO y YesodExampleData
{ yedApp = app
, yedSite = site
, yedCookies = M.empty
@ -269,7 +273,7 @@ yesodSpecWithSiteGenerator getSiteAction yspecs =
unYesod getSiteAction' (YesodSpecItem x y) = Hspec.specItem x $ do
site <- getSiteAction'
app <- toWaiAppPlain site
ST.evalStateT y YesodExampleData
evalSIO y YesodExampleData
{ yedApp = app
, yedSite = site
, yedCookies = M.empty
@ -290,7 +294,7 @@ yesodSpecApp site getApp yspecs =
unYesod (YesodSpecGroup x y) = Hspec.specGroup x $ map unYesod y
unYesod (YesodSpecItem x y) = Hspec.specItem x $ do
app <- getApp
ST.evalStateT y YesodExampleData
evalSIO y YesodExampleData
{ yedApp = app
, yedSite = site
, yedCookies = M.empty
@ -303,12 +307,11 @@ yit label example = tell [YesodSpecItem label example]
-- Performs a given action using the last response. Use this to create
-- response-level assertions
withResponse' :: MonadIO m
=> (state -> Maybe SResponse)
withResponse' :: (state -> Maybe SResponse)
-> [T.Text]
-> (SResponse -> ST.StateT state m a)
-> ST.StateT state m a
withResponse' getter errTrace f = maybe err f . getter =<< ST.get
-> (SResponse -> SIO state a)
-> SIO state a
withResponse' getter errTrace f = maybe err f . getter =<< getSIO
where err = failure msg
msg = if null errTrace
then "There was no response, you should make a request."
@ -327,11 +330,10 @@ parseHTML :: HtmlLBS -> Cursor
parseHTML html = fromDocument $ HD.parseLBS html
-- | Query the last response using CSS selectors, returns a list of matched fragments
htmlQuery' :: MonadIO m
=> (state -> Maybe SResponse)
htmlQuery' :: (state -> Maybe SResponse)
-> [T.Text]
-> Query
-> ST.StateT state m [HtmlLBS]
-> SIO state [HtmlLBS]
htmlQuery' getter errTrace query = withResponse' getter ("Tried to invoke htmlQuery' in order to read HTML of a previous response." : errTrace) $ \ res ->
case findBySelector (simpleBody res) query of
Left err -> failure $ query <> " did not parse: " <> T.pack (show err)
@ -496,14 +498,14 @@ printMatches query = do
-- | Add a parameter with the given name and value to the request body.
addPostParam :: T.Text -> T.Text -> RequestBuilder site ()
addPostParam name value =
ST.modify $ \rbd -> rbd { rbdPostData = (addPostData (rbdPostData rbd)) }
modifySIO $ \rbd -> rbd { rbdPostData = (addPostData (rbdPostData rbd)) }
where addPostData (BinaryPostData _) = error "Trying to add post param to binary content."
addPostData (MultipleItemsPostData posts) =
MultipleItemsPostData $ ReqKvPart name value : posts
-- | Add a parameter with the given name and value to the query string.
addGetParam :: T.Text -> T.Text -> RequestBuilder site ()
addGetParam name value = ST.modify $ \rbd -> rbd
addGetParam name value = modifySIO $ \rbd -> rbd
{ rbdGets = (TE.encodeUtf8 name, Just $ TE.encodeUtf8 value)
: rbdGets rbd
}
@ -522,7 +524,7 @@ addFile :: T.Text -- ^ The parameter name for the file.
-> RequestBuilder site ()
addFile name path mimetype = do
contents <- liftIO $ BSL8.readFile path
ST.modify $ \rbd -> rbd { rbdPostData = (addPostData (rbdPostData rbd) contents) }
modifySIO $ \rbd -> rbd { rbdPostData = (addPostData (rbdPostData rbd) contents) }
where addPostData (BinaryPostData _) _ = error "Trying to add file after setting binary content."
addPostData (MultipleItemsPostData posts) contents =
MultipleItemsPostData $ ReqFilePart name path contents mimetype : posts
@ -531,7 +533,7 @@ addFile name path mimetype = do
-- This looks up the name of a field based on the contents of the label pointing to it.
genericNameFromLabel :: (T.Text -> T.Text -> Bool) -> T.Text -> RequestBuilder site T.Text
genericNameFromLabel match label = do
mres <- fmap rbdResponse ST.get
mres <- fmap rbdResponse getSIO
res <-
case mres of
Nothing -> failure "genericNameFromLabel: No response available"
@ -798,7 +800,7 @@ addTokenFromCookieNamedToHeaderNamed cookieName headerName = do
-- Since 1.4.3.2
getRequestCookies :: RequestBuilder site Cookies
getRequestCookies = do
requestBuilderData <- ST.get
requestBuilderData <- getSIO
headers <- case simpleHeaders Control.Applicative.<$> rbdResponse requestBuilderData of
Just h -> return h
Nothing -> failure "getRequestCookies: No request has been made yet; the cookies can't be looked up."
@ -906,7 +908,7 @@ getLocation = do
-- > request $ do
-- > setMethod methodPut
setMethod :: H.Method -> RequestBuilder site ()
setMethod m = ST.modify $ \rbd -> rbd { rbdMethod = m }
setMethod m = modifySIO $ \rbd -> rbd { rbdMethod = m }
-- | Sets the URL used by the request.
--
@ -921,7 +923,7 @@ setUrl :: (Yesod site, RedirectUrl site url)
=> url
-> RequestBuilder site ()
setUrl url' = do
site <- fmap rbdSite ST.get
site <- fmap rbdSite getSIO
eurl <- Yesod.Core.Unsafe.runFakeHandler
M.empty
(const $ error "Yesod.Test: No logger available")
@ -929,7 +931,7 @@ setUrl url' = do
(toTextUrl url')
url <- either (error . show) return eurl
let (urlPath, urlQuery) = T.break (== '?') url
ST.modify $ \rbd -> rbd
modifySIO $ \rbd -> rbd
{ rbdPath =
case DL.filter (/="") $ H.decodePathSegments $ TE.encodeUtf8 urlPath of
("http:":_:rest) -> rest
@ -968,7 +970,7 @@ clickOn query = do
-- > request $ do
-- > setRequestBody $ encode $ object ["age" .= (1 :: Integer)]
setRequestBody :: BSL8.ByteString -> RequestBuilder site ()
setRequestBody body = ST.modify $ \rbd -> rbd { rbdPostData = BinaryPostData body }
setRequestBody body = modifySIO $ \rbd -> rbd { rbdPostData = BinaryPostData body }
-- | Adds the given header to the request; see "Network.HTTP.Types.Header" for creating 'Header's.
--
@ -978,7 +980,7 @@ setRequestBody body = ST.modify $ \rbd -> rbd { rbdPostData = BinaryPostData bod
-- > request $ do
-- > addRequestHeader (hUserAgent, "Chrome/41.0.2228.0")
addRequestHeader :: H.Header -> RequestBuilder site ()
addRequestHeader header = ST.modify $ \rbd -> rbd
addRequestHeader header = modifySIO $ \rbd -> rbd
{ rbdHeaders = header : rbdHeaders rbd
}
@ -998,9 +1000,9 @@ addRequestHeader header = ST.modify $ \rbd -> rbd
request :: RequestBuilder site ()
-> YesodExample site ()
request reqBuilder = do
YesodExampleData app site oldCookies mRes <- ST.get
YesodExampleData app site oldCookies mRes <- getSIO
RequestBuilderData {..} <- liftIO $ ST.execStateT reqBuilder RequestBuilderData
RequestBuilderData {..} <- liftIO $ execSIO reqBuilder RequestBuilderData
{ rbdPostData = MultipleItemsPostData []
, rbdResponse = mRes
, rbdMethod = "GET"
@ -1040,7 +1042,7 @@ request reqBuilder = do
}) app
let newCookies = parseSetCookies $ simpleHeaders response
cookies' = M.fromList [(Cookie.setCookieName c, c) | c <- newCookies] `M.union` cookies
ST.put $ YesodExampleData app site cookies' (Just response)
putSIO $ YesodExampleData app site cookies' (Just response)
where
isFile (ReqFilePart _ _ _ _) = True
isFile _ = False
@ -1144,14 +1146,14 @@ testApp :: site -> Middleware -> TestApp site
testApp site middleware = (site, middleware)
type YSpec site = Hspec.SpecWith (TestApp site)
instance YesodDispatch site => Hspec.Example (ST.StateT (YesodExampleData site) IO a) where
type Arg (ST.StateT (YesodExampleData site) IO a) = TestApp site
instance YesodDispatch site => Hspec.Example (SIO (YesodExampleData site) a) where
type Arg (SIO (YesodExampleData site) a) = TestApp site
evaluateExample example params action =
Hspec.evaluateExample
(action $ \(site, middleware) -> do
app <- toWaiAppPlain site
_ <- ST.evalStateT example YesodExampleData
_ <- evalSIO example YesodExampleData
{ yedApp = middleware app
, yedSite = site
, yedCookies = M.empty
@ -1160,3 +1162,27 @@ instance YesodDispatch site => Hspec.Example (ST.StateT (YesodExampleData site)
return ())
params
($ ())
-- | State + IO
--
-- @since 1.6.0
newtype SIO s a = SIO (ReaderT (IORef s) IO a)
deriving (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadUnliftIO)
getSIO :: SIO s s
getSIO = SIO $ ReaderT readIORef
putSIO :: s -> SIO s ()
putSIO s = SIO $ ReaderT $ \ref -> writeIORef ref $! s
modifySIO :: (s -> s) -> SIO s ()
modifySIO f = SIO $ ReaderT $ \ref -> modifyIORef' ref f
evalSIO :: SIO s a -> s -> IO a
evalSIO (SIO (ReaderT f)) s = newIORef s >>= f
execSIO :: SIO s () -> s -> IO s
execSIO (SIO (ReaderT f)) s = do
ref <- newIORef s
f ref
readIORef ref

4
yesod-test/test/main.hs
View File

@ -37,7 +37,7 @@ import Data.ByteString.Lazy.Char8 ()
import qualified Data.Map as Map
import qualified Text.HTML.DOM as HD
import Network.HTTP.Types.Status (status301, status303, unsupportedMediaType415)
import Control.Exception.Lifted(SomeException, try)
import UnliftIO.Exception (tryAny, SomeException, try)
parseQuery_ :: Text -> [[SelectorGroup]]
parseQuery_ = either error id . parseQuery
@ -192,7 +192,7 @@ main = hspec $ do
bodyEquals "<html><head><title>Hello</title></head><body><p>Hello World</p><p>Hello Moon</p></body></html>"
get ("/htmlWithLink" :: Text)
(bad :: Either SomeException ()) <- try (clickOn "a#nonexistentlink")
bad <- tryAny (clickOn "a#nonexistentlink")
assertEq "bad link" (isLeft bad) True

10
yesod-test/yesod-test.cabal
View File

@ -1,5 +1,5 @@
name: yesod-test
version: 1.5.9.1
version: 1.6.0
license: MIT
license-file: LICENSE
author: Nubis <nubis@woobiz.com.ar>
@ -27,7 +27,6 @@ library
, hspec-core == 2.*
, html-conduit >= 0.1
, http-types >= 0.7
, monad-control
, network >= 2.2
, persistent >= 1.0
, pretty-show >= 1.6
@ -38,7 +37,8 @@ library
, wai-extra
, xml-conduit >= 1.0
, xml-types >= 0.3
, yesod-core >= 1.4.14
, yesod-core >= 1.6
, conduit
exposed-modules: Yesod.Test
Yesod.Test.CssQuery
@ -58,11 +58,11 @@ test-suite test
, containers
, html-conduit
, yesod-core
, yesod-form >= 1.4.14
, yesod-form >= 1.6
, text
, wai
, lifted-base
, http-types
, unliftio
source-repository head
type: git

4
yesod-websockets/ChangeLog.md
View File

@ -1,3 +1,7 @@
## 0.3.0
* Upgrade to yesod-core 1.6
## 0.2.6
* Fix warnings

192
yesod-websockets/Yesod/WebSockets.hs
View File

@ -1,4 +1,3 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module Yesod.WebSockets
@ -34,19 +33,13 @@ module Yesod.WebSockets
, WS.ConnectionOptions (..)
) where
import qualified Control.Concurrent.Async as A
import Control.Monad (forever, void, when)
import Control.Monad.IO.Class (MonadIO (liftIO))
import Control.Monad.Trans.Control (control)
import Control.Monad.Trans.Control (MonadBaseControl (liftBaseWith, restoreM))
import Control.Monad.Trans.Reader (ReaderT (ReaderT, runReaderT))
import qualified Data.Conduit as C
import qualified Data.Conduit.List as CL
import Control.Monad (forever, when)
import Control.Monad.Reader (ReaderT, runReaderT, MonadReader, ask)
import Conduit
import qualified Network.Wai.Handler.WebSockets as WaiWS
import qualified Network.WebSockets as WS
import qualified Yesod.Core as Y
import Control.Exception (SomeException)
import Control.Exception.Enclosed (tryAny)
import UnliftIO (SomeException, tryAny, MonadIO, liftIO, MonadUnliftIO, withRunInIO, race, race_, concurrently, concurrently_)
-- | A transformer for a WebSockets handler.
--
@ -60,28 +53,28 @@ type WebSocketsT = ReaderT WS.Connection
-- instead.
--
-- Since 0.1.0
webSockets :: (Y.MonadBaseControl IO m, Y.MonadHandler m) => WebSocketsT m () -> m ()
webSockets
:: (MonadUnliftIO m, Y.MonadHandler m)
=> WebSocketsT m ()
-> m ()
webSockets = webSocketsOptions WS.defaultConnectionOptions
-- | Varient of 'webSockets' which allows you to specify
-- the WS.ConnectionOptions setttings when upgrading to a websocket connection.
--
-- Since 0.2.5
webSocketsOptions :: (Y.MonadBaseControl IO m, Y.MonadHandler m)
=> WS.ConnectionOptions
-> WebSocketsT m ()
-> m ()
#if MIN_VERSION_websockets(0,10,0)
webSocketsOptions
:: (MonadUnliftIO m, Y.MonadHandler m)
=> WS.ConnectionOptions
-> WebSocketsT m ()
-> m ()
webSocketsOptions opts = webSocketsOptionsWith opts $ const $ return $ Just $ WS.AcceptRequest Nothing []
#else
webSocketsOptions opts = webSocketsOptionsWith opts $ const $ return $ Just $ WS.AcceptRequest Nothing
#endif
-- | Varient of 'webSockets' which allows you to specify the 'WS.AcceptRequest'
-- setttings when upgrading to a websocket connection.
--
-- Since 0.2.4
webSocketsWith :: (Y.MonadBaseControl IO m, Y.MonadHandler m)
webSocketsWith :: (MonadUnliftIO m, Y.MonadHandler m)
=> (WS.RequestHead -> m (Maybe WS.AcceptRequest))
-- ^ A Nothing indicates that the websocket upgrade request should not happen
-- and instead the rest of the handler will be called instead. This allows
@ -98,7 +91,7 @@ webSocketsWith = webSocketsOptionsWith WS.defaultConnectionOptions
-- setttings when upgrading to a websocket connection.
--
-- Since 0.2.5
webSocketsOptionsWith :: (Y.MonadBaseControl IO m, Y.MonadHandler m)
webSocketsOptionsWith :: (MonadUnliftIO m, Y.MonadHandler m)
=> WS.ConnectionOptions
-- ^ Custom websockets options
-> (WS.RequestHead -> m (Maybe WS.AcceptRequest))
@ -119,7 +112,7 @@ webSocketsOptionsWith wsConnOpts buildAr inner = do
Nothing -> return ()
Just ar ->
Y.sendRawResponseNoConduit
$ \src sink -> control $ \runInIO -> WaiWS.runWebSockets
$ \src sink -> withRunInIO $ \runInIO -> WaiWS.runWebSockets
wsConnOpts
rhead
(\pconn -> do
@ -130,132 +123,157 @@ webSocketsOptionsWith wsConnOpts buildAr inner = do
sink
-- | Wrapper for capturing exceptions
wrapWSE :: MonadIO m => (WS.Connection -> a -> IO ())-> a -> WebSocketsT m (Either SomeException ())
wrapWSE ws x = ReaderT $ liftIO . tryAny . flip ws x
wrapWSE :: (MonadIO m, MonadReader WS.Connection m)
=> (WS.Connection -> a -> IO ())
-> a
-> m (Either SomeException ())
wrapWSE ws x = do
conn <- ask
liftIO $ tryAny $ ws conn x
wrapWS :: MonadIO m => (WS.Connection -> a -> IO ()) -> a -> WebSocketsT m ()
wrapWS ws x = ReaderT $ liftIO . flip ws x
wrapWS :: (MonadIO m, MonadReader WS.Connection m)
=> (WS.Connection -> a -> IO ())
-> a
-> m ()
wrapWS ws x = do
conn <- ask
liftIO $ ws conn x
-- | Receive a piece of data from the client.
--
-- Since 0.1.0
receiveData :: (MonadIO m, WS.WebSocketsData a) => WebSocketsT m a
receiveData = ReaderT $ liftIO . WS.receiveData
receiveData
:: (MonadIO m, MonadReader WS.Connection m, WS.WebSocketsData a)
=> m a
receiveData = do
conn <- ask
liftIO $ WS.receiveData conn
-- | Receive a piece of data from the client.
-- Capture SomeException as the result or operation
-- Since 0.2.2
receiveDataE :: (MonadIO m, WS.WebSocketsData a) => WebSocketsT m (Either SomeException a)
receiveDataE = ReaderT $ liftIO . tryAny . WS.receiveData
receiveDataE
:: (MonadIO m, MonadReader WS.Connection m, WS.WebSocketsData a)
=> m (Either SomeException a)
receiveDataE = do
conn <- ask
liftIO $ tryAny $ WS.receiveData conn
-- | Receive an application message.
-- Capture SomeException as the result or operation
-- Since 0.2.3
receiveDataMessageE :: (MonadIO m) => WebSocketsT m (Either SomeException WS.DataMessage)
receiveDataMessageE = ReaderT $ liftIO . tryAny . WS.receiveDataMessage
receiveDataMessageE
:: (MonadIO m, MonadReader WS.Connection m)
=> m (Either SomeException WS.DataMessage)
receiveDataMessageE = do
conn <- ask
liftIO $ tryAny $ WS.receiveDataMessage conn
-- | Send a textual message to the client.
--
-- Since 0.1.0
sendTextData :: (MonadIO m, WS.WebSocketsData a) => a -> WebSocketsT m ()
sendTextData
:: (MonadIO m, WS.WebSocketsData a, MonadReader WS.Connection m)
=> a
-> m ()
sendTextData = wrapWS WS.sendTextData
-- | Send a textual message to the client.
-- Capture SomeException as the result or operation
-- and can be used like
-- and can be used like
-- `either handle_exception return =<< sendTextDataE ("Welcome" :: Text)`
-- Since 0.2.2
sendTextDataE :: (MonadIO m, WS.WebSocketsData a) => a -> WebSocketsT m (Either SomeException ())
sendTextDataE
:: (MonadIO m, WS.WebSocketsData a, MonadReader WS.Connection m)
=> a
-> m (Either SomeException ())
sendTextDataE = wrapWSE WS.sendTextData
-- | Send a binary message to the client.
--
-- Since 0.1.0
sendBinaryData :: (MonadIO m, WS.WebSocketsData a) => a -> WebSocketsT m ()
sendBinaryData
:: (MonadIO m, WS.WebSocketsData a, MonadReader WS.Connection m)
=> a
-> m ()
sendBinaryData = wrapWS WS.sendBinaryData
-- | Send a binary message to the client.
-- Capture SomeException as the result of operation
-- Since 0.2.2
sendBinaryDataE :: (MonadIO m, WS.WebSocketsData a) => a -> WebSocketsT m (Either SomeException ())
sendBinaryDataE
:: (MonadIO m, WS.WebSocketsData a, MonadReader WS.Connection m)
=> a
-> m (Either SomeException ())
sendBinaryDataE = wrapWSE WS.sendBinaryData
-- | Send a ping message to the client.
--
-- Since 0.2.2
sendPing :: (MonadIO m, WS.WebSocketsData a) => a -> WebSocketsT m ()
sendPing
:: (MonadIO m, WS.WebSocketsData a, MonadReader WS.Connection m)
=> a
-> WebSocketsT m ()
sendPing = wrapWS WS.sendPing
-- | Send a ping message to the client.
-- | Send a ping message to the client.
-- Capture SomeException as the result of operation
-- Since 0.2.2
sendPingE :: (MonadIO m, WS.WebSocketsData a) => a -> WebSocketsT m (Either SomeException ())
sendPingE
:: (MonadIO m, WS.WebSocketsData a, MonadReader WS.Connection m)
=> a
-> m (Either SomeException ())
sendPingE = wrapWSE WS.sendPing
-- | Send a DataMessage to the client.
-- | Send a DataMessage to the client.
-- Capture SomeException as the result of operation
-- Since 0.2.3
sendDataMessageE :: (MonadIO m) => WS.DataMessage -> WebSocketsT m (Either SomeException ())
sendDataMessageE x = ReaderT $ liftIO . tryAny . (`WS.sendDataMessage` x)
sendDataMessageE
:: (MonadIO m, MonadReader WS.Connection m)
=> WS.DataMessage
-> m (Either SomeException ())
sendDataMessageE x = do
conn <- ask
liftIO $ tryAny $ WS.sendDataMessage conn x
-- | Send a close request to the client.
--
-- | Send a close request to the client.
--
-- Since 0.2.2
sendClose :: (MonadIO m, WS.WebSocketsData a) => a -> WebSocketsT m ()
sendClose
:: (MonadIO m, WS.WebSocketsData a, MonadReader WS.Connection m)
=> a
-> WebSocketsT m ()
sendClose = wrapWS WS.sendClose
-- | Send a close request to the client.
-- | Send a close request to the client.
-- Capture SomeException as the result of operation
-- Since 0.2.2
sendCloseE :: (MonadIO m, WS.WebSocketsData a) => a -> WebSocketsT m (Either SomeException ())
sendCloseE
:: (MonadIO m, WS.WebSocketsData a, MonadReader WS.Connection m)
=> a
-> m (Either SomeException ())
sendCloseE = wrapWSE WS.sendClose
-- | A @Source@ of WebSockets data from the user.
--
-- Since 0.1.0
sourceWS :: (MonadIO m, WS.WebSocketsData a) => C.Producer (WebSocketsT m) a
sourceWS = forever $ Y.lift receiveData >>= C.yield
sourceWS
:: (MonadIO m, WS.WebSocketsData a, MonadReader WS.Connection m)
=> ConduitT i a m ()
sourceWS = forever $ lift receiveData >>= yield
-- | A @Sink@ for sending textual data to the user.
--
-- Since 0.1.0
sinkWSText :: (MonadIO m, WS.WebSocketsData a) => C.Consumer a (WebSocketsT m) ()
sinkWSText = CL.mapM_ sendTextData
sinkWSText
:: (MonadIO m, WS.WebSocketsData a, MonadReader WS.Connection m)
=> ConduitT a o m ()
sinkWSText = mapM_C sendTextData
-- | A @Sink@ for sending binary data to the user.
--
-- Since 0.1.0
sinkWSBinary :: (MonadIO m, WS.WebSocketsData a) => C.Consumer a (WebSocketsT m) ()
sinkWSBinary = CL.mapM_ sendBinaryData
-- | Generalized version of 'A.race'.
--
-- Since 0.1.0
race :: MonadBaseControl IO m => m a -> m b -> m (Either a b)
race x y = liftBaseWith (\run -> A.race (run x) (run y))
>>= either (fmap Left . restoreM) (fmap Right . restoreM)
-- | Generalized version of 'A.race_'.
--
-- Since 0.1.0
race_ :: MonadBaseControl IO m => m a -> m b -> m ()
race_ x y = void $ race x y
-- | Generalized version of 'A.concurrently'. Note that if your underlying
-- monad has some kind of mutable state, the state from the second action will
-- overwrite the state from the first.
--
-- Since 0.1.0
concurrently :: MonadBaseControl IO m => m a -> m b -> m (a, b)
concurrently x y = do
(resX, resY) <- liftBaseWith $ \run -> A.concurrently (run x) (run y)
x' <- restoreM resX
y' <- restoreM resY
return (x', y')
-- | Run two actions concurrently (like 'A.concurrently'), but discard their
-- results and any modified monadic state.
--
-- Since 0.1.0
concurrently_ :: MonadBaseControl IO m => m a -> m b -> m ()
concurrently_ x y = void $ liftBaseWith $ \run -> A.concurrently (run x) (run y)
sinkWSBinary
:: (MonadIO m, WS.WebSocketsData a, MonadReader WS.Connection m)
=> ConduitT a o m ()
sinkWSBinary = mapM_C sendBinaryData

13
yesod-websockets/yesod-websockets.cabal
View File

@ -1,5 +1,5 @@
name: yesod-websockets
version: 0.2.6
version: 0.3.0
synopsis: WebSockets support for Yesod
description: WebSockets support for Yesod
homepage: https://github.com/yesodweb/yesod
@ -21,13 +21,12 @@ library
, wai
, wai-websockets >= 2.1
, websockets >= 0.9
, websockets >= 0.10
, transformers >= 0.2
, yesod-core >= 1.4
, monad-control >= 0.3
, conduit >= 1.0.15.1
, async >= 2.0.1.5
, enclosed-exceptions >= 1.0
, yesod-core >= 1.6
, unliftio
, conduit >= 1.3
, mtl
source-repository head
type: git

4
yesod/ChangeLog.md
View File

@ -1,3 +1,7 @@
## 1.6.0
* Upgrade to yesod-core 1.6
## 1.4.5
* Fix warnings

10
yesod/Yesod/Default/Util.hs
View File

@ -18,9 +18,7 @@ import qualified Data.ByteString.Lazy as L
import Data.Text (Text, pack, unpack)
import Yesod.Core -- purposely using complete import so that Haddock will see addStaticContent
import Control.Monad (when, unless)
import Control.Monad.Trans.Resource (runResourceT)
import Data.Conduit (($$))
import Data.Conduit.Binary (sourceLbs, sinkFileCautious)
import Conduit
import System.Directory (doesFileExist, createDirectoryIfMissing)
import Language.Haskell.TH.Syntax
import Text.Lucius (luciusFile, luciusFileReload)
@ -42,12 +40,12 @@ addStaticContentExternal
-> Text -- ^ filename extension
-> Text -- ^ mime type
-> L.ByteString -- ^ file contents
-> HandlerT master IO (Maybe (Either Text (Route master, [(Text, Text)])))
-> HandlerFor master (Maybe (Either Text (Route master, [(Text, Text)])))
addStaticContentExternal minify hash staticDir toRoute ext' _ content = do
liftIO $ createDirectoryIfMissing True statictmp
exists <- liftIO $ doesFileExist fn'
unless exists $
liftIO $ runResourceT $ sourceLbs content' $$ sinkFileCautious fn'
unless exists $ withSinkFileCautious fn' $ \sink ->
runConduit $ sourceLazy content' .| sink
return $ Just $ Right (toRoute ["tmp", pack fn], [])
where
fn, statictmp, fn' :: FilePath

12
yesod/yesod.cabal
View File

@ -1,5 +1,5 @@
name: yesod
version: 1.4.5
version: 1.6.0
license: MIT
license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com>
@ -18,10 +18,9 @@ library
cpp-options: -DWINDOWS
build-depends: base >= 4.6 && < 5
, yesod-core >= 1.4 && < 1.5
, yesod-persistent >= 1.4 && < 1.5
, yesod-form >= 1.4 && < 1.5
, monad-control >= 0.3 && < 1.1
, yesod-core >= 1.6 && < 1.7
, yesod-persistent >= 1.6 && < 1.7
, yesod-form >= 1.6 && < 1.7
, transformers >= 0.2.2
, wai >= 1.3
, wai-extra >= 1.3
@ -38,8 +37,7 @@ library
, bytestring
, monad-logger
, fast-logger
, conduit
, conduit-extra >= 1.1.14
, conduit >= 1.3
, resourcet
, shakespeare
, streaming-commons