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 # Use new container infrastructure to enable caching
sudo: false 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 language: generic
# Caching so the next build will be fast too. # Caching so the next build will be fast too.
@ -35,27 +35,12 @@ matrix:
include: include:
# We grab the appropriate GHC and cabal-install versions from hvr's PPA. See: # We grab the appropriate GHC and cabal-install versions from hvr's PPA. See:
# https://github.com/hvr/multi-ghc-travis # 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 - env: BUILD=cabal GHCVER=8.0.2 CABALVER=1.24 HAPPYVER=1.19.5 ALEXVER=3.1.7
compiler: ": #GHC 8.0.2" 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]}} 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, # Build with the newest GHC and cabal-install. This is an accepted failure,
# see below. # see below.
@ -69,32 +54,40 @@ matrix:
compiler: ": #stack default" compiler: ": #stack default"
addons: {apt: {packages: [libgmp-dev]}} addons: {apt: {packages: [libgmp-dev]}}
- env: BUILD=stack ARGS="--resolver lts-6" - env: BUILD=stack ARGS="--resolver lts-7"
compiler: ": #stack 7.10.3" compiler: ": #stack 8.0.1"
addons: {apt: {packages: [libgmp-dev]}} addons: {apt: {packages: [libgmp-dev]}}
- env: BUILD=stack ARGS="--resolver lts-8" - env: BUILD=stack ARGS="--resolver lts-9"
compiler: ": #stack 8.0.2" compiler: ": #stack 8.0.2"
addons: {apt: {packages: [libgmp-dev]}} 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 # Nightly builds are allowed to fail
- env: BUILD=stack ARGS="--resolver nightly" - env: BUILD=stack ARGS="--resolver nightly"
compiler: ": #stack nightly" compiler: ": #stack nightly"
addons: {apt: {packages: [libgmp-dev]}} addons: {apt: {packages: [libgmp-dev]}}
# Build on OS X in addition to Linux # Build on macOS in addition to Linux
- env: BUILD=stack ARGS="" - env: BUILD=stack ARGS=""
compiler: ": #stack default osx" compiler: ": #stack default osx"
os: osx os: osx
- env: BUILD=stack ARGS="--resolver lts-6" - env: BUILD=stack ARGS="--resolver lts-7"
compiler: ": #stack 7.10.3 osx" compiler: ": #stack 8.0.1 osx"
os: osx os: osx
- env: BUILD=stack ARGS="--resolver lts-8" - env: BUILD=stack ARGS="--resolver lts-9"
compiler: ": #stack 8.0.2 osx" compiler: ": #stack 8.0.2 osx"
os: osx os: osx
- env: BUILD=stack ARGS="--resolver lts-10"
compiler: ": #stack 8.2.2 osx"
os: osx
- env: BUILD=stack ARGS="--resolver nightly" - env: BUILD=stack ARGS="--resolver nightly"
compiler: ": #stack nightly osx" compiler: ": #stack nightly osx"
os: osx os: osx
@ -102,8 +95,6 @@ matrix:
allow_failures: allow_failures:
- env: BUILD=cabal GHCVER=head CABALVER=head HAPPYVER=1.19.5 ALEXVER=3.1.7 - env: BUILD=cabal GHCVER=head CABALVER=head HAPPYVER=1.19.5 ALEXVER=3.1.7
- env: BUILD=stack ARGS="--resolver nightly" - 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: before_install:
# Using compiler above sets CC to an invalid value, so unset it # 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 - if [ -f configure.ac ]; then autoreconf -i; fi
- | - |
set -ex set -ex
if [ "$ARGS" = "--resolver nightly" ] case "$BUILD" in
then stack)
stack --install-ghc $ARGS build cabal-install # Add in extra-deps for older snapshots, as necessary
stack --install-ghc $ARGS solver --update-config stack --no-terminal --install-ghc $ARGS test --bench --dry-run || ( \
fi 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 set +ex
script: script:
@ -151,47 +159,28 @@ script:
set -ex set -ex
case "$BUILD" in case "$BUILD" in
stack) stack)
if [ `uname` = "Darwin" ] stack --no-terminal $ARGS test --bench --no-run-benchmarks --haddock --no-haddock-deps
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
;; ;;
cabal) 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 cabal install --enable-tests --enable-benchmarks --force-reinstalls --ghc-options=-O0 --reorder-goals --max-backjumps=-1 $CABALARGS $PACKAGES
ORIGDIR=$(pwd) # Times out
for dir in $PACKAGES #ORIGDIR=$(pwd)
do #for dir in $PACKAGES
cd $dir #do
cabal check || [ "$CABALVER" == "1.16" ] # cd $dir
cabal sdist # cabal check || [ "$CABALVER" == "1.16" ]
PKGVER=$(cabal info . | awk '{print $2;exit}') # cabal sdist
SRC_TGZ=$PKGVER.tar.gz # PKGVER=$(cabal info . | awk '{print $2;exit}')
cd dist # SRC_TGZ=$PKGVER.tar.gz
tar zxfv "$SRC_TGZ" # cd dist
cd "$PKGVER" # tar zxfv "$SRC_TGZ"
cabal configure --enable-tests # cd "$PKGVER"
cabal build # cabal configure --enable-tests --ghc-options -O0
cd $ORIGDIR # cabal build
done # cabal test
# cd $ORIGDIR
#done
;; ;;
esac esac
set +ex set +ex

25
stack.yaml
View File

@ -14,6 +14,25 @@ packages:
- ./yesod-eventsource - ./yesod-eventsource
- ./yesod-websockets - ./yesod-websockets
extra-deps: extra-deps:
- conduit-extra-1.2.2 - unliftio-core-0.1.1.0
- unliftio-core-0.1.0.0 - unliftio-0.2.4.0
- typed-process-0.2.0.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 ## 1.4.2
* Fix warnings * Fix warnings

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

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

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

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

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

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

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

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

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

@ -186,29 +186,29 @@ class ( YesodAuth site
-- has not yet been verified. -- has not yet been verified.
-- --
-- @since 1.1.0 -- @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. -- | Send an email to the given address to verify ownership.
-- --
-- @since 1.1.0 -- @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. -- | Get the verification key for the given email ID.
-- --
-- @since 1.1.0 -- @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. -- | Set the verification key for the given email ID.
-- --
-- @since 1.1.0 -- @since 1.1.0
setVerifyKey :: AuthEmailId site -> VerKey -> HandlerT site IO () setVerifyKey :: AuthEmailId site -> VerKey -> AuthHandler site ()
-- | Hash and salt a password -- | Hash and salt a password
-- --
-- Default: 'saltPass'. -- Default: 'saltPass'.
-- --
-- @since 1.4.20 -- @since 1.4.20
hashAndSaltPassword :: Text -> HandlerT site IO SaltedPass hashAndSaltPassword :: Text -> AuthHandler site SaltedPass
hashAndSaltPassword = liftIO . saltPass hashAndSaltPassword = liftIO . saltPass
-- | Verify a password matches the stored password for the given account. -- | 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'. -- Default: Fetch a password with 'getPassword' and match using 'Yesod.Auth.Util.PasswordStore.verifyPassword'.
-- --
-- @since 1.4.20 -- @since 1.4.20
verifyPassword :: Text -> SaltedPass -> HandlerT site IO Bool verifyPassword :: Text -> SaltedPass -> AuthHandler site Bool
verifyPassword plain salted = return $ isValidPass plain salted verifyPassword plain salted = return $ isValidPass plain salted
-- | Verify the email address on the given account. -- | Verify the email address on the given account.
@ -228,28 +228,28 @@ class ( YesodAuth site
-- See <https://github.com/yesodweb/yesod/issues/1222>. -- See <https://github.com/yesodweb/yesod/issues/1222>.
-- --
-- @since 1.1.0 -- @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. -- | Get the salted password for the given account.
-- --
-- @since 1.1.0 -- @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. -- | Set the salted password for the given account.
-- --
-- @since 1.1.0 -- @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 -- | Get the credentials for the given @Identifier@, which may be either an
-- email address or some other identification (e.g., username). -- email address or some other identification (e.g., username).
-- --
-- @since 1.2.0 -- @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. -- | Get the email address for the given email ID.
-- --
-- @since 1.1.0 -- @since 1.1.0
getEmail :: AuthEmailId site -> HandlerT site IO (Maybe Email) getEmail :: AuthEmailId site -> AuthHandler site (Maybe Email)
-- | Generate a random alphanumeric string. -- | 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. -- Default: if the user logged in via an email link do not require a password.
-- --
-- @since 1.2.1 -- @since 1.2.1
needOldPassword :: AuthId site -> HandlerT site IO Bool needOldPassword :: AuthId site -> AuthHandler site Bool
needOldPassword aid' = do needOldPassword aid' = do
mkey <- lookupSession loginLinkKey mkey <- lookupSession loginLinkKey
case mkey >>= readMay . TS.unpack of case mkey >>= readMay . TS.unpack of
@ -280,7 +280,7 @@ class ( YesodAuth site
-- | Check that the given plain-text password meets minimum security standards. -- | Check that the given plain-text password meets minimum security standards.
-- --
-- Default: password is at least three characters. -- 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 checkPasswordSecurity _ x
| TS.length x >= 3 = return $ Right () | TS.length x >= 3 = return $ Right ()
| otherwise = return $ Left "Password must be at least three characters" | otherwise = return $ Left "Password must be at least three characters"
@ -288,7 +288,7 @@ class ( YesodAuth site
-- | Response after sending a confirmation email. -- | Response after sending a confirmation email.
-- --
-- @since 1.2.2 -- @since 1.2.2
confirmationEmailSentResponse :: Text -> HandlerT site IO TypedContent confirmationEmailSentResponse :: Text -> AuthHandler site TypedContent
confirmationEmailSentResponse identifier = do confirmationEmailSentResponse identifier = do
mr <- getMessageRender mr <- getMessageRender
selectRep $ do selectRep $ do
@ -314,7 +314,7 @@ class ( YesodAuth site
-- Default: 'defaultEmailLoginHandler'. -- Default: 'defaultEmailLoginHandler'.
-- --
-- @since 1.4.17 -- @since 1.4.17
emailLoginHandler :: (Route Auth -> Route site) -> WidgetT site IO () emailLoginHandler :: (Route Auth -> Route site) -> WidgetFor site ()
emailLoginHandler = defaultEmailLoginHandler emailLoginHandler = defaultEmailLoginHandler
@ -325,7 +325,7 @@ class ( YesodAuth site
-- Default: 'defaultRegisterHandler'. -- Default: 'defaultRegisterHandler'.
-- --
-- @since: 1.2.6 -- @since: 1.2.6
registerHandler :: HandlerT Auth (HandlerT site IO) Html registerHandler :: AuthHandler site Html
registerHandler = defaultRegisterHandler registerHandler = defaultRegisterHandler
-- | Handler called to render the \"forgot password\" page. -- | Handler called to render the \"forgot password\" page.
@ -335,7 +335,7 @@ class ( YesodAuth site
-- Default: 'defaultForgotPasswordHandler'. -- Default: 'defaultForgotPasswordHandler'.
-- --
-- @since: 1.2.6 -- @since: 1.2.6
forgotPasswordHandler :: HandlerT Auth (HandlerT site IO) Html forgotPasswordHandler :: AuthHandler site Html
forgotPasswordHandler = defaultForgotPasswordHandler forgotPasswordHandler = defaultForgotPasswordHandler
-- | Handler called to render the \"set password\" page. The -- | Handler called to render the \"set password\" page. The
@ -351,7 +351,7 @@ class ( YesodAuth site
-- field for the old password should be presented. -- field for the old password should be presented.
-- Otherwise, just two fields for the new password are -- Otherwise, just two fields for the new password are
-- needed. -- needed.
-> HandlerT Auth (HandlerT site IO) TypedContent -> AuthHandler site TypedContent
setPasswordHandler = defaultSetPasswordHandler setPasswordHandler = defaultSetPasswordHandler
authEmail :: (YesodAuthEmail m) => AuthPlugin m authEmail :: (YesodAuthEmail m) => AuthPlugin m
@ -371,15 +371,18 @@ authEmail =
dispatch "POST" ["set-password"] = postPasswordR >>= sendResponse dispatch "POST" ["set-password"] = postPasswordR >>= sendResponse
dispatch _ _ = notFound dispatch _ _ = notFound
getRegisterR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) Html getRegisterR :: YesodAuthEmail master => AuthHandler master Html
getRegisterR = registerHandler getRegisterR = registerHandler
-- | Default implementation of 'emailLoginHandler'. -- | Default implementation of 'emailLoginHandler'.
-- --
-- @since 1.4.17 -- @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 defaultEmailLoginHandler toParent = do
(widget, enctype) <- liftWidgetT $ generateFormPost loginForm (widget, enctype) <- generateFormPost loginForm
[whamlet| [whamlet|
<form method="post" action="@{toParent loginR}", enctype=#{enctype}> <form method="post" action="@{toParent loginR}", enctype=#{enctype}>
@ -437,11 +440,11 @@ defaultEmailLoginHandler toParent = do
-- | Default implementation of 'registerHandler'. -- | Default implementation of 'registerHandler'.
-- --
-- @since 1.2.6 -- @since 1.2.6
defaultRegisterHandler :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) Html defaultRegisterHandler :: YesodAuthEmail master => AuthHandler master Html
defaultRegisterHandler = do defaultRegisterHandler = do
(widget, enctype) <- lift $ generateFormPost registrationForm (widget, enctype) <- generateFormPost registrationForm
toParentRoute <- getRouteToParent toParentRoute <- getRouteToParent
lift $ authLayout $ do authLayout $ do
setTitleI Msg.RegisterLong setTitleI Msg.RegisterLong
[whamlet| [whamlet|
<p>_{Msg.EnterEmail} <p>_{Msg.EnterEmail}
@ -480,14 +483,14 @@ parseEmail = withObject "email" (\obj -> do
registerHelper :: YesodAuthEmail master registerHelper :: YesodAuthEmail master
=> Bool -- ^ allow usernames? => Bool -- ^ allow usernames?
-> Route Auth -> Route Auth
-> HandlerT Auth (HandlerT master IO) TypedContent -> AuthHandler master TypedContent
registerHelper allowUsername dest = do registerHelper allowUsername dest = do
y <- lift getYesod y <- getYesod
checkCsrfHeaderOrParam defaultCsrfHeaderName defaultCsrfParamName checkCsrfHeaderOrParam defaultCsrfHeaderName defaultCsrfParamName
pidentifier <- lookupPostParam "email" pidentifier <- lookupPostParam "email"
midentifier <- case pidentifier of midentifier <- case pidentifier of
Nothing -> do Nothing -> do
(jidentifier :: Result Value) <- lift parseCheckJsonBody (jidentifier :: Result Value) <- parseCheckJsonBody
case jidentifier of case jidentifier of
Error _ -> return Nothing Error _ -> return Nothing
Success val -> return $ parseMaybe parseEmail val Success val -> return $ parseMaybe parseEmail val
@ -502,43 +505,44 @@ registerHelper allowUsername dest = do
case eidentifier of case eidentifier of
Left route -> loginErrorMessageI dest route Left route -> loginErrorMessageI dest route
Right identifier -> do Right identifier -> do
mecreds <- lift $ getEmailCreds identifier mecreds <- getEmailCreds identifier
registerCreds <- registerCreds <-
case mecreds of case mecreds of
Just (EmailCreds lid _ _ (Just key) email) -> return $ Just (lid, key, email) Just (EmailCreds lid _ _ (Just key) email) -> return $ Just (lid, key, email)
Just (EmailCreds lid _ _ Nothing email) -> do Just (EmailCreds lid _ _ Nothing email) -> do
key <- liftIO $ randomKey y key <- liftIO $ randomKey y
lift $ setVerifyKey lid key setVerifyKey lid key
return $ Just (lid, key, email) return $ Just (lid, key, email)
Nothing Nothing
| allowUsername -> return Nothing | allowUsername -> return Nothing
| otherwise -> do | otherwise -> do
key <- liftIO $ randomKey y key <- liftIO $ randomKey y
lid <- lift $ addUnverified identifier key lid <- addUnverified identifier key
return $ Just (lid, key, identifier) return $ Just (lid, key, identifier)
case registerCreds of case registerCreds of
Nothing -> loginErrorMessageI dest (Msg.IdentifierNotFound identifier) Nothing -> loginErrorMessageI dest (Msg.IdentifierNotFound identifier)
Just (lid, verKey, email) -> do Just (lid, verKey, email) -> do
render <- getUrlRender render <- getUrlRender
let verUrl = render $ verifyR (toPathPiece lid) verKey tp <- getRouteToParent
lift $ sendVerifyEmail email verKey verUrl let verUrl = render $ tp $ verifyR (toPathPiece lid) verKey
lift $ confirmationEmailSentResponse identifier 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 postRegisterR = registerHelper False registerR
getForgotPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) Html getForgotPasswordR :: YesodAuthEmail master => AuthHandler master Html
getForgotPasswordR = forgotPasswordHandler getForgotPasswordR = forgotPasswordHandler
-- | Default implementation of 'forgotPasswordHandler'. -- | Default implementation of 'forgotPasswordHandler'.
-- --
-- @since 1.2.6 -- @since 1.2.6
defaultForgotPasswordHandler :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) Html defaultForgotPasswordHandler :: YesodAuthEmail master => AuthHandler master Html
defaultForgotPasswordHandler = do defaultForgotPasswordHandler = do
(widget, enctype) <- lift $ generateFormPost forgotPasswordForm (widget, enctype) <- generateFormPost forgotPasswordForm
toParent <- getRouteToParent toParent <- getRouteToParent
lift $ authLayout $ do authLayout $ do
setTitleI Msg.PasswordResetTitle setTitleI Msg.PasswordResetTitle
[whamlet| [whamlet|
<p>_{Msg.PasswordResetPrompt} <p>_{Msg.PasswordResetPrompt}
@ -569,35 +573,36 @@ defaultForgotPasswordHandler = do
fsAttrs = [("autofocus", "")] fsAttrs = [("autofocus", "")]
} }
postForgotPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) TypedContent postForgotPasswordR :: YesodAuthEmail master => AuthHandler master TypedContent
postForgotPasswordR = registerHelper True forgotPasswordR postForgotPasswordR = registerHelper True forgotPasswordR
getVerifyR :: YesodAuthEmail site getVerifyR :: YesodAuthEmail site
=> AuthEmailId site => AuthEmailId site
-> Text -> Text
-> HandlerT Auth (HandlerT site IO) TypedContent -> AuthHandler site TypedContent
getVerifyR lid key = do getVerifyR lid key = do
realKey <- lift $ getVerifyKey lid realKey <- getVerifyKey lid
memail <- lift $ getEmail lid memail <- getEmail lid
mr <- lift getMessageRender mr <- getMessageRender
case (realKey == Just key, memail) of case (realKey == Just key, memail) of
(True, Just email) -> do (True, Just email) -> do
muid <- lift $ verifyAccount lid muid <- verifyAccount lid
case muid of case muid of
Nothing -> invalidKey mr Nothing -> invalidKey mr
Just uid -> do Just uid -> do
lift $ setCreds False $ Creds "email-verify" email [("verifiedEmail", email)] -- FIXME uid? setCreds False $ Creds "email-verify" email [("verifiedEmail", email)] -- FIXME uid?
lift $ setLoginLinkKey uid setLoginLinkKey uid
let msgAv = Msg.AddressVerified let msgAv = Msg.AddressVerified
selectRep $ do selectRep $ do
provideRep $ do provideRep $ do
lift $ addMessageI "success" msgAv addMessageI "success" msgAv
fmap asHtml $ redirect setpassR tp <- getRouteToParent
fmap asHtml $ redirect $ tp setpassR
provideJsonMessage $ mr msgAv provideJsonMessage $ mr msgAv
_ -> invalidKey mr _ -> invalidKey mr
where where
msgIk = Msg.InvalidKey msgIk = Msg.InvalidKey
invalidKey mr = messageJson401 (mr msgIk) $ lift $ authLayout $ do invalidKey mr = messageJson401 (mr msgIk) $ authLayout $ do
setTitleI msgIk setTitleI msgIk
[whamlet| [whamlet|
$newline never $newline never
@ -612,16 +617,16 @@ parseCreds = withObject "creds" (\obj -> do
return (email', pass)) return (email', pass))
postLoginR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) TypedContent postLoginR :: YesodAuthEmail master => AuthHandler master TypedContent
postLoginR = do postLoginR = do
result <- lift $ runInputPostResult $ (,) result <- runInputPostResult $ (,)
<$> ireq textField "email" <$> ireq textField "email"
<*> ireq textField "password" <*> ireq textField "password"
midentifier <- case result of midentifier <- case result of
FormSuccess (iden, pass) -> return $ Just (iden, pass) FormSuccess (iden, pass) -> return $ Just (iden, pass)
_ -> do _ -> do
(creds :: Result Value) <- lift parseCheckJsonBody (creds :: Result Value) <- parseCheckJsonBody
case creds of case creds of
Error _ -> return Nothing Error _ -> return Nothing
Success val -> return $ parseMaybe parseCreds val Success val -> return $ parseMaybe parseCreds val
@ -629,18 +634,18 @@ postLoginR = do
case midentifier of case midentifier of
Nothing -> loginErrorMessageI LoginR Msg.NoIdentifierProvided Nothing -> loginErrorMessageI LoginR Msg.NoIdentifierProvided
Just (identifier, pass) -> do Just (identifier, pass) -> do
mecreds <- lift $ getEmailCreds identifier mecreds <- getEmailCreds identifier
maid <- maid <-
case ( mecreds >>= emailCredsAuthId case ( mecreds >>= emailCredsAuthId
, emailCredsEmail <$> mecreds , emailCredsEmail <$> mecreds
, emailCredsStatus <$> mecreds , emailCredsStatus <$> mecreds
) of ) of
(Just aid, Just email', Just True) -> do (Just aid, Just email', Just True) -> do
mrealpass <- lift $ getPassword aid mrealpass <- getPassword aid
case mrealpass of case mrealpass of
Nothing -> return Nothing Nothing -> return Nothing
Just realpass -> do Just realpass -> do
passValid <- lift $ verifyPassword pass realpass passValid <- verifyPassword pass realpass
return $ if passValid return $ if passValid
then Just email' then Just email'
else Nothing else Nothing
@ -648,7 +653,7 @@ postLoginR = do
let isEmail = Text.Email.Validate.isValid $ encodeUtf8 identifier let isEmail = Text.Email.Validate.isValid $ encodeUtf8 identifier
case maid of case maid of
Just email' -> Just email' ->
lift $ setCredsRedirect $ Creds setCredsRedirect $ Creds
(if isEmail then "email" else "username") (if isEmail then "email" else "username")
email' email'
[("verifiedEmail", email')] [("verifiedEmail", email')]
@ -658,26 +663,26 @@ postLoginR = do
then Msg.InvalidEmailPass then Msg.InvalidEmailPass
else Msg.InvalidUsernamePass else Msg.InvalidUsernamePass
getPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) TypedContent getPasswordR :: YesodAuthEmail master => AuthHandler master TypedContent
getPasswordR = do getPasswordR = do
maid <- lift maybeAuthId maid <- maybeAuthId
case maid of case maid of
Nothing -> loginErrorMessageI LoginR Msg.BadSetPass Nothing -> loginErrorMessageI LoginR Msg.BadSetPass
Just _ -> do Just _ -> do
needOld <- maybe (return True) (lift . needOldPassword) maid needOld <- maybe (return True) needOldPassword maid
setPasswordHandler needOld setPasswordHandler needOld
-- | Default implementation of 'setPasswordHandler'. -- | Default implementation of 'setPasswordHandler'.
-- --
-- @since 1.2.6 -- @since 1.2.6
defaultSetPasswordHandler :: YesodAuthEmail master => Bool -> HandlerT Auth (HandlerT master IO) TypedContent defaultSetPasswordHandler :: YesodAuthEmail master => Bool -> AuthHandler master TypedContent
defaultSetPasswordHandler needOld = do defaultSetPasswordHandler needOld = do
messageRender <- lift getMessageRender messageRender <- getMessageRender
toParent <- getRouteToParent toParent <- getRouteToParent
selectRep $ do selectRep $ do
provideJsonMessage $ messageRender Msg.SetPass provideJsonMessage $ messageRender Msg.SetPass
provideRep $ lift $ authLayout $ do provideRep $ authLayout $ do
(widget, enctype) <- liftWidgetT $ generateFormPost setPasswordForm (widget, enctype) <- generateFormPost setPasswordForm
setTitleI Msg.SetPassTitle setTitleI Msg.SetPassTitle
[whamlet| [whamlet|
<h3>_{Msg.SetPass} <h3>_{Msg.SetPass}
@ -749,10 +754,10 @@ parsePassword = withObject "password" (\obj -> do
curr <- obj .:? "current" curr <- obj .:? "current"
return (email', pass, curr)) return (email', pass, curr))
postPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) TypedContent postPasswordR :: YesodAuthEmail master => AuthHandler master TypedContent
postPasswordR = do postPasswordR = do
maid <- lift maybeAuthId maid <- maybeAuthId
(creds :: Result Value) <- lift parseCheckJsonBody (creds :: Result Value) <- parseCheckJsonBody
let jcreds = case creds of let jcreds = case creds of
Error _ -> Nothing Error _ -> Nothing
Success val -> parseMaybe parsePassword val Success val -> parseMaybe parsePassword val
@ -761,26 +766,26 @@ postPasswordR = do
Nothing -> loginErrorMessageI LoginR Msg.BadSetPass Nothing -> loginErrorMessageI LoginR Msg.BadSetPass
Just aid -> do Just aid -> do
tm <- getRouteToParent tm <- getRouteToParent
needOld <- lift $ needOldPassword aid needOld <- needOldPassword aid
if not needOld then confirmPassword aid tm jcreds else do 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 let fcurrent = case res of
FormSuccess currentPass -> Just currentPass FormSuccess currentPass -> Just currentPass
_ -> Nothing _ -> Nothing
let current = if doJsonParsing let current = if doJsonParsing
then getThird jcreds then getThird jcreds
else fcurrent else fcurrent
mrealpass <- lift $ getPassword aid mrealpass <- getPassword aid
case (mrealpass, current) of case (mrealpass, current) of
(Nothing, _) -> (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) -> (_, Nothing) ->
loginErrorMessageI LoginR Msg.BadSetPass loginErrorMessageI LoginR Msg.BadSetPass
(Just realpass, Just current') -> do (Just realpass, Just current') -> do
passValid <- lift $ verifyPassword current' realpass passValid <- verifyPassword current' realpass
if passValid if passValid
then confirmPassword aid tm jcreds 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 where
msgOk = Msg.PassUpdated msgOk = Msg.PassUpdated
@ -789,7 +794,7 @@ postPasswordR = do
getNewConfirm (Just (a,b,_)) = Just (a,b) getNewConfirm (Just (a,b,_)) = Just (a,b)
getNewConfirm _ = Nothing getNewConfirm _ = Nothing
confirmPassword aid tm jcreds = do confirmPassword aid tm jcreds = do
res <- lift $ runInputPostResult $ (,) res <- runInputPostResult $ (,)
<$> ireq textField "new" <$> ireq textField "new"
<*> ireq textField "confirm" <*> ireq textField "confirm"
let creds = if (isJust jcreds) let creds = if (isJust jcreds)
@ -803,21 +808,21 @@ postPasswordR = do
if new /= confirm if new /= confirm
then loginErrorMessageI setpassR Msg.PassMismatch then loginErrorMessageI setpassR Msg.PassMismatch
else do else do
isSecure <- lift $ checkPasswordSecurity aid new isSecure <- checkPasswordSecurity aid new
case isSecure of case isSecure of
Left e -> lift $ loginErrorMessage (tm setpassR) e Left e -> loginErrorMessage (tm setpassR) e
Right () -> do Right () -> do
salted <- lift $ hashAndSaltPassword new salted <- hashAndSaltPassword new
y <- lift $ do y <- do
setPassword aid salted setPassword aid salted
deleteSession loginLinkKey deleteSession loginLinkKey
addMessageI "success" msgOk addMessageI "success" msgOk
getYesod getYesod
mr <- lift getMessageRender mr <- getMessageRender
selectRep $ do selectRep $ do
provideRep $ provideRep $
fmap asHtml $ lift $ redirect $ afterPasswordRoute y fmap asHtml $ redirect $ afterPasswordRoute y
provideJsonMessage (mr msgOk) provideJsonMessage (mr msgOk)
saltLength :: Int 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 FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
-- | Use an email address as an identifier via Google's login system. -- | Use an email address as an identifier via Google's login system.
-- --
-- Note that this is a replacement for "Yesod.Auth.GoogleEmail", which depends -- 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), AuthRoute, Creds (Creds),
Route (PluginR), YesodAuth, Route (PluginR), YesodAuth,
runHttpRequest, setCredsRedirect, runHttpRequest, setCredsRedirect,
logoutDest) logoutDest, AuthHandler)
import qualified Yesod.Auth.Message as Msg import qualified Yesod.Auth.Message as Msg
import Yesod.Core (HandlerSite, HandlerT, MonadHandler, import Yesod.Core (HandlerSite, MonadHandler,
TypedContent, getRouteToParent, TypedContent, getRouteToParent,
getUrlRender, invalidArgs, getUrlRender, invalidArgs,
lift, liftIO, lookupGetParam, liftIO, lookupGetParam,
lookupSession, notFound, redirect, lookupSession, notFound, redirect,
setSession, whamlet, (.:), setSession, whamlet, (.:),
addMessage, getYesod, addMessage, getYesod,
toHtml) toHtml, liftSubHandler)
import Blaze.ByteString.Builder (fromByteString, toByteString) 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.Parser (json')
import Data.Aeson.Types (FromJSON (parseJSON), parseEither, import Data.Aeson.Types (FromJSON (parseJSON), parseEither,
parseMaybe, withObject, withText) parseMaybe, withObject, withText)
import Data.Conduit (($$+-), ($$)) import Data.Conduit
import Data.Conduit.Attoparsec (sinkParser) import Data.Conduit.Attoparsec (sinkParser)
import qualified Data.HashMap.Strict as M import qualified Data.HashMap.Strict as M
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
@ -187,10 +189,10 @@ authPlugin storeToken clientID clientSecret =
dispatch :: YesodAuth site dispatch :: YesodAuth site
=> Text => Text
-> [Text] -> [Text]
-> HandlerT Auth (HandlerT site IO) TypedContent -> AuthHandler site TypedContent
dispatch "GET" ["forward"] = do dispatch "GET" ["forward"] = do
tm <- getRouteToParent tm <- getRouteToParent
lift (getDest tm) >>= redirect getDest tm >>= redirect
dispatch "GET" ["complete"] = do dispatch "GET" ["complete"] = do
mstate <- lookupGetParam "state" mstate <- lookupGetParam "state"
@ -207,30 +209,27 @@ authPlugin storeToken clientID clientSecret =
case merr of case merr of
Nothing -> invalidArgs ["Missing code paramter"] Nothing -> invalidArgs ["Missing code paramter"]
Just err -> do Just err -> do
master <- lift getYesod master <- getYesod
let msg = let msg =
case err of case err of
"access_denied" -> "Access denied" "access_denied" -> "Access denied"
_ -> "Unknown error occurred: " `T.append` err _ -> "Unknown error occurred: " `T.append` err
addMessage "error" $ toHtml msg addMessage "error" $ toHtml msg
lift $ redirect $ logoutDest master redirect $ logoutDest master
Just c -> return c Just c -> return c
render <- getUrlRender render <- getUrlRender
tm <- getRouteToParent
req' <- liftIO $ req' <- liftIO $
#if MIN_VERSION_http_client(0,4,30)
HTTP.parseUrlThrow 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 "https://accounts.google.com/o/oauth2/token" -- FIXME don't hardcode, use: https://accounts.google.com/.well-known/openid-configuration
let req = let req =
urlEncodedBody urlEncodedBody
[ ("code", encodeUtf8 code) [ ("code", encodeUtf8 code)
, ("client_id", encodeUtf8 clientID) , ("client_id", encodeUtf8 clientID)
, ("client_secret", encodeUtf8 clientSecret) , ("client_secret", encodeUtf8 clientSecret)
, ("redirect_uri", encodeUtf8 $ render complete) , ("redirect_uri", encodeUtf8 $ render $ tm complete)
, ("grant_type", "authorization_code") , ("grant_type", "authorization_code")
] ]
req' req'
@ -257,38 +256,31 @@ authPlugin storeToken clientID clientSecret =
[e] -> return e [e] -> return e
[] -> error "No account email" [] -> error "No account email"
x -> error $ "Too many account emails: " ++ show x x -> error $ "Too many account emails: " ++ show x
lift $ setCredsRedirect $ Creds pid email $ allPersonInfo personValue setCredsRedirect $ Creds pid email $ allPersonInfo personValue
dispatch _ _ = notFound dispatch _ _ = notFound
makeHttpRequest makeHttpRequest :: Request -> AuthHandler site A.Value
:: (YesodAuth site) makeHttpRequest req =
=> Request liftSubHandler $ runHttpRequest req $ \res ->
-> HandlerT Auth (HandlerT site IO) A.Value runConduit $ bodyReaderSource (responseBody res) .| sinkParser json'
makeHttpRequest req = lift $
runHttpRequest req $ \res -> bodyReaderSource (responseBody res) $$ sinkParser json'
-- | Allows to fetch information about a user from Google's API. -- | Allows to fetch information about a user from Google's API.
-- In case of parsing error returns 'Nothing'. -- In case of parsing error returns 'Nothing'.
-- Will throw 'HttpException' in case of network problems or error response code. -- Will throw 'HttpException' in case of network problems or error response code.
-- --
-- @since 1.4.3 -- @since 1.4.3
getPerson :: Manager -> Token -> HandlerT site IO (Maybe Person) getPerson :: Manager -> Token -> AuthHandler site (Maybe Person)
getPerson manager token = parseMaybe parseJSON <$> (do getPerson manager token = liftSubHandler $ parseMaybe parseJSON <$> (do
req <- personValueRequest token req <- personValueRequest token
res <- http req manager res <- http req manager
responseBody res $$+- sinkParser json' runConduit $ responseBody res .| sinkParser json'
) )
personValueRequest :: MonadIO m => Token -> m Request personValueRequest :: MonadIO m => Token -> m Request
personValueRequest token = do personValueRequest token = do
req2' <- liftIO $ req2' <- liftIO
#if MIN_VERSION_http_client(0,4,30) $ HTTP.parseUrlThrow "https://www.googleapis.com/plus/v1/people/me"
HTTP.parseUrlThrow
#else
HTTP.parseUrl
#endif
"https://www.googleapis.com/plus/v1/people/me"
return req2' return req2'
{ requestHeaders = { requestHeaders =
[ ("Authorization", encodeUtf8 $ "Bearer " `mappend` accessToken token) [ ("Authorization", encodeUtf8 $ "Bearer " `mappend` accessToken token)

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

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

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

@ -3,6 +3,7 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RankNTypes #-}
{-# LANGUAGE GADTs #-}
module Yesod.Auth.OpenId module Yesod.Auth.OpenId
( authOpenId ( authOpenId
, forwardUrl , forwardUrl
@ -19,7 +20,7 @@ import Yesod.Form
import Yesod.Core import Yesod.Core
import Data.Text (Text, isPrefixOf) import Data.Text (Text, isPrefixOf)
import qualified Yesod.Auth.Message as Msg import qualified Yesod.Auth.Message as Msg
import Control.Exception.Lifted (SomeException, try) import UnliftIO.Exception (tryAny)
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import qualified Data.Text as T import qualified Data.Text as T
@ -36,7 +37,10 @@ authOpenId idType extensionFields =
AuthPlugin "openid" dispatch login AuthPlugin "openid" dispatch login
where where
complete = PluginR "openid" ["complete"] complete = PluginR "openid" ["complete"]
name :: Text
name = "openid_identifier" name = "openid_identifier"
login tm = do login tm = do
ident <- newIdent ident <- newIdent
-- FIXME this is a hack to get GHC 7.6's type checker to allow the -- 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 id="#{ident}" type="text" name="#{name}" value="http://">
<input type="submit" value="_{Msg.LoginOpenID}"> <input type="submit" value="_{Msg.LoginOpenID}">
|] |]
dispatch :: Text -> [Text] -> AuthHandler master TypedContent
dispatch "GET" ["forward"] = do dispatch "GET" ["forward"] = do
roid <- lift $ runInputGet $ iopt textField name roid <- runInputGet $ iopt textField name
case roid of case roid of
Just oid -> do Just oid -> do
tm <- getRouteToParent
render <- getUrlRender render <- getUrlRender
let complete' = render complete let complete' = render $ tm complete
master <- lift getYesod manager <- authHttpManager
eres <- lift $ try $ OpenId.getForwardUrl oid complete' Nothing extensionFields (authHttpManager master) eres <- tryAny $ OpenId.getForwardUrl oid complete' Nothing extensionFields manager
case eres of case eres of
Left err -> do Left err -> loginErrorMessage (tm LoginR) $ T.pack $ show err
tm <- getRouteToParent
lift $ loginErrorMessage (tm LoginR) $ T.pack $
show (err :: SomeException)
Right x -> redirect x Right x -> redirect x
Nothing -> loginErrorMessageI LoginR Msg.NoOpenID Nothing -> loginErrorMessageI LoginR Msg.NoOpenID
dispatch "GET" ["complete", ""] = dispatch "GET" ["complete"] -- compatibility issues dispatch "GET" ["complete", ""] = dispatch "GET" ["complete"] -- compatibility issues
@ -84,14 +88,13 @@ $newline never
completeHelper :: IdentifierType -> [(Text, Text)] -> AuthHandler master TypedContent completeHelper :: IdentifierType -> [(Text, Text)] -> AuthHandler master TypedContent
completeHelper idType gets' = do completeHelper idType gets' = do
master <- lift getYesod manager <- authHttpManager
eres <- try $ OpenId.authenticateClaimed gets' (authHttpManager master) eres <- tryAny $ OpenId.authenticateClaimed gets' manager
either onFailure onSuccess eres either onFailure onSuccess eres
where where
onFailure err = do onFailure err = do
tm <- getRouteToParent tm <- getRouteToParent
lift $ loginErrorMessage (tm LoginR) $ T.pack $ loginErrorMessage (tm LoginR) $ T.pack $ show err
show (err :: SomeException)
onSuccess oir = do onSuccess oir = do
let claimed = let claimed =
case OpenId.oirClaimed oir of case OpenId.oirClaimed oir of
@ -105,7 +108,7 @@ completeHelper idType gets' = do
case idType of case idType of
OPLocal -> OpenId.oirOpLocal oir OPLocal -> OpenId.oirOpLocal oir
Claimed -> fromMaybe (OpenId.oirOpLocal oir) $ OpenId.oirClaimed 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 -- | The main identifier provided by the OpenID authentication plugin is the
-- \"OP-local identifier\". There is also sometimes a \"claimed\" identifier -- \"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 OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
module Yesod.Auth.Rpxnow module Yesod.Auth.Rpxnow
( authRpxnow ( authRpxnow
) where ) where
@ -17,10 +18,10 @@ import Data.Text.Encoding.Error (lenientDecode)
import Control.Arrow ((***)) import Control.Arrow ((***))
import Network.HTTP.Types (renderQuery) import Network.HTTP.Types (renderQuery)
authRpxnow :: YesodAuth m authRpxnow :: YesodAuth master
=> String -- ^ app name => String -- ^ app name
-> String -- ^ key -> String -- ^ key
-> AuthPlugin m -> AuthPlugin master
authRpxnow app apiKey = authRpxnow app apiKey =
AuthPlugin "rpxnow" dispatch login AuthPlugin "rpxnow" dispatch login
where where
@ -32,14 +33,16 @@ authRpxnow app apiKey =
$newline never $newline never
<iframe src="http://#{app}.rpxnow.com/openid/embed#{queryString}" scrolling="no" frameBorder="no" allowtransparency="true" style="width:400px;height:240px"> <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 dispatch _ [] = do
token1 <- lookupGetParams "token" token1 <- lookupGetParams "token"
token2 <- lookupPostParams "token" token2 <- lookupPostParams "token"
token <- case token1 ++ token2 of token <- case token1 ++ token2 of
[] -> invalidArgs ["token: Value not supplied"] [] -> invalidArgs ["token: Value not supplied"]
x:_ -> return $ unpack x x:_ -> return $ unpack x
master <- lift getYesod manager <- authHttpManager
Rpxnow.Identifier ident extra <- lift $ Rpxnow.authenticate apiKey token (authHttpManager master) Rpxnow.Identifier ident extra <- Rpxnow.authenticate apiKey token manager
let creds = let creds =
Creds "rpxnow" ident Creds "rpxnow" ident
$ maybe id (\x -> (:) ("verifiedEmail", x)) $ maybe id (\x -> (:) ("verifiedEmail", x))
@ -47,7 +50,7 @@ $newline never
$ maybe id (\x -> (:) ("displayName", x)) $ maybe id (\x -> (:) ("displayName", x))
(fmap pack $ getDisplayName $ map (unpack *** unpack) extra) (fmap pack $ getDisplayName $ map (unpack *** unpack) extra)
[] []
lift $ setCredsRedirect creds setCredsRedirect creds
dispatch _ _ = notFound dispatch _ _ = notFound
-- | Get some form of a display name. -- | Get some form of a display name.

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

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

9
yesod-bin/AddHandler.hs
View File

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

15
yesod-bin/Devel.hs
View File

@ -9,17 +9,15 @@ module Devel
) where ) where
import Control.Applicative ((<|>)) import Control.Applicative ((<|>))
import UnliftIO (race_)
import Control.Concurrent (threadDelay) import Control.Concurrent (threadDelay)
import Control.Concurrent.Async (race_)
import Control.Concurrent.STM import Control.Concurrent.STM
import qualified Control.Exception.Safe as Ex import qualified UnliftIO.Exception as Ex
import Control.Monad (forever, unless, void, import Control.Monad (forever, unless, void,
when) when)
import Data.ByteString (ByteString, isInfixOf) import Data.ByteString (ByteString, isInfixOf)
import qualified Data.ByteString.Lazy as LB import qualified Data.ByteString.Lazy as LB
import Data.Conduit (($$), (=$)) import Conduit
import qualified Data.Conduit.Binary as CB
import qualified Data.Conduit.List as CL
import Data.Default.Class (def) import Data.Default.Class (def)
import Data.FileEmbed (embedFile) import Data.FileEmbed (embedFile)
import qualified Data.Map as Map import qualified Data.Map as Map
@ -368,9 +366,10 @@ devel opts passThroughArgs = do
-- process is piped to the actual stdout and stderr handles. -- process is piped to the actual stdout and stderr handles.
withProcess_ procConfig $ \p -> do withProcess_ procConfig $ \p -> do
let helper getter h = let helper getter h =
getter p runConduit
$$ CL.iterM (\(str :: ByteString) -> atomically (updateAppPort str buildStarted appPortVar)) $ getter p
=$ CB.sinkHandle h .| iterMC (\(str :: ByteString) -> atomically (updateAppPort str buildStarted appPortVar))
.| sinkHandle h
race_ (helper getStdout stdout) (helper getStderr stderr) race_ (helper getStdout stdout) (helper getStderr stderr)
-- Run the inner action with a TVar which will be set to True -- 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 #-} {-# LANGUAGE OverloadedStrings #-}
module HsFile (mkHsFile) where module HsFile (mkHsFile) where
import Text.ProjectTemplate (createTemplate) import Text.ProjectTemplate (createTemplate)
import Data.Conduit import Conduit
( ($$), (=$), awaitForever)
import Data.Conduit.Filesystem (sourceDirectory)
import Control.Monad.Trans.Resource (runResourceT)
import qualified Data.Conduit.List as CL
import qualified Data.ByteString as BS import qualified Data.ByteString as BS
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
import Data.String (fromString) import Data.String (fromString)
mkHsFile :: IO () mkHsFile :: IO ()
mkHsFile = runResourceT $ sourceDirectory "." mkHsFile = runConduitRes
$$ readIt $ sourceDirectory "."
=$ createTemplate .| readIt
=$ awaitForever (liftIO . BS.putStr) .| createTemplate
.| mapM_C (liftIO . BS.putStr)
where where
-- Reads a filepath from upstream and dumps a pair of (filepath, filecontents) -- 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 #-} {-# LANGUAGE RecordWildCards #-}
module Main (main) where module Main (main) where
import Control.Monad (unless)
import Data.Monoid import Data.Monoid
import Data.Version (showVersion) import Data.Version (showVersion)
import Options.Applicative import Options.Applicative
import System.Environment (getEnvironment) import System.Exit (exitFailure)
import System.Exit (ExitCode (ExitSuccess), exitWith, exitFailure)
import System.Process (rawSystem)
import AddHandler (addHandler) import AddHandler (addHandler)
import Devel (DevelOpts (..), devel, develSignal) import Devel (DevelOpts (..), devel, develSignal)
import Keter (keter) import Keter (keter)
import Options (injectDefaults) import Options (injectDefaults)
import qualified Paths_yesod_bin import qualified Paths_yesod_bin
import System.IO (hPutStrLn, stderr)
import HsFile (mkHsFile) 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) data CabalPgm = Cabal | CabalDev deriving (Show, Eq)
@ -91,17 +72,16 @@ main = do
c -> c c -> c
}) })
] optParser' ] optParser'
let cabal = rawSystem' (cabalCommand o)
case optCommand o of case optCommand o of
Init _ -> initErrorMsg Init _ -> initErrorMsg
HsFiles -> mkHsFile HsFiles -> mkHsFile
Configure -> cabal ["configure"] Configure -> cabalErrorMsg
Build es -> touch' >> cabal ("build":es) Build _ -> cabalErrorMsg
Touch -> touch' Touch -> cabalErrorMsg
Keter{..} -> keter (cabalCommand o) _keterNoRebuild _keterNoCopyTo _keterBuildArgs Keter{..} -> keter (cabalCommand o) _keterNoRebuild _keterNoCopyTo _keterBuildArgs
Version -> putStrLn ("yesod-bin version: " ++ showVersion Paths_yesod_bin.version) Version -> putStrLn ("yesod-bin version: " ++ showVersion Paths_yesod_bin.version)
AddHandler{..} -> addHandler addHandlerRoute addHandlerPattern addHandlerMethods AddHandler{..} -> addHandler addHandlerRoute addHandlerPattern addHandlerMethods
Test -> cabalTest cabal Test -> cabalErrorMsg
Devel{..} -> devel DevelOpts Devel{..} -> devel DevelOpts
{ verbose = optVerbose o { verbose = optVerbose o
, successHook = develSuccessHook , successHook = develSuccessHook
@ -113,19 +93,6 @@ main = do
} develExtraArgs } develExtraArgs
DevelSignal -> develSignal DevelSignal -> develSignal
where 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 initErrorMsg = do
mapM_ putStrLn mapM_ putStrLn
[ "The init command has been removed." [ "The init command has been removed."
@ -136,6 +103,13 @@ main = do
] ]
exitFailure 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' :: ParserInfo Options
optParser' = info (helper <*> optParser) ( fullDesc <> header "Yesod Web Framework command line utility" ) optParser' = info (helper <*> optParser) ( fullDesc <> header "Yesod Web Framework command line utility" )
@ -148,17 +122,17 @@ optParser = Options
<> command "hsfiles" (info (pure HsFiles) <> command "hsfiles" (info (pure HsFiles)
(progDesc "Create a hsfiles file for the current folder")) (progDesc "Create a hsfiles file for the current folder"))
<> command "configure" (info (pure Configure) <> command "configure" (info (pure Configure)
(progDesc "Configure a project for building")) (progDesc "DEPRECATED"))
<> command "build" (info (helper <*> (Build <$> extraCabalArgs)) <> command "build" (info (helper <*> (Build <$> extraCabalArgs))
(progDesc $ "Build project (performs TH dependency analysis)" ++ windowsWarning)) (progDesc "DEPRECATED"))
<> command "touch" (info (pure Touch) <> 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) <> command "devel" (info (helper <*> develOptions)
(progDesc "Run project with the devel server")) (progDesc "Run project with the devel server"))
<> command "devel-signal" (info (helper <*> pure DevelSignal) <> command "devel-signal" (info (helper <*> pure DevelSignal)
(progDesc "Used internally by the devel command")) (progDesc "Used internally by the devel command"))
<> command "test" (info (pure Test) <> command "test" (info (pure Test)
(progDesc "Build and run the integration tests")) (progDesc "DEPRECATED"))
<> command "add-handler" (info (helper <*> addHandlerOptions) <> command "add-handler" (info (helper <*> addHandlerOptions)
(progDesc ("Add a new handler and module to the project." (progDesc ("Add a new handler and module to the project."
++ " Interactively asks for input if you do not specify arguments."))) ++ " Interactively asks for input if you do not specify arguments.")))
@ -217,10 +191,3 @@ addHandlerOptions = AddHandler
-- | Optional @String@ argument -- | Optional @String@ argument
optStr :: Mod OptionFields (Maybe String) -> Parser (Maybe String) optStr :: Mod OptionFields (Maybe String) -> Parser (Maybe String)
optStr m = option (Just <$> str) $ value Nothing <> m 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 name: yesod-bin
version: 1.5.3 version: 1.6.0
license: MIT license: MIT
license-file: LICENSE license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com> author: Michael Snoyman <michael@snoyman.com>
@ -48,17 +48,16 @@ executable yesod
, fsnotify >= 0.0 && < 0.3 , fsnotify >= 0.0 && < 0.3
, split >= 0.2 && < 0.3 , split >= 0.2 && < 0.3
, file-embed , file-embed
, conduit >= 1.2 , conduit >= 1.3
, conduit-extra >= 1.2.2 , conduit-extra >= 1.3
, resourcet >= 0.3 && < 1.2 , resourcet >= 1.2
, base64-bytestring , base64-bytestring
, lifted-base
, http-reverse-proxy >= 0.4 , http-reverse-proxy >= 0.4
, network >= 2.5 , network >= 2.5
, http-client-tls , http-client-tls
, http-client >= 0.4.7 , http-client >= 0.4.7
, project-template >= 0.1.1 , project-template >= 0.1.1
, safe-exceptions , unliftio
, say , say
, stm , stm
, transformers , transformers
@ -69,13 +68,11 @@ executable yesod
, data-default-class , data-default-class
, streaming-commons , streaming-commons
, warp-tls >= 3.0.1 , warp-tls >= 3.0.1
, async , unliftio
, deepseq
ghc-options: -Wall -threaded -rtsopts ghc-options: -Wall -threaded -rtsopts
main-is: main.hs main-is: main.hs
other-modules: Devel other-modules: Devel
Build
Keter Keter
AddHandler AddHandler
Paths_yesod_bin 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 ## 1.4.37.3
* Improve error message when request body is too large [#1477](https://github.com/yesodweb/yesod/pull/1477) * 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 -- * Logging
, defaultMakeLogger , defaultMakeLogger
, defaultMessageLoggerSource , defaultMessageLoggerSource
, defaultShouldLog
, defaultShouldLogIO , defaultShouldLogIO
, formatLogMessage , formatLogMessage
, LogLevel (..) , LogLevel (..)
@ -67,11 +66,9 @@ module Yesod.Core
-- * JS loaders -- * JS loaders
, ScriptLoadPosition (..) , ScriptLoadPosition (..)
, BottomOfHeadAsync , BottomOfHeadAsync
-- * Subsites -- * Generalizing type classes
, MonadHandler (..) , MonadHandler (..)
, MonadWidget (..) , MonadWidget (..)
, getRouteToParent
, defaultLayoutSub
-- * Approot -- * Approot
, guessApproot , guessApproot
, guessApprootOr , guessApprootOr
@ -95,8 +92,7 @@ module Yesod.Core
, module Text.Blaze.Html , module Text.Blaze.Html
, MonadTrans (..) , MonadTrans (..)
, MonadIO (..) , MonadIO (..)
, MonadBase (..) , MonadUnliftIO (..)
, MonadBaseControl
, MonadResource (..) , MonadResource (..)
, MonadLogger , MonadLogger
-- * Commonly referenced functions/datatypes -- * Commonly referenced functions/datatypes
@ -143,9 +139,7 @@ import qualified Yesod.Core.Internal.Run
import qualified Paths_yesod_core import qualified Paths_yesod_core
import Data.Version (showVersion) import Data.Version (showVersion)
import Yesod.Routes.Class import Yesod.Routes.Class
import Control.Monad.IO.Class (MonadIO (..)) import UnliftIO (MonadIO (..), MonadUnliftIO (..))
import Control.Monad.Base (MonadBase (..))
import Control.Monad.Trans.Control (MonadBaseControl (..))
import Control.Monad.Trans.Resource (MonadResource (..)) import Control.Monad.Trans.Resource (MonadResource (..))
import Yesod.Core.Internal.LiteApp import Yesod.Core.Internal.LiteApp
@ -185,14 +179,6 @@ maybeAuthorized r isWrite = do
x <- isAuthorized r isWrite x <- isAuthorized r isWrite
return $ if x == Authorized then Just r else Nothing 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 :: Integral a => a -> String
showIntegral x = show (fromIntegral x :: Integer) 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 class YesodBreadcrumbs site where
-- | Returns the title and the parent resource, if available. If you return -- | Returns the title and the parent resource, if available. If you return
-- a 'Nothing', then this is considered a top-level page. -- 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, -- | Gets the title of the current page and the hierarchy of parent pages,
-- along with their respective titles. -- 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 breadcrumbs = do
x <- getCurrentRoute x <- getCurrentRoute
case x of case x of

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

@ -6,46 +6,47 @@
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
module Yesod.Core.Class.Dispatch where module Yesod.Core.Class.Dispatch where
import Yesod.Routes.Class
import qualified Network.Wai as W import qualified Network.Wai as W
import Yesod.Core.Types import Yesod.Core.Types
import Yesod.Core.Content import Yesod.Core.Content (ToTypedContent (..))
import Yesod.Core.Handler (sendWaiApplication, stripHandlerT) import Yesod.Core.Handler (sendWaiApplication)
import Yesod.Core.Class.Yesod import Yesod.Core.Class.Yesod
import Yesod.Core.Class.Handler
-- | This class is automatically instantiated when you use the template haskell -- | This class is automatically instantiated when you use the template haskell
-- mkYesod function. You should never need to deal with it directly. -- mkYesod function. You should never need to deal with it directly.
class Yesod site => YesodDispatch site where class Yesod site => YesodDispatch site where
yesodDispatch :: YesodRunnerEnv site -> W.Application yesodDispatch :: YesodRunnerEnv site -> W.Application
class YesodSubDispatch sub m where class YesodSubDispatch sub master where
yesodSubDispatch :: YesodSubRunnerEnv sub (HandlerSite m) m yesodSubDispatch :: YesodSubRunnerEnv sub master -> W.Application
-> W.Application
instance YesodSubDispatch WaiSubsite master where instance YesodSubDispatch WaiSubsite master where
yesodSubDispatch YesodSubRunnerEnv {..} = app yesodSubDispatch YesodSubRunnerEnv {..} = app
where where
WaiSubsite app = ysreGetSub $ yreSite ysreParentEnv WaiSubsite app = ysreGetSub $ yreSite ysreParentEnv
instance YesodSubDispatch WaiSubsiteWithAuth (HandlerT master IO) where instance YesodSubDispatch WaiSubsiteWithAuth master where
yesodSubDispatch YesodSubRunnerEnv {..} req = yesodSubDispatch YesodSubRunnerEnv {..} req =
ysreParentRunner base ysreParentEnv (fmap ysreToParentRoute route) req ysreParentRunner handlert ysreParentEnv (fmap ysreToParentRoute route) req
where where
base = stripHandlerT handlert ysreGetSub ysreToParentRoute route
route = Just $ WaiSubsiteWithAuthRoute (W.pathInfo req) [] route = Just $ WaiSubsiteWithAuthRoute (W.pathInfo req) []
WaiSubsiteWithAuth set = ysreGetSub $ yreSite $ ysreParentEnv WaiSubsiteWithAuth set = ysreGetSub $ yreSite $ ysreParentEnv
handlert = sendWaiApplication $ set handlert = sendWaiApplication set
-- | A helper function for creating YesodSubDispatch instances, used by the subHelper
-- internal generated code. This function has been exported since 1.4.11. :: ToTypedContent content
-- It promotes a subsite handler to a wai application. => SubHandlerFor child master content
subHelper :: Monad m -- NOTE: This is incredibly similar in type signature to yesodRunner, should probably be pointed out/explained. -> YesodSubRunnerEnv child master
=> HandlerT child (HandlerT parent m) TypedContent -> Maybe (Route child)
-> YesodSubRunnerEnv child parent (HandlerT parent m) -> W.Application
-> Maybe (Route child) subHelper (SubHandlerFor f) YesodSubRunnerEnv {..} mroute =
-> W.Application ysreParentRunner handler ysreParentEnv (fmap ysreToParentRoute mroute)
subHelper handlert YesodSubRunnerEnv {..} route =
ysreParentRunner base ysreParentEnv (fmap ysreToParentRoute route)
where 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 FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} -- Because of ErrorT
module Yesod.Core.Class.Handler module Yesod.Core.Class.Handler
( MonadHandler (..) ( MonadHandler (..)
, MonadWidget (..) , MonadWidget (..)
, liftHandlerT
, liftWidgetT
) where ) where
import Yesod.Core.Types import Yesod.Core.Types
import Control.Monad (liftM) import Control.Monad.Logger (MonadLogger)
import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Resource (MonadResource)
import Control.Monad.Trans.Resource (MonadResource, MonadResourceBase)
import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Class (lift)
#if __GLASGOW_HASKELL__ < 710 #if __GLASGOW_HASKELL__ < 710
import Data.Monoid (Monoid, mempty) import Data.Monoid (Monoid)
#endif #endif
import Data.Conduit.Internal (Pipe, ConduitM) import Data.Conduit.Internal (Pipe, ConduitM)
import Control.Monad.Trans.Identity ( IdentityT) import Control.Monad.Trans.Identity ( IdentityT)
import Control.Monad.Trans.List ( ListT ) import Control.Monad.Trans.List ( ListT )
import Control.Monad.Trans.Maybe ( MaybeT ) 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 ) import Control.Monad.Trans.Except ( ExceptT )
#endif
import Control.Monad.Trans.Reader ( ReaderT ) import Control.Monad.Trans.Reader ( ReaderT )
import Control.Monad.Trans.State ( StateT ) import Control.Monad.Trans.State ( StateT )
import Control.Monad.Trans.Writer ( WriterT ) 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.State.Strict as Strict ( StateT )
import qualified Control.Monad.Trans.Writer.Strict as Strict ( WriterT ) 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 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 () liftHandlerT :: MonadHandler m => HandlerFor (HandlerSite m) a -> m a
replaceToParent hd = hd { handlerToParent = const () } liftHandlerT = liftHandler
{-# DEPRECATED liftHandlerT "Use liftHandler instead" #-}
instance MonadResourceBase m => MonadHandler (HandlerT site m) where instance MonadHandler (HandlerFor site) where
type HandlerSite (HandlerT site m) = site type HandlerSite (HandlerFor site) = site
liftHandlerT (HandlerT f) = HandlerT $ liftIO . f . replaceToParent type SubHandlerSite (HandlerFor site) = site
{-# RULES "liftHandlerT (HandlerT site IO)" liftHandlerT = id #-} liftHandler = id
{-# INLINE liftHandler #-}
liftSubHandler (SubHandlerFor f) = HandlerFor f
{-# INLINE liftSubHandler #-}
instance MonadResourceBase m => MonadHandler (WidgetT site m) where instance MonadHandler (SubHandlerFor sub master) where
type HandlerSite (WidgetT site m) = site type HandlerSite (SubHandlerFor sub master) = master
liftHandlerT (HandlerT f) = WidgetT $ liftIO . liftM (, mempty) . f . replaceToParent type SubHandlerSite (SubHandlerFor sub master) = sub
{-# RULES "liftHandlerT (WidgetT site IO)" forall f. liftHandlerT (HandlerT f) = WidgetT $ liftM (, mempty) . f #-} 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 instance MonadHandler (WidgetFor site) where
#define GOX(X, T) instance (X, MonadHandler m) => MonadHandler (T m) where type HandlerSite (T m) = HandlerSite m; liftHandlerT = lift . liftHandlerT 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(IdentityT)
GO(ListT) GO(ListT)
GO(MaybeT) GO(MaybeT)
GOX(Error e, ErrorT e)
#if MIN_VERSION_transformers(0,4,0)
GO(ExceptT e) GO(ExceptT e)
#endif
GO(ReaderT r) GO(ReaderT r)
GO(StateT s) GO(StateT s)
GOX(Monoid w, WriterT w) GOX(Monoid w, WriterT w)
@ -75,19 +95,21 @@ GO(ConduitM i o)
#undef GOX #undef GOX
class MonadHandler m => MonadWidget m where class MonadHandler m => MonadWidget m where
liftWidgetT :: WidgetT (HandlerSite m) IO a -> m a liftWidget :: WidgetFor (HandlerSite m) a -> m a
instance MonadResourceBase m => MonadWidget (WidgetT site m) where instance MonadWidget (WidgetFor site) where
liftWidgetT (WidgetT f) = WidgetT $ liftIO . f . replaceToParent liftWidget = id
{-# INLINE liftWidget #-}
#define GO(T) instance MonadWidget m => MonadWidget (T m) where liftWidgetT = lift . liftWidgetT liftWidgetT :: MonadWidget m => WidgetFor (HandlerSite m) a -> m a
#define GOX(X, T) instance (X, MonadWidget m) => MonadWidget (T m) where liftWidgetT = lift . liftWidgetT 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(IdentityT)
GO(ListT) GO(ListT)
GO(MaybeT) GO(MaybeT)
GOX(Error e, ErrorT e)
#if MIN_VERSION_transformers(0,4,0)
GO(ExceptT e) GO(ExceptT e)
#endif
GO(ReaderT r) GO(ReaderT r)
GO(StateT s) GO(StateT s)
GOX(Monoid w, WriterT w) 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 Yesod.Routes.Class
import Blaze.ByteString.Builder (Builder, toByteString) import Data.ByteString.Builder (Builder)
import Blaze.ByteString.Builder.ByteString (copyByteString) import Data.Text.Encoding (encodeUtf8Builder)
import Blaze.ByteString.Builder.Char.Utf8 (fromText, fromChar)
import Control.Arrow ((***), second) import Control.Arrow ((***), second)
import Control.Exception (bracket) import Control.Exception (bracket)
#if __GLASGOW_HASKELL__ < 710 #if __GLASGOW_HASKELL__ < 710
@ -37,9 +36,8 @@ import Data.Text.Lazy.Builder (toLazyText)
import Data.Text.Lazy.Encoding (encodeUtf8) import Data.Text.Lazy.Encoding (encodeUtf8)
import Data.Word (Word64) import Data.Word (Word64)
import Language.Haskell.TH.Syntax (Loc (..)) import Language.Haskell.TH.Syntax (Loc (..))
import Network.HTTP.Types (encodePath, renderQueryText) import Network.HTTP.Types (encodePath)
import qualified Network.Wai as W import qualified Network.Wai as W
import Data.Default (def)
import Network.Wai.Parse (lbsBackEnd, import Network.Wai.Parse (lbsBackEnd,
tempFileBackEnd) tempFileBackEnd)
import Network.Wai.Logger (ZonedDate, clockDateCacher) import Network.Wai.Logger (ZonedDate, clockDateCacher)
@ -52,13 +50,13 @@ import Text.Hamlet
import Text.Julius import Text.Julius
import qualified Web.ClientSession as CS import qualified Web.ClientSession as CS
import Web.Cookie (SetCookie (..), parseCookies, sameSiteLax, import Web.Cookie (SetCookie (..), parseCookies, sameSiteLax,
sameSiteStrict, SameSiteOption) sameSiteStrict, SameSiteOption, defaultSetCookie)
import Yesod.Core.Types import Yesod.Core.Types
import Yesod.Core.Internal.Session import Yesod.Core.Internal.Session
import Yesod.Core.Widget import Yesod.Core.Widget
import Control.Monad.Trans.Class (lift)
import Data.CaseInsensitive (CI) import Data.CaseInsensitive (CI)
import qualified Network.Wai.Request import qualified Network.Wai.Request
import Data.IORef
-- | Define settings for a Yesod applications. All methods have intelligent -- | Define settings for a Yesod applications. All methods have intelligent
-- defaults, and therefore no implementation is required. -- 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 -- | An absolute URL to the root of the application. Do not include
-- trailing slash. -- trailing slash.
-- --
-- Default value: 'ApprootRelative'. This is valid under the following -- Default value: 'guessApproot'. If you know your application root
-- conditions: -- 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. -- Note: Prior to yesod-core 1.5, the default value was 'ApprootRelative'.
--
-- * 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.
approot :: Approot site approot :: Approot site
approot = ApprootRelative approot = guessApproot
-- | Output error response pages. -- | Output error response pages.
-- --
-- Default value: 'defaultErrorHandler'. -- Default value: 'defaultErrorHandler'.
errorHandler :: ErrorResponse -> HandlerT site IO TypedContent errorHandler :: ErrorResponse -> HandlerFor site TypedContent
errorHandler = defaultErrorHandler errorHandler = defaultErrorHandler
-- | Applies some form of layout to the contents of a page. -- | 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 defaultLayout w = do
p <- widgetToPageContent w p <- widgetToPageContent w
msgs <- getMessages msgs <- getMessages
@ -103,33 +97,19 @@ class RenderRoute site => Yesod site where
^{pageBody p} ^{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 -- | Override the rendering function for a particular URL and query string
-- parameters. One use case for this is to offload static hosting to a -- parameters. One use case for this is to offload static hosting to a
-- different domain name to avoid sending cookies. -- different domain name to avoid sending cookies.
-- --
-- For backward compatibility default implementation is in terms of -- For backward compatibility default implementation is in terms of
-- 'urlRenderOverride', probably ineffective -- 'urlRenderOverride', probably ineffective
-- --
-- Since 1.4.23 -- Since 1.4.23
urlParamRenderOverride :: site urlParamRenderOverride :: site
-> Route site -> Route site
-> [(T.Text, T.Text)] -- ^ query string -> [(T.Text, T.Text)] -- ^ query string
-> Maybe Builder -> Maybe Builder
urlParamRenderOverride y route params = addParams params <$> urlRenderOverride y route urlParamRenderOverride _ _ _ = Nothing
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
-- | Determine if a request is authorized or not. -- | Determine if a request is authorized or not.
-- --
@ -138,7 +118,7 @@ class RenderRoute site => Yesod site where
-- If authentication is required, return 'AuthenticationRequired'. -- If authentication is required, return 'AuthenticationRequired'.
isAuthorized :: Route site isAuthorized :: Route site
-> Bool -- ^ is this a write request? -> Bool -- ^ is this a write request?
-> HandlerT site IO AuthResult -> HandlerFor site AuthResult
isAuthorized _ _ = return Authorized isAuthorized _ _ = return Authorized
-- | Determines whether the current request is a write request. By default, -- | 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 -- This function is used to determine if a request is authorized; see
-- 'isAuthorized'. -- 'isAuthorized'.
isWriteRequest :: Route site -> HandlerT site IO Bool isWriteRequest :: Route site -> HandlerFor site Bool
isWriteRequest _ = do isWriteRequest _ = do
wai <- waiRequest wai <- waiRequest
return $ W.requestMethod wai `notElem` return $ W.requestMethod wai `notElem`
@ -191,7 +171,7 @@ class RenderRoute site => Yesod site where
-> [(T.Text, T.Text)] -- ^ query string -> [(T.Text, T.Text)] -- ^ query string
-> Builder -> Builder
joinPath _ ar pieces' qs' = joinPath _ ar pieces' qs' =
fromText ar `mappend` encodePath pieces qs encodeUtf8Builder ar `mappend` encodePath pieces qs
where where
pieces = if null pieces' then [""] else map addDash pieces' pieces = if null pieces' then [""] else map addDash pieces'
qs = map (TE.encodeUtf8 *** go) qs' qs = map (TE.encodeUtf8 *** go) qs'
@ -214,7 +194,7 @@ class RenderRoute site => Yesod site where
addStaticContent :: Text -- ^ filename extension addStaticContent :: Text -- ^ filename extension
-> Text -- ^ mime-type -> Text -- ^ mime-type
-> L.ByteString -- ^ content -> 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 addStaticContent _ _ _ = return Nothing
-- | Maximum allowed length of the request body, in bytes. -- | 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. -- | Should we log the given log source/level combination.
-- --
-- Default: the 'defaultShouldLog' function. -- Default: the 'defaultShouldLogIO' 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.
-- --
-- Since 1.2.4 -- Since 1.2.4
shouldLogIO :: site -> LogSource -> LogLevel -> IO Bool 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 -- | A Yesod middleware, which will wrap every handler function. This
-- allows you to run code before and after a normal handler. -- 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. -- Default: the 'defaultYesodMiddleware' function.
-- --
-- Since: 1.1.6 -- 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 yesodMiddleware = defaultYesodMiddleware
-- | How to allocate an @InternalState@ for each request. -- | 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. -- primarily for wrapping up error messages for better display.
-- --
-- @since 1.4.30 -- @since 1.4.30
defaultMessageWidget :: Html -> HtmlUrl (Route site) -> WidgetT site IO () defaultMessageWidget :: Html -> HtmlUrl (Route site) -> WidgetFor site ()
defaultMessageWidget title body = do defaultMessageWidget title body = do
setTitle title setTitle title
toWidget toWidget
@ -332,7 +301,6 @@ class RenderRoute site => Yesod site where
<h1>#{title} <h1>#{title}
^{body} ^{body}
|] |]
{-# DEPRECATED urlRenderOverride "Use urlParamRenderOverride instead" #-}
-- | Default implementation of 'makeLogger'. Sends to stdout and -- | Default implementation of 'makeLogger'. Sends to stdout and
-- automatically flushes on each write. -- automatically flushes on each write.
@ -369,21 +337,14 @@ defaultMessageLoggerSource ckLoggable logger loc source level msg = do
-- above 'LevelInfo'. -- above 'LevelInfo'.
-- --
-- Since 1.4.10 -- 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 :: LogSource -> LogLevel -> IO Bool
defaultShouldLogIO a b = return $ defaultShouldLog a b defaultShouldLogIO _ level = return $ level >= LevelInfo
-- | Default implementation of 'yesodMiddleware'. Adds the response header -- | Default implementation of 'yesodMiddleware'. Adds the response header
-- \"Vary: Accept, Accept-Language\" and performs authorization checks. -- \"Vary: Accept, Accept-Language\" and performs authorization checks.
-- --
-- Since 1.2.0 -- 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 defaultYesodMiddleware handler = do
addHeader "Vary" "Accept, Accept-Language" addHeader "Vary" "Accept, Accept-Language"
authorizationCheck authorizationCheck
@ -443,8 +404,8 @@ sameSiteSession s = (fmap . fmap) secureSessionCookies
-- --
-- Since 1.4.7 -- Since 1.4.7
sslOnlyMiddleware :: Int -- ^ minutes sslOnlyMiddleware :: Int -- ^ minutes
-> HandlerT site IO res -> HandlerFor site res
-> HandlerT site IO res -> HandlerFor site res
sslOnlyMiddleware timeout handler = do sslOnlyMiddleware timeout handler = do
addHeader "Strict-Transport-Security" addHeader "Strict-Transport-Security"
$ T.pack $ concat [ "max-age=" $ T.pack $ concat [ "max-age="
@ -457,7 +418,7 @@ sslOnlyMiddleware timeout handler = do
-- 'isWriteRequest'. -- 'isWriteRequest'.
-- --
-- Since 1.2.0 -- Since 1.2.0
authorizationCheck :: Yesod site => HandlerT site IO () authorizationCheck :: Yesod site => HandlerFor site ()
authorizationCheck = getCurrentRoute >>= maybe (return ()) checkUrl authorizationCheck = getCurrentRoute >>= maybe (return ()) checkUrl
where where
checkUrl url = do checkUrl url = do
@ -481,7 +442,7 @@ authorizationCheck = getCurrentRoute >>= maybe (return ()) checkUrl
-- | Calls 'csrfCheckMiddleware' with 'isWriteRequest', 'defaultCsrfHeaderName', and 'defaultCsrfParamName' as parameters. -- | Calls 'csrfCheckMiddleware' with 'isWriteRequest', 'defaultCsrfHeaderName', and 'defaultCsrfParamName' as parameters.
-- --
-- Since 1.4.14 -- 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 = defaultCsrfCheckMiddleware handler =
csrfCheckMiddleware csrfCheckMiddleware
handler handler
@ -495,11 +456,11 @@ defaultCsrfCheckMiddleware handler =
-- For details, see the "AJAX CSRF protection" section of "Yesod.Core.Handler". -- For details, see the "AJAX CSRF protection" section of "Yesod.Core.Handler".
-- --
-- Since 1.4.14 -- Since 1.4.14
csrfCheckMiddleware :: HandlerT site IO res csrfCheckMiddleware :: HandlerFor site res
-> HandlerT site IO Bool -- ^ Whether or not to perform the CSRF check. -> HandlerFor site Bool -- ^ Whether or not to perform the CSRF check.
-> CI S8.ByteString -- ^ The header name to lookup the CSRF token from. -> CI S8.ByteString -- ^ The header name to lookup the CSRF token from.
-> Text -- ^ The POST parameter 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 csrfCheckMiddleware handler shouldCheckFn headerName paramName = do
shouldCheck <- shouldCheckFn shouldCheck <- shouldCheckFn
when shouldCheck (checkCsrfHeaderOrParam headerName paramName) 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. -- The cookie's path is set to @/@, making it valid for your whole website.
-- --
-- Since 1.4.14 -- Since 1.4.14
defaultCsrfSetCookieMiddleware :: HandlerT site IO res -> HandlerT site IO res defaultCsrfSetCookieMiddleware :: HandlerFor site res -> HandlerFor site res
defaultCsrfSetCookieMiddleware handler = setCsrfCookie >> handler defaultCsrfSetCookieMiddleware handler = setCsrfCookie >> handler
-- | Takes a 'SetCookie' and overrides its value with a CSRF token, then sets the cookie. See 'setCsrfCookieWithCookie'. -- | 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 @/@. -- 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 -- 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 csrfSetCookieMiddleware handler cookie = setCsrfCookieWithCookie cookie >> handler
-- | Calls 'defaultCsrfSetCookieMiddleware' and 'defaultCsrfCheckMiddleware'. -- | Calls 'defaultCsrfSetCookieMiddleware' and 'defaultCsrfCheckMiddleware'.
@ -540,21 +501,26 @@ csrfSetCookieMiddleware handler cookie = setCsrfCookieWithCookie cookie >> handl
-- @ -- @
-- --
-- Since 1.4.14 -- 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 defaultCsrfMiddleware = defaultCsrfSetCookieMiddleware . defaultCsrfCheckMiddleware
-- | Convert a widget to a 'PageContent'. -- | Convert a widget to a 'PageContent'.
widgetToPageContent :: Yesod site widgetToPageContent :: Yesod site
=> WidgetT site IO () => WidgetFor site ()
-> HandlerT site IO (PageContent (Route site)) -> HandlerFor site (PageContent (Route site))
widgetToPageContent w = do widgetToPageContent w = HandlerFor $ \hd -> do
master <- getYesod master <- unHandlerFor getYesod hd
hd <- HandlerT return ref <- newIORef mempty
((), GWData (Body body) (Last mTitle) scripts' stylesheets' style jscript (Head head')) <- lift $ unWidgetT w hd unWidgetFor w WidgetData
let title = maybe mempty unTitle mTitle { wdRef = ref
scripts = runUniqueList scripts' , wdHandler = hd
stylesheets = runUniqueList stylesheets' }
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 render <- getUrlRenderParams
let renderLoc x = let renderLoc x =
case x of case x of
@ -642,7 +608,7 @@ widgetToPageContent w = do
runUniqueList (UniqueList x) = nub $ x [] runUniqueList (UniqueList x) = nub $ x []
-- | The default error handler for 'errorHandler'. -- | 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 defaultErrorHandler NotFound = selectRep $ do
provideRep $ defaultLayout $ do provideRep $ defaultLayout $ do
r <- waiRequest r <- waiRequest
@ -866,7 +832,7 @@ loadClientSession key getCachedDate sessionName req = load
save date sess' = do save date sess' = do
-- We should never cache the IV! Be careful! -- We should never cache the IV! Be careful!
iv <- liftIO CS.randomIV iv <- liftIO CS.randomIV
return [AddCookie def return [AddCookie defaultSetCookie
{ setCookieName = sessionName { setCookieName = sessionName
, setCookieValue = encodeClientSession key iv date host sess' , setCookieValue = encodeClientSession key iv date host sess'
, setCookiePath = Just "/" , 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 qualified Data.ByteString.Lazy as L
import Data.Text.Lazy (Text, pack) import Data.Text.Lazy (Text, pack)
import qualified Data.Text as T 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 #if __GLASGOW_HASKELL__ < 710
import Data.Monoid (mempty) import Data.Monoid (mempty)
#endif #endif
import Text.Hamlet (Html) import Text.Hamlet (Html)
import Text.Blaze.Html.Renderer.Utf8 (renderHtmlBuilder) 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 (liftM)
import Control.Monad.Trans.Resource (ResourceT) import Control.Monad.Trans.Resource (ResourceT)
import Data.Conduit.Internal (ResumableSource (ResumableSource))
import qualified Data.Conduit.Internal as CI import qualified Data.Conduit.Internal as CI
import qualified Data.Aeson as J 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 Data.Text.Lazy.Builder (toLazyText)
import Yesod.Core.Types import Yesod.Core.Types
import Text.Lucius (Css, renderCss) import Text.Lucius (Css, renderCss)
import Text.Julius (Javascript, unJavascript) import Text.Julius (Javascript, unJavascript)
import Data.Word8 (_semicolon, _slash) import Data.Word8 (_semicolon, _slash)
import Control.Arrow (second)
-- | Zero-length enumerator. -- | Zero-length enumerator.
emptyContent :: Content emptyContent :: Content
@ -99,15 +94,15 @@ instance ToContent Content where
instance ToContent Builder where instance ToContent Builder where
toContent = flip ContentBuilder Nothing toContent = flip ContentBuilder Nothing
instance ToContent B.ByteString where 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 instance ToContent L.ByteString where
toContent = flip ContentBuilder Nothing . fromLazyByteString toContent = flip ContentBuilder Nothing . lazyByteString
instance ToContent T.Text where instance ToContent T.Text where
toContent = toContent . Blaze.fromText toContent = toContent . encodeUtf8Builder
instance ToContent Text where instance ToContent Text where
toContent = toContent . Blaze.fromLazyText toContent = toContent . foldMap encodeUtf8Builder . TL.toChunks
instance ToContent String where instance ToContent String where
toContent = toContent . Blaze.fromString toContent = toContent . stringUtf8
instance ToContent Html where instance ToContent Html where
toContent bs = ContentBuilder (renderHtmlBuilder bs) Nothing toContent bs = ContentBuilder (renderHtmlBuilder bs) Nothing
instance ToContent () where instance ToContent () where
@ -123,12 +118,12 @@ instance ToContent Javascript where
toContent = toContent . toLazyText . unJavascript toContent = toContent . toLazyText . unJavascript
instance ToFlushBuilder builder => ToContent (CI.Pipe () () builder () (ResourceT IO) ()) where 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 toContent src = ContentSource $ mapOutput toFlushBuilder src
instance ToFlushBuilder builder => ToContent (ResumableSource (ResourceT IO) builder) where instance ToFlushBuilder builder => ToContent (SealedConduitT () builder (ResourceT IO) ()) where
toContent (ResumableSource src _) = toContent src toContent (CI.SealedConduitT src) = toContent src
-- | A class for all data which can be sent in a streaming response. Note that -- | A class for all data which can be sent in a streaming response. Note that
-- for textual data, instances must use UTF-8 encoding. -- 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 class ToFlushBuilder a where toFlushBuilder :: a -> Flush Builder
instance ToFlushBuilder (Flush Builder) where toFlushBuilder = id instance ToFlushBuilder (Flush Builder) where toFlushBuilder = id
instance ToFlushBuilder Builder where toFlushBuilder = Chunk instance ToFlushBuilder Builder where toFlushBuilder = Chunk
instance ToFlushBuilder (Flush B.ByteString) where toFlushBuilder = fmap fromByteString instance ToFlushBuilder (Flush B.ByteString) where toFlushBuilder = fmap byteString
instance ToFlushBuilder B.ByteString where toFlushBuilder = Chunk . fromByteString instance ToFlushBuilder B.ByteString where toFlushBuilder = Chunk . byteString
instance ToFlushBuilder (Flush L.ByteString) where toFlushBuilder = fmap fromLazyByteString instance ToFlushBuilder (Flush L.ByteString) where toFlushBuilder = fmap lazyByteString
instance ToFlushBuilder L.ByteString where toFlushBuilder = Chunk . fromLazyByteString instance ToFlushBuilder L.ByteString where toFlushBuilder = Chunk . lazyByteString
instance ToFlushBuilder (Flush Text) where toFlushBuilder = fmap Blaze.fromLazyText instance ToFlushBuilder (Flush Text) where toFlushBuilder = fmap (foldMap encodeUtf8Builder . TL.toChunks)
instance ToFlushBuilder Text where toFlushBuilder = Chunk . Blaze.fromLazyText instance ToFlushBuilder Text where toFlushBuilder = Chunk . foldMap encodeUtf8Builder . TL.toChunks
instance ToFlushBuilder (Flush T.Text) where toFlushBuilder = fmap Blaze.fromText instance ToFlushBuilder (Flush T.Text) where toFlushBuilder = fmap encodeUtf8Builder
instance ToFlushBuilder T.Text where toFlushBuilder = Chunk . Blaze.fromText instance ToFlushBuilder T.Text where toFlushBuilder = Chunk . encodeUtf8Builder
instance ToFlushBuilder (Flush String) where toFlushBuilder = fmap Blaze.fromString instance ToFlushBuilder (Flush String) where toFlushBuilder = fmap stringUtf8
instance ToFlushBuilder String where toFlushBuilder = Chunk . Blaze.fromString instance ToFlushBuilder String where toFlushBuilder = Chunk . stringUtf8
instance ToFlushBuilder (Flush Html) where toFlushBuilder = fmap renderHtmlBuilder instance ToFlushBuilder (Flush Html) where toFlushBuilder = fmap renderHtmlBuilder
instance ToFlushBuilder Html where toFlushBuilder = Chunk . renderHtmlBuilder instance ToFlushBuilder Html where toFlushBuilder = Chunk . renderHtmlBuilder
@ -228,13 +223,13 @@ typeOctet = "application/octet-stream"
simpleContentType :: ContentType -> ContentType simpleContentType :: ContentType -> ContentType
simpleContentType = fst . B.break (== _semicolon) 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") -- For example, \"text/html; charset=utf-8\" returns ("text", "html")
contentTypeTypes :: ContentType -> (B.ByteString, B.ByteString) contentTypeTypes :: ContentType -> (B.ByteString, B.ByteString)
contentTypeTypes ct = (main, fst $ B.break (== _semicolon) (tailEmpty sub)) contentTypeTypes = second tailEmpty . B.break (== _slash) . simpleContentType
where where
tailEmpty x = if B.null x then "" else B.tail x tailEmpty x = if B.null x then "" else B.tail x
(main, sub) = B.break (== _slash) ct
instance HasContentType a => HasContentType (DontFullyEvaluate a) where instance HasContentType a => HasContentType (DontFullyEvaluate a) where
getContentType = getContentType . liftM unDontFullyEvaluate getContentType = getContentType . liftM unDontFullyEvaluate
@ -243,34 +238,18 @@ instance ToContent a => ToContent (DontFullyEvaluate a) where
toContent (DontFullyEvaluate a) = ContentDontEvaluate $ toContent a toContent (DontFullyEvaluate a) = ContentDontEvaluate $ toContent a
instance ToContent J.Value where instance ToContent J.Value where
#if MIN_VERSION_aeson(1, 0, 0)
toContent = flip ContentBuilder Nothing toContent = flip ContentBuilder Nothing
. J.fromEncoding . J.fromEncoding
. J.toEncoding . 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 instance ToContent J.Encoding where
toContent = flip ContentBuilder Nothing . J.fromEncoding toContent = flip ContentBuilder Nothing . J.fromEncoding
#endif
instance HasContentType J.Value where instance HasContentType J.Value where
getContentType _ = typeJson getContentType _ = typeJson
#if MIN_VERSION_aeson(0, 11, 0)
instance HasContentType J.Encoding where instance HasContentType J.Encoding where
getContentType _ = typeJson getContentType _ = typeJson
#endif
instance HasContentType Html where instance HasContentType Html where
getContentType _ = typeHtml getContentType _ = typeHtml
@ -307,10 +286,8 @@ instance ToTypedContent RepXml where
toTypedContent (RepXml c) = TypedContent typeXml c toTypedContent (RepXml c) = TypedContent typeXml c
instance ToTypedContent J.Value where instance ToTypedContent J.Value where
toTypedContent v = TypedContent typeJson (toContent v) toTypedContent v = TypedContent typeJson (toContent v)
#if MIN_VERSION_aeson(0, 11, 0)
instance ToTypedContent J.Encoding where instance ToTypedContent J.Encoding where
toTypedContent e = TypedContent typeJson (toContent e) toTypedContent e = TypedContent typeJson (toContent e)
#endif
instance ToTypedContent Html where instance ToTypedContent Html where
toTypedContent h = TypedContent typeHtml (toContent h) toTypedContent h = TypedContent typeHtml (toContent h)
instance ToTypedContent T.Text where instance ToTypedContent T.Text where

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

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

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

@ -27,6 +27,7 @@
module Yesod.Core.Handler module Yesod.Core.Handler
( -- * Handler monad ( -- * Handler monad
HandlerT HandlerT
, HandlerFor
-- ** Read information from handler -- ** Read information from handler
, getYesod , getYesod
, getsYesod , getsYesod
@ -146,6 +147,10 @@ module Yesod.Core.Handler
, setMessage , setMessage
, setMessageI , setMessageI
, getMessage , getMessage
-- * Subsites
, getSubYesod
, getRouteToParent
, getSubCurrentRoute
-- * Helpers for specific content -- * Helpers for specific content
-- ** Hamlet -- ** Hamlet
, hamletToRepHtml , hamletToRepHtml
@ -161,7 +166,6 @@ module Yesod.Core.Handler
-- * Per-request caching -- * Per-request caching
, cached , cached
, cachedBy , cachedBy
, stripHandlerT
-- * AJAX CSRF protection -- * AJAX CSRF protection
-- $ajaxCSRFOverview -- $ajaxCSRFOverview
@ -193,13 +197,14 @@ import Control.Applicative ((<$>))
import Data.Monoid (mempty, mappend) import Data.Monoid (mempty, mappend)
#endif #endif
import Control.Applicative ((<|>)) import Control.Applicative ((<|>))
import qualified Data.CaseInsensitive as CI
import Control.Exception (evaluate, SomeException, throwIO) import Control.Exception (evaluate, SomeException, throwIO)
import Control.Exception.Lifted (handle) import Control.Exception (handle)
import Control.Monad (void, liftM, unless) import Control.Monad (void, liftM, unless)
import qualified Control.Monad.Trans.Writer as Writer 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.HTTP.Types as H
import qualified Network.Wai as W import qualified Network.Wai as W
@ -228,40 +233,41 @@ import Data.Monoid (Endo (..))
import Data.Text (Text) import Data.Text (Text)
import qualified Network.Wai.Parse as NWP import qualified Network.Wai.Parse as NWP
import Text.Shakespeare.I18N (RenderMessage (..)) 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.Content (ToTypedContent (..), simpleContentType, contentTypeTypes, HasContentType (..), ToContent (..), ToFlushBuilder (..))
import Yesod.Core.Internal.Util (formatRFC1123) import Yesod.Core.Internal.Util (formatRFC1123)
import Text.Blaze.Html (preEscapedToHtml, toHtml) 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.Maybe (listToMaybe, mapMaybe)
import Data.Typeable (Typeable) import Data.Typeable (Typeable)
import Web.PathPieces (PathPiece(..)) import Web.PathPieces (PathPiece(..))
import Yesod.Core.Class.Handler import Yesod.Core.Class.Handler
import Yesod.Core.Types import Yesod.Core.Types
import Yesod.Routes.Class (Route) import Yesod.Routes.Class (Route)
import Blaze.ByteString.Builder (Builder) import Data.ByteString.Builder (Builder)
import Safe (headMay) import Safe (headMay)
import Data.CaseInsensitive (CI, original) import Data.CaseInsensitive (CI, original)
import qualified Data.Conduit.List as CL import qualified Data.Conduit.List as CL
import Control.Monad.Trans.Resource (MonadResource, InternalState, runResourceT, withInternalState, getInternalState, liftResourceT, resourceForkIO) import Control.Monad.Trans.Resource (MonadResource, InternalState, runResourceT, withInternalState, getInternalState, liftResourceT, resourceForkIO)
import qualified System.PosixCompat.Files as PC import qualified System.PosixCompat.Files as PC
import Control.Monad.Trans.Control (control, MonadBaseControl) import Data.Conduit (ConduitT, transPipe, Flush (Flush), yield, Void)
import Data.Conduit (Source, transPipe, Flush (Flush), yield, Producer, Sink)
import qualified Yesod.Core.TypeCache as Cache import qualified Yesod.Core.TypeCache as Cache
import qualified Data.Word8 as W8 import qualified Data.Word8 as W8
import qualified Data.Foldable as Fold import qualified Data.Foldable as Fold
import Data.Default
import Control.Monad.Logger (MonadLogger, logWarnS) import Control.Monad.Logger (MonadLogger, logWarnS)
type HandlerT site (m :: * -> *) = HandlerFor site
{-# DEPRECATED HandlerT "Use HandlerFor directly" #-}
get :: MonadHandler m => m GHState get :: MonadHandler m => m GHState
get = liftHandlerT $ HandlerT $ I.readIORef . handlerState get = liftHandler $ HandlerFor $ I.readIORef . handlerState
put :: MonadHandler m => GHState -> m () 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 :: 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 :: MonadHandler m => Endo [Header] -> m ()
tell hs = modify $ \g -> g { ghsHeaders = ghsHeaders g `mappend` hs } tell hs = modify $ \g -> g { ghsHeaders = ghsHeaders g `mappend` hs }
@ -273,14 +279,14 @@ hcError :: MonadHandler m => ErrorResponse -> m a
hcError = handlerError . HCError hcError = handlerError . HCError
getRequest :: MonadHandler m => m YesodRequest getRequest :: MonadHandler m => m YesodRequest
getRequest = liftHandlerT $ HandlerT $ return . handlerRequest getRequest = liftHandler $ HandlerFor $ return . handlerRequest
runRequestBody :: MonadHandler m => m RequestBodyContents runRequestBody :: MonadHandler m => m RequestBodyContents
runRequestBody = do runRequestBody = do
HandlerData HandlerData
{ handlerEnv = RunHandlerEnv {..} { handlerEnv = RunHandlerEnv {..}
, handlerRequest = req , handlerRequest = req
} <- liftHandlerT $ HandlerT return } <- liftHandler $ HandlerFor return
let len = W.requestBodyLength $ reqWaiRequest req let len = W.requestBodyLength $ reqWaiRequest req
upload = rheUpload len upload = rheUpload len
x <- get x <- get
@ -319,8 +325,8 @@ rbHelper' backend mkFI req =
| otherwise = a' | otherwise = a'
go = decodeUtf8With lenientDecode go = decodeUtf8With lenientDecode
askHandlerEnv :: MonadHandler m => m (RunHandlerEnv (HandlerSite m)) askHandlerEnv :: MonadHandler m => m (RunHandlerEnv (HandlerSite m) (HandlerSite m))
askHandlerEnv = liftHandlerT $ HandlerT $ return . handlerEnv askHandlerEnv = liftHandler $ HandlerFor $ return . handlerEnv
-- | Get the master site application argument. -- | Get the master site application argument.
getYesod :: MonadHandler m => m (HandlerSite m) getYesod :: MonadHandler m => m (HandlerSite m)
@ -396,9 +402,9 @@ getCurrentRoute = rheRoute <$> askHandlerEnv
-- This allows the inner 'GHandler' to outlive the outer -- This allows the inner 'GHandler' to outlive the outer
-- 'GHandler' (e.g., on the @forkIO@ example above, a response -- 'GHandler' (e.g., on the @forkIO@ example above, a response
-- may be sent to the client without killing the new thread). -- 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 = handlerToIO =
HandlerT $ \oldHandlerData -> do HandlerFor $ \oldHandlerData -> do
-- Take just the bits we need from oldHandlerData. -- Take just the bits we need from oldHandlerData.
let newReq = oldReq { reqWaiRequest = newWaiReq } let newReq = oldReq { reqWaiRequest = newWaiReq }
where where
@ -420,7 +426,7 @@ handlerToIO =
liftIO $ evaluate (newReq `seq` oldEnv `seq` newState `seq` ()) liftIO $ evaluate (newReq `seq` oldEnv `seq` newState `seq` ())
-- Return GHandler running function. -- Return GHandler running function.
return $ \(HandlerT f) -> return $ \(HandlerFor f) ->
liftIO $ liftIO $
runResourceT $ withInternalState $ \resState -> do runResourceT $ withInternalState $ \resState -> do
-- The state IORef needs to be created here, otherwise it -- The state IORef needs to be created here, otherwise it
@ -431,7 +437,6 @@ handlerToIO =
{ handlerRequest = newReq { handlerRequest = newReq
, handlerEnv = oldEnv , handlerEnv = oldEnv
, handlerState = newStateIORef , handlerState = newStateIORef
, handlerToParent = const ()
, handlerResource = resState , handlerResource = resState
} }
liftIO (f newHandlerData) liftIO (f newHandlerData)
@ -442,12 +447,13 @@ handlerToIO =
-- for correctness and efficiency -- for correctness and efficiency
-- --
-- @since 1.2.8 -- @since 1.2.8
forkHandler :: (SomeException -> HandlerT site IO ()) -- ^ error handler forkHandler :: (SomeException -> HandlerFor site ()) -- ^ error handler
-> HandlerT site IO () -> HandlerFor site ()
-> HandlerT site IO () -> HandlerFor site ()
forkHandler onErr handler = do forkHandler onErr handler = do
yesRunner <- handlerToIO yesRunner <- handlerToIO
void $ liftResourceT $ resourceForkIO $ yesRunner $ handle onErr handler void $ liftResourceT $ resourceForkIO $
liftIO $ handle (yesRunner . onErr) (yesRunner handler)
-- | Redirect to the given route. -- | Redirect to the given route.
-- HTTP status code 303 for HTTP 1.1 clients and 302 for HTTP 1.0 -- 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 -- @since 1.4.18
sendStatusJSON :: (MonadHandler m, ToJSON c) => H.Status -> c -> m a sendStatusJSON :: (MonadHandler m, ToJSON c) => H.Status -> c -> m a
#if MIN_VERSION_aeson(0, 11, 0)
sendStatusJSON s v = sendResponseStatus s (toEncoding v) 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 -- | Send a 201 "Created" response with the given route as the Location
-- response header. -- response header.
@ -668,10 +670,10 @@ sendWaiApplication = handlerError . HCWaiApp
-- --
-- @since 1.2.16 -- @since 1.2.16
sendRawResponseNoConduit sendRawResponseNoConduit
:: (MonadHandler m, MonadBaseControl IO m) :: (MonadHandler m, MonadUnliftIO m)
=> (IO S8.ByteString -> (S8.ByteString -> IO ()) -> m ()) => (IO S8.ByteString -> (S8.ByteString -> IO ()) -> m ())
-> m a -> m a
sendRawResponseNoConduit raw = control $ \runInIO -> sendRawResponseNoConduit raw = withRunInIO $ \runInIO ->
liftIO $ throwIO $ HCWai $ flip W.responseRaw fallback liftIO $ throwIO $ HCWai $ flip W.responseRaw fallback
$ \src sink -> void $ runInIO (raw src sink) $ \src sink -> void $ runInIO (raw src sink)
where where
@ -683,10 +685,11 @@ sendRawResponseNoConduit raw = control $ \runInIO ->
-- Warp). -- Warp).
-- --
-- @since 1.2.7 -- @since 1.2.7
sendRawResponse :: (MonadHandler m, MonadBaseControl IO m) sendRawResponse
=> (Source IO S8.ByteString -> Sink S8.ByteString IO () -> m ()) :: (MonadHandler m, MonadUnliftIO m)
-> m a => (ConduitT () S8.ByteString IO () -> ConduitT S8.ByteString Void IO () -> m ())
sendRawResponse raw = control $ \runInIO -> -> m a
sendRawResponse raw = withRunInIO $ \runInIO ->
liftIO $ throwIO $ HCWai $ flip W.responseRaw fallback liftIO $ throwIO $ HCWai $ flip W.responseRaw fallback
$ \src sink -> void $ runInIO $ raw (src' src) (CL.mapM_ sink) $ \src sink -> void $ runInIO $ raw (src' src) (CL.mapM_ sink)
where where
@ -783,7 +786,7 @@ setLanguage = setSession langKey
-- --
-- @since 1.2.0 -- @since 1.2.0
addHeader :: MonadHandler m => Text -> Text -> m () 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. -- | Deprecated synonym for addHeader.
setHeader :: MonadHandler m => Text -> Text -> m () setHeader :: MonadHandler m => Text -> Text -> m ()
@ -801,10 +804,10 @@ replaceOrAddHeader :: MonadHandler m => Text -> Text -> m ()
replaceOrAddHeader a b = replaceOrAddHeader a b =
modify $ \g -> g {ghsHeaders = replaceHeader (ghsHeaders g)} modify $ \g -> g {ghsHeaders = replaceHeader (ghsHeaders g)}
where where
repHeader = Header (encodeUtf8 a) (encodeUtf8 b) repHeader = Header (CI.mk $ encodeUtf8 a) (encodeUtf8 b)
sameHeaderName :: Header -> Header -> Bool 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 sameHeaderName _ _ = False
replaceIndividualHeader :: [Header] -> [Header] replaceIndividualHeader :: [Header] -> [Header]
@ -1341,7 +1344,7 @@ provideRepType ct handler =
-- | Stream in the raw request body without any parsing. -- | Stream in the raw request body without any parsing.
-- --
-- @since 1.2.0 -- @since 1.2.0
rawRequestBody :: MonadHandler m => Source m S.ByteString rawRequestBody :: MonadHandler m => ConduitT i S.ByteString m ()
rawRequestBody = do rawRequestBody = do
req <- lift waiRequest req <- lift waiRequest
let loop = do let loop = do
@ -1353,7 +1356,7 @@ rawRequestBody = do
-- | Stream the data from the file. Since Yesod 1.2, this has been generalized -- | Stream the data from the file. Since Yesod 1.2, this has been generalized
-- to work in any @MonadResource@. -- 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 fileSource = transPipe liftResourceT . fileSourceRaw
-- | Provide a pure value for the response body. -- | Provide a pure value for the response body.
@ -1374,78 +1377,59 @@ respond ct = return . TypedContent ct . toContent
-- --
-- @since 1.2.0 -- @since 1.2.0
respondSource :: ContentType respondSource :: ContentType
-> Source (HandlerT site IO) (Flush Builder) -> ConduitT () (Flush Builder) (HandlerFor site) ()
-> HandlerT site IO TypedContent -> HandlerFor site TypedContent
respondSource ctype src = HandlerT $ \hd -> respondSource ctype src = HandlerFor $ \hd ->
-- Note that this implementation relies on the fact that the ResourceT -- Note that this implementation relies on the fact that the ResourceT
-- environment provided by the server is the same one used in HandlerT. -- environment provided by the server is the same one used in HandlerT.
-- This is a safe assumption assuming the HandlerT is run correctly. -- This is a safe assumption assuming the HandlerT is run correctly.
return $ TypedContent ctype $ ContentSource 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 -- | In a streaming response, send a single chunk of data. This function works
-- on most datatypes, such as @ByteString@ and @Html@. -- on most datatypes, such as @ByteString@ and @Html@.
-- --
-- @since 1.2.0 -- @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 sendChunk = yield . toFlushBuilder
-- | In a streaming response, send a flush command, causing all buffered data -- | In a streaming response, send a flush command, causing all buffered data
-- to be immediately sent to the client. -- to be immediately sent to the client.
-- --
-- @since 1.2.0 -- @since 1.2.0
sendFlush :: Monad m => Producer m (Flush Builder) sendFlush :: Monad m => ConduitT i (Flush Builder) m ()
sendFlush = yield Flush sendFlush = yield Flush
-- | Type-specialized version of 'sendChunk' for strict @ByteString@s. -- | Type-specialized version of 'sendChunk' for strict @ByteString@s.
-- --
-- @since 1.2.0 -- @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 sendChunkBS = sendChunk
-- | Type-specialized version of 'sendChunk' for lazy @ByteString@s. -- | Type-specialized version of 'sendChunk' for lazy @ByteString@s.
-- --
-- @since 1.2.0 -- @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 sendChunkLBS = sendChunk
-- | Type-specialized version of 'sendChunk' for strict @Text@s. -- | Type-specialized version of 'sendChunk' for strict @Text@s.
-- --
-- @since 1.2.0 -- @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 sendChunkText = sendChunk
-- | Type-specialized version of 'sendChunk' for lazy @Text@s. -- | Type-specialized version of 'sendChunk' for lazy @Text@s.
-- --
-- @since 1.2.0 -- @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 sendChunkLazyText = sendChunk
-- | Type-specialized version of 'sendChunk' for @Html@s. -- | Type-specialized version of 'sendChunk' for @Html@s.
-- --
-- @since 1.2.0 -- @since 1.2.0
sendChunkHtml :: Monad m => Html -> Producer m (Flush Builder) sendChunkHtml :: Monad m => Html -> ConduitT i (Flush Builder) m ()
sendChunkHtml = sendChunk 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 -- $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. -- 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. -- 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 -- @since 1.4.14
setCsrfCookie :: MonadHandler m => m () 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. -- | 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 formatValue maybeText = case maybeText of
Nothing -> "(which is not currently set)" Nothing -> "(which is not currently set)"
Just t -> T.concat ["(which has the current, incorrect value: '", t, "')"] 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 mempty = LiteApp $ \_ _ -> Nothing
mappend (LiteApp x) (LiteApp y) = LiteApp $ \m ps -> x m ps <|> y m ps mappend (LiteApp x) (LiteApp y) = LiteApp $ \m ps -> x m ps <|> y m ps
type LiteHandler = HandlerT LiteApp IO type LiteHandler = HandlerFor LiteApp
type LiteWidget = WidgetT LiteApp IO type LiteWidget = WidgetFor LiteApp
liteApp :: Writer LiteApp () -> LiteApp liteApp :: Writer LiteApp () -> LiteApp
liteApp = execWriter 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 qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8With, decodeUtf8) import Data.Text.Encoding (decodeUtf8With, decodeUtf8)
import Data.Text.Encoding.Error (lenientDecode) import Data.Text.Encoding.Error (lenientDecode)
import Data.Conduit import Conduit
import Data.Conduit.List (sourceList)
import Data.Conduit.Binary (sourceFile, sinkFile)
import Data.Word (Word8, Word64) import Data.Word (Word8, Word64)
import Control.Monad.Trans.Resource (runResourceT, ResourceT)
import Control.Exception (throwIO) import Control.Exception (throwIO)
import Control.Monad ((<=<), liftM) import Control.Monad ((<=<), liftM)
import Yesod.Core.Types import Yesod.Core.Types
import qualified Data.Map as Map import qualified Data.Map as Map
import Data.IORef import Data.IORef
import qualified System.Random.MWC as MWC
import Control.Monad.Primitive (PrimMonad, PrimState)
import qualified Data.Vector.Storable as V import qualified Data.Vector.Storable as V
import Data.ByteString.Internal (ByteString (PS)) import Data.ByteString.Internal (ByteString (PS))
import qualified Data.Word8 as Word8 import qualified Data.Word8 as Word8
@ -83,7 +78,7 @@ parseWaiRequest :: W.Request
-> SessionMap -> SessionMap
-> Bool -> Bool
-> Maybe Word64 -- ^ max body size -> Maybe Word64 -- ^ max body size
-> Either (IO YesodRequest) (MWC.GenIO -> IO YesodRequest) -> Either (IO YesodRequest) (IO Int -> IO YesodRequest)
parseWaiRequest env session useToken mmaxBodySize = parseWaiRequest env session useToken mmaxBodySize =
-- In most cases, we won't need to generate any random values. Therefore, -- 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 -- 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 -- | Generate a random String of alphanumerical characters
-- (a-z, A-Z, and 0-9) of the given length using the given -- (a-z, A-Z, and 0-9) of the given length using the given
-- random number generator. -- random number generator.
randomString :: PrimMonad m => Int -> MWC.Gen (PrimState m) -> m Text randomString :: Monad m => Int -> m Int -> m Text
randomString len gen = randomString len gen =
liftM (decodeUtf8 . fromByteVector) $ V.replicateM len asciiChar liftM (decodeUtf8 . fromByteVector) $ V.replicateM len asciiChar
where where
asciiChar = liftM toAscii $ MWC.uniformR (0, 61) gen asciiChar =
let loop = do
toAscii i x <- gen
| i < 26 = i + Word8._A let y = fromIntegral $ x `mod` 64
| i < 52 = i + Word8._a - 26 case () of
| otherwise = i + Word8._0 - 52 ()
| 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.Vector Word8 -> ByteString
fromByteVector v = fromByteVector v =
@ -183,13 +183,13 @@ fromByteVector v =
mkFileInfoLBS :: Text -> Text -> L.ByteString -> FileInfo mkFileInfoLBS :: Text -> Text -> L.ByteString -> FileInfo
mkFileInfoLBS name ct lbs = 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 :: 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 :: Text -> Text -> ConduitT () ByteString (ResourceT IO) () -> FileInfo
mkFileInfoSource name ct src = FileInfo name ct src (\dst -> runResourceT $ src $$ sinkFile dst) mkFileInfoSource name ct src = FileInfo name ct src (\dst -> runConduitRes $ src .| sinkFile dst)
tokenKey :: IsString a => a tokenKey :: IsString a => a
tokenKey = "_TOKEN" 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 Data.ByteString (ByteString)
import qualified Data.ByteString as S import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as BL
import Data.CaseInsensitive (CI) import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI
import Network.Wai import Network.Wai
import Control.Monad (mplus) import Control.Monad (mplus)
import Control.Monad.Trans.Resource (runInternalState, InternalState) import Control.Monad.Trans.Resource (runInternalState, InternalState)
import Network.Wai.Internal import Network.Wai.Internal
#if !MIN_VERSION_base(4, 6, 0)
import Prelude hiding (catch)
#endif
import Web.Cookie (renderSetCookie) import Web.Cookie (renderSetCookie)
import Yesod.Core.Content import Yesod.Core.Content
import Yesod.Core.Types import Yesod.Core.Types
import qualified Network.HTTP.Types as H import qualified Network.HTTP.Types as H
import qualified Data.Text as T import qualified Data.Text as T
import Control.Exception (SomeException, handle) import Control.Exception (SomeException, handle)
import Blaze.ByteString.Builder (fromLazyByteString, import Data.ByteString.Builder (lazyByteString, toLazyByteString)
toLazyByteString, toByteString)
import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy as L
import qualified Data.Map as Map import qualified Data.Map as Map
import Yesod.Core.Internal.Request (tokenKey) import Yesod.Core.Internal.Request (tokenKey)
import Data.Text.Encoding (encodeUtf8) import Data.Text.Encoding (encodeUtf8)
import Data.Conduit (Flush (..), ($$), transPipe) import Conduit
import qualified Data.Conduit.List as CL
yarToResponse :: YesodResponse yarToResponse :: YesodResponse
-> (SessionMap -> IO [Header]) -- ^ save session -> (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 sendResponse $ ResponseBuilder s hs' b
go (ContentFile fp p) = sendResponse $ ResponseFile s finalHeaders fp p go (ContentFile fp p) = sendResponse $ ResponseFile s finalHeaders fp p
go (ContentSource body) = sendResponse $ responseStream s finalHeaders go (ContentSource body) = sendResponse $ responseStream s finalHeaders
$ \sendChunk flush -> $ \sendChunk flush -> runConduit $
transPipe (`runInternalState` is) body transPipe (`runInternalState` is) body
$$ CL.mapM_ (\mchunk -> .| mapM_C (\mchunk ->
case mchunk of case mchunk of
Flush -> flush Flush -> flush
Chunk builder -> sendChunk builder) Chunk builder -> sendChunk builder)
@ -86,7 +81,7 @@ defaultStatus = H.mkStatus (-1) "INVALID DEFAULT STATUS"
headerToPair :: Header headerToPair :: Header
-> (CI ByteString, ByteString) -> (CI ByteString, ByteString)
headerToPair (AddCookie sc) = headerToPair (AddCookie sc) =
("Set-Cookie", toByteString $ renderSetCookie sc) ("Set-Cookie", BL.toStrict $ toLazyByteString $ renderSetCookie sc)
headerToPair (DeleteCookie key path) = headerToPair (DeleteCookie key path) =
( "Set-Cookie" ( "Set-Cookie"
, S.concat , S.concat
@ -96,14 +91,14 @@ headerToPair (DeleteCookie key path) =
, "; expires=Thu, 01-Jan-1970 00:00:00 GMT" , "; 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 :: Content -> IO (Either ErrorResponse Content)
evaluateContent (ContentBuilder b mlen) = handle f $ do evaluateContent (ContentBuilder b mlen) = handle f $ do
let lbs = toLazyByteString b let lbs = toLazyByteString b
len = L.length lbs len = L.length lbs
mlen' = mlen `mplus` Just (fromIntegral len) mlen' = mlen `mplus` Just (fromIntegral len)
len `seq` return (Right $ ContentBuilder (fromLazyByteString lbs) mlen') len `seq` return (Right $ ContentBuilder (lazyByteString lbs) mlen')
where where
f :: SomeException -> IO (Either ErrorResponse Content) f :: SomeException -> IO (Either ErrorResponse Content)
f = return . Left . InternalError . T.pack . show 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 ((<$>)) import Control.Applicative ((<$>))
#endif #endif
import Yesod.Core.Internal.Response import Yesod.Core.Internal.Response
import Blaze.ByteString.Builder (toByteString) import Data.ByteString.Builder (toLazyByteString)
import Control.Exception (fromException, evaluate) import qualified Data.ByteString.Lazy as BL
import qualified Control.Exception as E
import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Logger (LogLevel (LevelError), LogSource, import Control.Monad.Logger (LogLevel (LevelError), LogSource,
liftLoc) liftLoc)
@ -44,46 +43,29 @@ import Yesod.Core.Internal.Request (parseWaiRequest,
import Yesod.Core.Internal.Util (getCurrentMaxExpiresRFC1123) import Yesod.Core.Internal.Util (getCurrentMaxExpiresRFC1123)
import Yesod.Routes.Class (Route, renderRoute) import Yesod.Routes.Class (Route, renderRoute)
import Control.DeepSeq (($!!), NFData) import Control.DeepSeq (($!!), NFData)
import UnliftIO.Exception
-- | Catch all synchronous exceptions, ignoring asynchronous -- | Convert a synchronous exception into an ErrorResponse
-- exceptions. toErrorHandler :: SomeException -> IO ErrorResponse
-- toErrorHandler e0 = handleAny errFromShow $
-- 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 $
case fromException e0 of case fromException e0 of
Just (HCError x) -> evaluate $!! x Just (HCError x) -> evaluate $!! x
_ _ -> errFromShow e0
| isAsyncException e0 -> E.throwIO e0
| otherwise -> errFromShow e0
-- | Generate an @ErrorResponse@ based on the shown version of the exception -- | Generate an @ErrorResponse@ based on the shown version of the exception
errFromShow :: E.SomeException -> IO ErrorResponse errFromShow :: SomeException -> IO ErrorResponse
errFromShow x = evaluate $!! InternalError $! T.pack $! show x 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 -- | Do a basic run of a handler, getting some contents and the final
-- @GHState@. The @GHState@ unfortunately may contain some impure -- @GHState@. The @GHState@ unfortunately may contain some impure
-- exceptions, but all other synchronous exceptions will be caught and -- exceptions, but all other synchronous exceptions will be caught and
-- represented by the @HandlerContents@. -- represented by the @HandlerContents@.
basicRunHandler :: ToTypedContent c basicRunHandler :: ToTypedContent c
=> RunHandlerEnv site => RunHandlerEnv site site
-> HandlerT site IO c -> HandlerFor site c
-> YesodRequest -> YesodRequest
-> InternalState -> InternalState
-> IO (GHState, HandlerContents) -> IO (GHState, HandlerContents)
@ -94,9 +76,9 @@ basicRunHandler rhe handler yreq resState = do
-- Run the handler itself, capturing any runtime exceptions and -- Run the handler itself, capturing any runtime exceptions and
-- converting them into a @HandlerContents@ -- converting them into a @HandlerContents@
contents' <- catchSync contents' <- catchAny
(do (do
res <- unHandlerT handler (hd istate) res <- unHandlerFor handler (hd istate)
tc <- evaluate (toTypedContent res) tc <- evaluate (toTypedContent res)
-- Success! Wrap it up in an @HCContent@ -- Success! Wrap it up in an @HCContent@
return (HCContent defaultStatus tc)) return (HCContent defaultStatus tc))
@ -121,12 +103,11 @@ basicRunHandler rhe handler yreq resState = do
{ handlerRequest = yreq { handlerRequest = yreq
, handlerEnv = rhe , handlerEnv = rhe
, handlerState = istate , handlerState = istate
, handlerToParent = const ()
, handlerResource = resState , handlerResource = resState
} }
-- | Convert an @ErrorResponse@ into a @YesodResponse@ -- | Convert an @ErrorResponse@ into a @YesodResponse@
handleError :: RunHandlerEnv site handleError :: RunHandlerEnv sub site
-> YesodRequest -> YesodRequest
-> InternalState -> InternalState
-> Map.Map Text S8.ByteString -> Map.Map Text S8.ByteString
@ -135,7 +116,7 @@ handleError :: RunHandlerEnv site
-> IO YesodResponse -> IO YesodResponse
handleError rhe yreq resState finalSession headers e0 = do handleError rhe yreq resState finalSession headers e0 = do
-- Find any evil hidden impure exceptions -- Find any evil hidden impure exceptions
e <- (evaluate $!! e0) `catchSync` errFromShow e <- (evaluate $!! e0) `catchAny` errFromShow
-- Generate a response, leveraging the updated session and -- Generate a response, leveraging the updated session and
-- response headers -- response headers
@ -200,15 +181,15 @@ evalFallback :: (Monoid w, NFData w)
=> HandlerContents => HandlerContents
-> w -> w
-> IO (w, HandlerContents) -> IO (w, HandlerContents)
evalFallback contents val = catchSync evalFallback contents val = catchAny
(fmap (, contents) (evaluate $!! val)) (fmap (, contents) (evaluate $!! val))
(fmap ((mempty, ) . HCError) . toErrorHandler) (fmap ((mempty, ) . HCError) . toErrorHandler)
-- | Function used internally by Yesod in the process of converting a -- | Function used internally by Yesod in the process of converting a
-- 'HandlerT' into an 'Application'. Should not be needed by users. -- 'HandlerT' into an 'Application'. Should not be needed by users.
runHandler :: ToTypedContent c runHandler :: ToTypedContent c
=> RunHandlerEnv site => RunHandlerEnv site site
-> HandlerT site IO c -> HandlerFor site c
-> YesodApp -> YesodApp
runHandler rhe@RunHandlerEnv {..} handler yreq = withInternalState $ \resState -> do runHandler rhe@RunHandlerEnv {..} handler yreq = withInternalState $ \resState -> do
-- Get the raw state and original contents -- Get the raw state and original contents
@ -218,13 +199,14 @@ runHandler rhe@RunHandlerEnv {..} handler yreq = withInternalState $ \resState -
-- propagating exceptions into the contents -- propagating exceptions into the contents
(finalSession, contents1) <- evalFallback contents0 (ghsSession state) (finalSession, contents1) <- evalFallback contents0 (ghsSession state)
(headers, contents2) <- evalFallback contents1 (appEndo (ghsHeaders state) []) (headers, contents2) <- evalFallback contents1 (appEndo (ghsHeaders state) [])
contents3 <- (evaluate contents2) `catchAny` (fmap HCError . toErrorHandler)
-- Convert the HandlerContents into the final YesodResponse -- Convert the HandlerContents into the final YesodResponse
handleContents handleContents
(handleError rhe yreq resState finalSession headers) (handleError rhe yreq resState finalSession headers)
finalSession finalSession
headers headers
contents2 contents3
safeEh :: (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) safeEh :: (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
-> ErrorResponse -> ErrorResponse
@ -263,7 +245,7 @@ runFakeHandler :: (Yesod site, MonadIO m) =>
SessionMap SessionMap
-> (site -> Logger) -> (site -> Logger)
-> site -> site
-> HandlerT site IO a -> HandlerFor site a
-> m (Either ErrorResponse a) -> m (Either ErrorResponse a)
runFakeHandler fakeSessionMap logger site handler = liftIO $ do runFakeHandler fakeSessionMap logger site handler = liftIO $ do
ret <- I.newIORef (Left $ InternalError "runFakeHandler: no result") ret <- I.newIORef (Left $ InternalError "runFakeHandler: no result")
@ -273,6 +255,8 @@ runFakeHandler fakeSessionMap logger site handler = liftIO $ do
RunHandlerEnv RunHandlerEnv
{ rheRender = yesodRender site $ resolveApproot site fakeWaiRequest { rheRender = yesodRender site $ resolveApproot site fakeWaiRequest
, rheRoute = Nothing , rheRoute = Nothing
, rheRouteToMaster = id
, rheChild = site
, rheSite = site , rheSite = site
, rheUpload = fileUpload site , rheUpload = fileUpload site
, rheLog = messageLoggerSource site $ logger site , rheLog = messageLoggerSource site $ logger site
@ -322,7 +306,7 @@ runFakeHandler fakeSessionMap logger site handler = liftIO $ do
I.readIORef ret I.readIORef ret
yesodRunner :: (ToTypedContent res, Yesod site) yesodRunner :: (ToTypedContent res, Yesod site)
=> HandlerT site IO res => HandlerFor site res
-> YesodRunnerEnv site -> YesodRunnerEnv site
-> Maybe (Route site) -> Maybe (Route site)
-> Application -> Application
@ -347,6 +331,8 @@ yesodRunner handler' YesodRunnerEnv {..} route req sendResponse
rheSafe = RunHandlerEnv rheSafe = RunHandlerEnv
{ rheRender = yesodRender yreSite ra { rheRender = yesodRender yreSite ra
, rheRoute = route , rheRoute = route
, rheRouteToMaster = id
, rheChild = yreSite
, rheSite = yreSite , rheSite = yreSite
, rheUpload = fileUpload yreSite , rheUpload = fileUpload yreSite
, rheLog = log' , rheLog = log'
@ -372,7 +358,7 @@ yesodRender :: Yesod y
-> [(Text, Text)] -- ^ url query string -> [(Text, Text)] -- ^ url query string
-> Text -> Text
yesodRender y ar url params = yesodRender y ar url params =
decodeUtf8With lenientDecode $ toByteString $ decodeUtf8With lenientDecode $ BL.toStrict $ toLazyByteString $
fromMaybe fromMaybe
(joinPath y ar ps (joinPath y ar ps
$ params ++ params') $ 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 qualified Network.Wai as W
import Data.ByteString.Lazy.Char8 () import Data.ByteString.Lazy.Char8 ()
#if MIN_VERSION_base(4,8,0)
import Data.List (foldl', uncons)
#else
import Data.List (foldl') import Data.List (foldl')
#endif
#if __GLASGOW_HASKELL__ < 710 #if __GLASGOW_HASKELL__ < 710
import Control.Applicative ((<$>)) import Control.Applicative ((<$>))
#endif #endif
import Control.Monad (replicateM, void) import Control.Monad (replicateM, void)
import Data.Either (partitionEithers)
import Text.Parsec (parse, many1, many, eof, try, option, sepBy1) import Text.Parsec (parse, many1, many, eof, try, option, sepBy1)
import Text.ParserCombinators.Parsec.Char (alphaNum, spaces, string, char) import Text.ParserCombinators.Parsec.Char (alphaNum, spaces, string, char)
import Yesod.Routes.TH import Yesod.Routes.TH
import Yesod.Routes.Parse import Yesod.Routes.Parse
import Yesod.Core.Types import Yesod.Core.Types
import Yesod.Core.Content
import Yesod.Core.Class.Dispatch import Yesod.Core.Class.Dispatch
import Yesod.Core.Internal.Run import Yesod.Core.Internal.Run
-- | Generates URL datatype and site function for the given 'Resource's. This -- | 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. -- 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 mkYesod :: String -- ^ name of the argument datatype
-> [ResourceTree String] -> [ResourceTree String]
-> Q [Dec] -> Q [Dec]
mkYesod name = fmap (uncurry (++)) . mkYesodGeneral name [] False return mkYesod name = fmap (uncurry (++)) . mkYesodWithParser name False return
mkYesodWith :: String {-# DEPRECATED mkYesodWith "Contexts and type variables are now parsed from the name in `mkYesod`. <https://github.com/yesodweb/yesod/pull/1366>" #-}
-> [Either String [String]] -- | 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] -> [ResourceTree String]
-> Q [Dec] -> 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 -- | 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 -- your handlers elsewhere. For example, this is the only way to break up a
-- monolithic file into smaller parts. Use this function, paired with -- monolithic file into smaller parts. Use this function, paired with
-- 'mkYesodDispatch', to do just that. -- 'mkYesodDispatch', to do just that.
mkYesodData :: String -> [ResourceTree String] -> Q [Dec] 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 :: 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] -- | Parses contexts and type arguments out of name before generating TH.
mkYesodDataGeneral name isSub res = do 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 let (name', rest, cxt) = case parse parseName "" name of
Left err -> error $ show err Left err -> error $ show err
Right a -> a Right a -> a
fst <$> mkYesodGeneral' cxt name' (fmap Left rest) isSub return res mkYesodGeneral cxt name' rest isSub f resS
where where
parseName = do parseName = do
@ -99,36 +106,25 @@ mkYesodDataGeneral name isSub res = do
-- | See 'mkYesodData'. -- | See 'mkYesodData'.
mkYesodDispatch :: String -> [ResourceTree String] -> Q [Dec] 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. -- | 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 = masterTypeSyns vs site =
[ TySynD (mkName "Handler") (fmap PlainTV vs) [ TySynD (mkName "Handler") (fmap PlainTV vs)
$ ConT ''HandlerT `AppT` site `AppT` ConT ''IO $ ConT ''HandlerFor `AppT` site
, TySynD (mkName "Widget") (fmap PlainTV vs) , 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 mkYesodGeneral :: [[String]] -- ^ Appliction context. Used in RenderRoute, RouteAttrs, and ParseRoute instances.
-- 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.
-> String -- ^ foundation type -> String -- ^ foundation type
-> [Either String [String]] -- ^ arguments for the type -> [String] -- ^ arguments for the type
-> Bool -- ^ is this a subsite -> Bool -- ^ is this a subsite
-> (Exp -> Q Exp) -- ^ unwrap handler -> (Exp -> Q Exp) -- ^ unwrap handler
-> [ResourceTree String] -> [ResourceTree String]
-> Q([Dec],[Dec]) -> Q([Dec],[Dec])
mkYesodGeneral' appCxt' namestr args isSub f resS = do mkYesodGeneral appCxt' namestr mtys isSub f resS = do
let appCxt = fmap (\(c:rest) -> let appCxt = fmap (\(c:rest) ->
#if MIN_VERSION_template_haskell(2,10,0) #if MIN_VERSION_template_haskell(2,10,0)
foldl' (\acc v -> acc `AppT` nameToType v) (ConT $ mkName c) rest 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 DataD _ _ vs _ _ -> length vs
NewtypeD _ _ vs _ _ -> length vs NewtypeD _ _ vs _ _ -> length vs
#endif #endif
TySynD _ vs _ -> length vs
_ -> 0 _ -> 0
_ -> 0 _ -> 0
_ -> return 0 _ -> return 0
let name = mkName namestr let name = mkName namestr
(mtys,_) = partitionEithers args
-- Generate as many variable names as the arity indicates -- Generate as many variable names as the arity indicates
vns <- replicateM (arity - length mtys) $ newName "t" vns <- replicateM (arity - length mtys) $ newName "t"
-- Base type (site type with variables) -- Base type (site type with variables)
let (argtypes,cxt) = (\(ns,r,cs) -> (ns ++ fmap VarT r, cs)) $ let argtypes = fmap nameToType mtys ++ fmap VarT vns
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
site = foldl' AppT (ConT name) argtypes site = foldl' AppT (ConT name) argtypes
res = map (fmap (parseType . dropBracket)) resS res = map (fmap (parseType . dropBracket)) resS
renderRouteDec <- mkRenderRouteInstance' appCxt site res renderRouteDec <- mkRenderRouteInstance appCxt site res
routeAttrsDec <- mkRouteAttrsInstance' appCxt site res routeAttrsDec <- mkRouteAttrsInstance appCxt site res
dispatchDec <- mkDispatchInstance site cxt f res dispatchDec <- mkDispatchInstance site appCxt f res
parseRoute <- mkParseRouteInstance' appCxt site res parseRoute <- mkParseRouteInstance appCxt site res
let rname = mkName $ "resources" ++ namestr let rname = mkName $ "resources" ++ namestr
eres <- lift resS eres <- lift resS
let resourcesDec = let resourcesDec =
@ -196,12 +177,6 @@ mkYesodGeneral' appCxt' namestr args isSub f resS = do
] ]
return (dataDec, dispatchDec) 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 :: (Exp -> Q Exp) -> Q Exp -> MkDispatchSettings a site b
mkMDS f rh = MkDispatchSettings mkMDS f rh = MkDispatchSettings
{ mdsRunHandler = rh { mdsRunHandler = rh
@ -242,7 +217,7 @@ mkDispatchInstance master cxt f res = do
mkYesodSubDispatch :: [ResourceTree a] -> Q Exp mkYesodSubDispatch :: [ResourceTree a] -> Q Exp
mkYesodSubDispatch res = do mkYesodSubDispatch res = do
clause' <- mkDispatchClause (mkMDS return [|subHelper . fmap toTypedContent|]) res clause' <- mkDispatchClause (mkMDS return [|subHelper|]) res
inner <- newName "inner" inner <- newName "inner"
let innerFun = FunD inner [clause'] let innerFun = FunD inner [clause']
helper <- newName "helper" 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 qualified Data.Text as T
import Data.Time (Day (ModifiedJulianDay, toModifiedJulianDay), import Data.Time (Day (ModifiedJulianDay, toModifiedJulianDay),
DiffTime, UTCTime (..), formatTime, DiffTime, UTCTime (..), formatTime,
getCurrentTime, addUTCTime) getCurrentTime, addUTCTime, defaultTimeLocale)
#if MIN_VERSION_time(1,5,0)
import Data.Time (defaultTimeLocale)
#else
import System.Locale (defaultTimeLocale)
#endif
putTime :: UTCTime -> Put putTime :: UTCTime -> Put
putTime (UTCTime d t) = putTime (UTCTime d t) =

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

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

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

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

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

@ -14,6 +14,7 @@
module Yesod.Core.Widget module Yesod.Core.Widget
( -- * Datatype ( -- * Datatype
WidgetT WidgetT
, WidgetFor
, PageContent (..) , PageContent (..)
-- * Special Hamlet quasiquoter/TH for Widgets -- * Special Hamlet quasiquoter/TH for Widgets
, whamlet , whamlet
@ -43,7 +44,6 @@ module Yesod.Core.Widget
, addScriptRemoteAttrs , addScriptRemoteAttrs
, addScriptEither , addScriptEither
-- * Subsites -- * Subsites
, widgetToParentWidget
, handlerToWidget , handlerToWidget
-- * Internal -- * Internal
, whamletFileWithSettings , whamletFileWithSettings
@ -60,8 +60,6 @@ import Yesod.Core.Handler (getMessageRender, getUrlRenderParams)
#if __GLASGOW_HASKELL__ < 710 #if __GLASGOW_HASKELL__ < 710
import Control.Applicative ((<$>)) import Control.Applicative ((<$>))
#endif #endif
import Control.Monad (liftM)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Text.Shakespeare.I18N (RenderMessage) import Text.Shakespeare.I18N (RenderMessage)
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Map as Map 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.Types
import Yesod.Core.Class.Handler import Yesod.Core.Class.Handler
type WidgetT site (m :: * -> *) = WidgetFor site
{-# DEPRECATED WidgetT "Use WidgetFor directly" #-}
preEscapedLazyText :: TL.Text -> Html preEscapedLazyText :: TL.Text -> Html
preEscapedLazyText = preEscapedToMarkup 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 toWidget x = tell $ GWData mempty mempty mempty mempty mempty (Just x) mempty
instance ToWidget site Javascript where instance ToWidget site Javascript where
toWidget x = tell $ GWData mempty mempty mempty mempty mempty (Just $ const x) mempty 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 instance (site' ~ site, a ~ ()) => ToWidget site' (WidgetFor site a) where
toWidget = liftWidgetT toWidget = liftWidget
instance ToWidget site Html where instance ToWidget site Html where
toWidget = toWidget . const toWidget = toWidget . const
-- | @since 1.4.28 -- | @since 1.4.28
@ -268,45 +269,10 @@ ihamletToHtml ih = do
return $ ih (toHtml . mrender) urender return $ ih (toHtml . mrender) urender
tell :: MonadWidget m => GWData (Route (HandlerSite m)) -> m () tell :: MonadWidget m => GWData (Route (HandlerSite m)) -> m ()
tell w = liftWidgetT $ WidgetT $ const $ return ((), w) tell = liftWidget . tellWidget
toUnique :: x -> UniqueList x toUnique :: x -> UniqueList x
toUnique = UniqueList . (:) toUnique = UniqueList . (:)
handlerToWidget :: Monad m => HandlerT site m a -> WidgetT site m a handlerToWidget :: HandlerFor site a -> WidgetFor site a
handlerToWidget (HandlerT f) = WidgetT $ liftM (, mempty) . f handlerToWidget (HandlerFor f) = WidgetFor $ f . wdHandler
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

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

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

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

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

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

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

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

@ -5,22 +5,20 @@
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
module Main where module Main where
import Criterion.Main import Gauge.Main
import Text.Hamlet import Text.Hamlet
import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy as L
import qualified Text.Blaze.Html.Renderer.Utf8 as Utf8 import qualified Text.Blaze.Html.Renderer.Utf8 as Utf8
import Data.Monoid (mconcat) import Data.Monoid (mconcat)
import Text.Blaze.Html5 (table, tr, td) import Text.Blaze.Html5 (table, tr, td)
import Text.Blaze.Html (toHtml) import Text.Blaze.Html (toHtml)
import Yesod.Core.Widget
import Yesod.Core.Types
import Data.Int import Data.Int
main :: IO () main :: IO ()
main = defaultMain main = defaultMain
[ bench "bigTable html" $ nf bigTableHtml bigTableData [ bench "bigTable html" $ nf bigTableHtml bigTableData
, bench "bigTable hamlet" $ nf bigTableHamlet 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 , bench "bigTable blaze" $ nf bigTableBlaze bigTableData
] ]
where where
@ -49,6 +47,7 @@ bigTableHamlet rows = L.length $ Utf8.renderHtml $ ($ id) [hamlet|
<td>#{show cell} <td>#{show cell}
|] |]
{-
bigTableWidget :: Show a => [[a]] -> IO Int64 bigTableWidget :: Show a => [[a]] -> IO Int64
bigTableWidget rows = fmap (L.length . Utf8.renderHtml . ($ render)) (run [whamlet| bigTableWidget rows = fmap (L.length . Utf8.renderHtml . ($ render)) (run [whamlet|
<table> <table>
@ -62,6 +61,7 @@ bigTableWidget rows = fmap (L.length . Utf8.renderHtml . ($ render)) (run [whaml
run (WidgetT w) = do run (WidgetT w) = do
(_, GWData { gwdBody = Body x }) <- w undefined (_, GWData { gwdBody = Body x }) <- w undefined
return x return x
-}
bigTableBlaze :: Show a => [[a]] -> Int64 bigTableBlaze :: Show a => [[a]] -> Int64
bigTableBlaze t = L.length $ Utf8.renderHtml $ table $ Data.Monoid.mconcat $ map row t 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 -- /#Int TrailingIntR GET
|] |]
rrinst <- mkRenderRouteInstance (ConT ''Hierarchy) $ map (fmap parseType) resources rrinst <- mkRenderRouteInstance [] (ConT ''Hierarchy) $ map (fmap parseType) resources
rainst <- mkRouteAttrsInstance (ConT ''Hierarchy) $ map (fmap parseType) resources rainst <- mkRouteAttrsInstance [] (ConT ''Hierarchy) $ map (fmap parseType) resources
prinst <- mkParseRouteInstance (ConT ''Hierarchy) $ map (fmap parseType) resources prinst <- mkParseRouteInstance [] (ConT ''Hierarchy) $ map (fmap parseType) resources
dispatch <- mkDispatchClause MkDispatchSettings dispatch <- mkDispatchClause MkDispatchSettings
{ mdsRunHandler = [|runHandler|] { mdsRunHandler = [|runHandler|]
, mdsSubDispatcher = [|subDispatch|] , mdsSubDispatcher = [|subDispatch|]

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

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

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

@ -15,7 +15,7 @@ import Network.Wai
import Network.Wai.Test import Network.Wai.Test
import Yesod.Core import Yesod.Core
import Data.IORef.Lifted import UnliftIO.IORef
import Data.Typeable (Typeable) import Data.Typeable (Typeable)
import qualified Data.ByteString.Lazy.Char8 as L8 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 Control.Arrow ((***))
import Network.HTTP.Types (encodePath) import Network.HTTP.Types (encodePath)
import Data.Monoid (mappend) import Data.Monoid (mappend)
import Blaze.ByteString.Builder.Char.Utf8 (fromText) import Data.Text.Encoding (encodeUtf8Builder)
data Subsite = Subsite data Subsite = Subsite
@ -64,7 +64,7 @@ instance Yesod Y where
corrected = filter (not . TS.null) s corrected = filter (not . TS.null) s
joinPath Y ar pieces' qs' = joinPath Y ar pieces' qs' =
fromText ar `Data.Monoid.mappend` encodePath pieces qs encodeUtf8Builder ar `Data.Monoid.mappend` encodePath pieces qs
where where
pieces = if null pieces' then [""] else pieces' pieces = if null pieces' then [""] else pieces'
qs = map (TE.encodeUtf8 *** go) qs' 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 qualified Data.ByteString.Char8 as S8
import Control.Exception (SomeException, try) import Control.Exception (SomeException, try)
import Network.HTTP.Types (Status, mkStatus) 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.Monoid (mconcat)
import Data.Text (Text, pack) import Data.Text (Text, pack)
import Control.Monad (forM_) 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 data App = App
@ -99,7 +101,7 @@ getFileBadNameR :: Handler TypedContent
getFileBadNameR = return $ TypedContent "ignored" $ ContentFile (error "filebadname") Nothing getFileBadNameR = return $ TypedContent "ignored" $ ContentFile (error "filebadname") Nothing
goodBuilderContent :: Builder 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 :: Handler TypedContent
getGoodBuilderR = return $ TypedContent "text/plain" $ toContent goodBuilderContent getGoodBuilderR = return $ TypedContent "text/plain" $ toContent goodBuilderContent
@ -217,6 +219,6 @@ caseGoodBuilder = runner $ do
caseError :: Int -> IO () caseError :: Int -> IO ()
caseError i = runner $ do caseError i = runner $ do
res <- request defaultRequest { pathInfo = ["error", pack $ show i] } 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 liftIO $ print res
E.throwIO (e :: E.SomeException) 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 Yesod.Core
import Data.Word (Word64) import Data.Word (Word64)
import System.IO.Unsafe (unsafePerformIO) import System.IO.Unsafe (unsafePerformIO)
import qualified System.Random.MWC as MWC
import Control.Monad.ST
import Control.Monad (replicateM) import Control.Monad (replicateM)
import System.Random
gen :: IO Int
gen = getStdRandom next
randomStringSpecs :: Spec randomStringSpecs :: Spec
randomStringSpecs = describe "Yesod.Internal.Request.randomString" $ do 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 -- NOTE: this testcase may break on other systems/architectures if
-- mkStdGen is not identical everywhere (is it?). -- mkStdGen is not identical everywhere (is it?).
_looksRandom :: Bool _looksRandom :: IO ()
_looksRandom = runST $ do _looksRandom = do
gen <- MWC.create
s <- randomString 20 gen s <- randomString 20 gen
return $ s == "VH9SkhtptqPs6GqtofVg" s `shouldBe` "VH9SkhtptqPs6GqtofVg"
noRepeat :: Int -> Int -> Bool noRepeat :: Int -> Int -> IO ()
noRepeat len n = runST $ do noRepeat len n = do
gen <- MWC.create
ss <- replicateM n $ randomString len gen ss <- replicateM n $ randomString len gen
return $ length (nub ss) == n length (nub ss) `shouldBe` n
-- For convenience instead of "(undefined :: StdGen)". -- For convenience instead of "(undefined :: StdGen)".
g :: MWC.GenIO g :: IO Int
g = error "test/YesodCoreTest/InternalRequest.g" g = error "test/YesodCoreTest/InternalRequest.g"
parseWaiRequest' :: Request parseWaiRequest' :: Request

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

@ -13,7 +13,7 @@ import Yesod.Core
import Network.Wai import Network.Wai
import Network.Wai.Test import Network.Wai.Test
import Data.Text (Text) import Data.Text (Text)
import Blaze.ByteString.Builder (toByteString) import Data.ByteString.Builder (toLazyByteString)
data Y = Y data Y = Y
mkYesod "Y" [parseRoutes| mkYesod "Y" [parseRoutes|
@ -86,7 +86,7 @@ case_blanks = runner $ do
liftIO $ do liftIO $ do
let go r = let go r =
let (ps, qs) = renderRoute 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 $ TextR "") `shouldBe` "/single/-" (go $ TextR "") `shouldBe` "/single/-"
(go $ TextsR ["", "-", "foo", "", "bar"]) `shouldBe` "/multi/-/--/foo/-/bar" (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 QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances, ViewPatterns #-} {-# LANGUAGE FlexibleInstances, ViewPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-} -- the module name is a lie!!! {-# LANGUAGE OverloadedStrings #-} -- the module name is a lie!!!
module YesodCoreTest.NoOverloadedStrings module YesodCoreTest.NoOverloadedStrings
( noOverloadedTest ( noOverloadedTest
@ -20,19 +21,19 @@ import qualified Data.ByteString.Lazy.Char8 as L8
getSubsite :: a -> Subsite getSubsite :: a -> Subsite
getSubsite _ = Subsite $(mkYesodSubDispatch resourcesSubsite) getSubsite _ = Subsite $(mkYesodSubDispatch resourcesSubsite)
getBarR :: Monad m => m T.Text getBarR :: MonadHandler m => m T.Text
getBarR = return $ T.pack "BarR" getBarR = return $ T.pack "BarR"
getBazR :: Yesod master => HandlerT Subsite (HandlerT master IO) Html getBazR :: (MonadHandler m, Yesod (HandlerSite m)) => m Html
getBazR = lift $ defaultLayout [whamlet|Used Default Layout|] 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 getBinR = do
widget <- widgetToParentWidget [whamlet| routeToParent <- getRouteToParent
liftHandler $ defaultLayout [whamlet|
<p>Used defaultLayoutT <p>Used defaultLayoutT
<a href=@{BazR}>Baz <a href=@{routeToParent BazR}>Baz
|] |]
lift $ defaultLayout widget
getOnePiecesR :: Monad m => Int -> m () getOnePiecesR :: Monad m => Int -> m ()
getOnePiecesR _ = return () 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
import Yesod.Core.Types 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| mkYesodSubData "Subsite" [parseRoutes|
/bar BarR GET /bar BarR GET
@ -21,7 +21,7 @@ mkYesodSubData "Subsite" [parseRoutes|
/has-three-pieces/#Int/#Int/#Int ThreePiecesR GET /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 = yesodSubDispatch ysre =
f ysre f ysre
where 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.IORef
import Data.Streaming.Network (bindPortTCP) import Data.Streaming.Network (bindPortTCP)
import Network.HTTP.Types (status200) import Network.HTTP.Types (status200)
import Blaze.ByteString.Builder (fromByteString)
mkYesod "App" [parseRoutes| mkYesod "App" [parseRoutes|
/ HomeR GET / HomeR GET
@ -40,22 +39,22 @@ getHomeR = do
_ <- register $ writeIORef ref 1 _ <- register $ writeIORef ref 1
sendRawResponse $ \src sink -> liftIO $ do sendRawResponse $ \src sink -> liftIO $ do
val <- readIORef ref val <- readIORef ref
yield (S8.pack $ show val) $$ sink runConduit $ yield (S8.pack $ show val) .| sink
src $$ CL.map (S8.map toUpper) =$ sink runConduit $ src .| CL.map (S8.map toUpper) .| sink
getWaiStreamR :: Handler () getWaiStreamR :: Handler ()
getWaiStreamR = sendWaiResponse $ responseStream status200 [] $ \send flush -> do getWaiStreamR = sendWaiResponse $ responseStream status200 [] $ \send flush -> do
flush flush
send $ fromByteString "hello" send "hello"
flush flush
send $ fromByteString " world" send " world"
getWaiAppStreamR :: Handler () getWaiAppStreamR :: Handler ()
getWaiAppStreamR = sendWaiApplication $ \_ f -> f $ responseStream status200 [] $ \send flush -> do getWaiAppStreamR = sendWaiApplication $ \_ f -> f $ responseStream status200 [] $ \send flush -> do
flush flush
send $ fromByteString "hello" send "hello"
flush flush
send $ fromByteString " world" send " world"
getFreePort :: IO Int getFreePort :: IO Int
getFreePort = do getFreePort = do
@ -77,18 +76,18 @@ specs = do
withAsync (warp port App) $ \_ -> do withAsync (warp port App) $ \_ -> do
threadDelay 100000 threadDelay 100000
runTCPClient (clientSettings port "127.0.0.1") $ \ad -> do runTCPClient (clientSettings port "127.0.0.1") $ \ad -> do
yield "GET / HTTP/1.1\r\n\r\nhello" $$ appSink ad runConduit $ yield "GET / HTTP/1.1\r\n\r\nhello" .| appSink ad
(appSource ad $$ CB.take 6) >>= (`shouldBe` "0HELLO") runConduit (appSource ad .| CB.take 6) >>= (`shouldBe` "0HELLO")
yield "WORLd" $$ appSink ad runConduit $ yield "WORLd" .| appSink ad
(appSource ad $$ await) >>= (`shouldBe` Just "WORLD") runConduit (appSource ad .| await) >>= (`shouldBe` Just "WORLD")
let body req = do let body req = do
port <- getFreePort port <- getFreePort
withAsync (warp port App) $ \_ -> do withAsync (warp port App) $ \_ -> do
threadDelay 100000 threadDelay 100000
runTCPClient (clientSettings port "127.0.0.1") $ \ad -> do runTCPClient (clientSettings port "127.0.0.1") $ \ad -> do
yield req $$ appSink ad runConduit $ yield req .| appSink ad
appSource ad $$ CB.lines =$ do runConduit $ appSource ad .| CB.lines .| do
let loop = do let loop = do
x <- await x <- await
case x of case x of

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

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

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

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

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

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

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

@ -1,5 +1,5 @@
name: yesod-eventsource name: yesod-eventsource
version: 1.4.1 version: 1.6.0
license: MIT license: MIT
license-file: LICENSE license-file: LICENSE
author: Felipe Lessa <felipe.lessa@gmail.com> author: Felipe Lessa <felipe.lessa@gmail.com>
@ -15,8 +15,8 @@ extra-source-files: README.md ChangeLog.md
library library
build-depends: base >= 4 && < 5 build-depends: base >= 4 && < 5
, yesod-core == 1.4.* , yesod-core == 1.6.*
, conduit >= 0.5 && < 1.3 , conduit >= 1.3
, wai >= 1.3 , wai >= 1.3
, wai-eventsource >= 1.3 , wai-eventsource >= 1.3
, wai-extra , 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 ## 1.4.16
* Korean translation * 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. -- | (Internal) Render a help widget for tooltips and errors.
helpWidget :: FieldView site -> WidgetT site IO () helpWidget :: FieldView site -> WidgetFor site ()
helpWidget view = [whamlet| helpWidget view = [whamlet|
$maybe tt <- fvTooltip view $maybe tt <- fvTooltip view
<span .help-block>#{tt} <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) 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 :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m TimeOfDay
timeField = timeFieldTypeText timeField = timeFieldTypeTime
{-# 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." #-}
-- | 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'. -- | 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" 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). -- | 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. -- 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 -- > areq (selectFieldList [("Value 1" :: Text, "value1"),("Value 2", "value2")]) "Which value?" Nothing
selectFieldList :: (Eq a, RenderMessage site FormMessage, RenderMessage site msg) selectFieldList :: (Eq a, RenderMessage site FormMessage, RenderMessage site msg)
=> [(msg, a)] => [(msg, a)]
-> Field (HandlerT site IO) a -> Field (HandlerFor site) a
selectFieldList = selectField . optionsPairs selectFieldList = selectField . optionsPairs
-- | Creates a @\<select>@ tag for selecting one option. Example usage: -- | Creates a @\<select>@ tag for selecting one option. Example usage:
-- --
-- > areq (selectField $ optionsPairs [(MsgValue1, "value1"),(MsgValue2, "value2")]) "Which value?" Nothing -- > areq (selectField $ optionsPairs [(MsgValue1, "value1"),(MsgValue2, "value2")]) "Which value?" Nothing
selectField :: (Eq a, RenderMessage site FormMessage) selectField :: (Eq a, RenderMessage site FormMessage)
=> HandlerT site IO (OptionList a) => HandlerFor site (OptionList a)
-> Field (HandlerT site IO) a -> Field (HandlerFor site) a
selectField = selectFieldHelper selectField = selectFieldHelper
(\theId name attrs inside -> [whamlet| (\theId name attrs inside -> [whamlet|
$newline never $newline never
@ -446,13 +447,13 @@ $newline never
-- | Creates a @\<select>@ tag for selecting multiple options. -- | Creates a @\<select>@ tag for selecting multiple options.
multiSelectFieldList :: (Eq a, RenderMessage site msg) multiSelectFieldList :: (Eq a, RenderMessage site msg)
=> [(msg, a)] => [(msg, a)]
-> Field (HandlerT site IO) [a] -> Field (HandlerFor site) [a]
multiSelectFieldList = multiSelectField . optionsPairs multiSelectFieldList = multiSelectField . optionsPairs
-- | Creates a @\<select>@ tag for selecting multiple options. -- | Creates a @\<select>@ tag for selecting multiple options.
multiSelectField :: Eq a multiSelectField :: Eq a
=> HandlerT site IO (OptionList a) => HandlerFor site (OptionList a)
-> Field (HandlerT site IO) [a] -> Field (HandlerFor site) [a]
multiSelectField ioptlist = multiSelectField ioptlist =
Field parse view UrlEncoded Field parse view UrlEncoded
where where
@ -478,18 +479,18 @@ multiSelectField ioptlist =
-- | Creates an input with @type="radio"@ for selecting one option. -- | Creates an input with @type="radio"@ for selecting one option.
radioFieldList :: (Eq a, RenderMessage site FormMessage, RenderMessage site msg) radioFieldList :: (Eq a, RenderMessage site FormMessage, RenderMessage site msg)
=> [(msg, a)] => [(msg, a)]
-> Field (HandlerT site IO) a -> Field (HandlerFor site) a
radioFieldList = radioField . optionsPairs radioFieldList = radioField . optionsPairs
-- | Creates an input with @type="checkbox"@ for selecting multiple options. -- | Creates an input with @type="checkbox"@ for selecting multiple options.
checkboxesFieldList :: (Eq a, RenderMessage site msg) => [(msg, a)] checkboxesFieldList :: (Eq a, RenderMessage site msg) => [(msg, a)]
-> Field (HandlerT site IO) [a] -> Field (HandlerFor site) [a]
checkboxesFieldList = checkboxesField . optionsPairs checkboxesFieldList = checkboxesField . optionsPairs
-- | Creates an input with @type="checkbox"@ for selecting multiple options. -- | Creates an input with @type="checkbox"@ for selecting multiple options.
checkboxesField :: Eq a checkboxesField :: Eq a
=> HandlerT site IO (OptionList a) => HandlerFor site (OptionList a)
-> Field (HandlerT site IO) [a] -> Field (HandlerFor site) [a]
checkboxesField ioptlist = (multiSelectField ioptlist) checkboxesField ioptlist = (multiSelectField ioptlist)
{ fieldView = { fieldView =
\theId name attrs val _isReq -> do \theId name attrs val _isReq -> do
@ -506,8 +507,8 @@ checkboxesField ioptlist = (multiSelectField ioptlist)
} }
-- | Creates an input with @type="radio"@ for selecting one option. -- | Creates an input with @type="radio"@ for selecting one option.
radioField :: (Eq a, RenderMessage site FormMessage) radioField :: (Eq a, RenderMessage site FormMessage)
=> HandlerT site IO (OptionList a) => HandlerFor site (OptionList a)
-> Field (HandlerT site IO) a -> Field (HandlerFor site) a
radioField = selectFieldHelper radioField = selectFieldHelper
(\theId _name _attrs inside -> [whamlet| (\theId _name _attrs inside -> [whamlet|
$newline never $newline never
@ -663,7 +664,7 @@ optionsPersist :: ( YesodPersist site
=> [Filter a] => [Filter a]
-> [SelectOpt a] -> [SelectOpt a]
-> (a -> msg) -> (a -> msg)
-> HandlerT site IO (OptionList (Entity a)) -> HandlerFor site (OptionList (Entity a))
#else #else
optionsPersist :: ( YesodPersist site, PersistEntity a optionsPersist :: ( YesodPersist site, PersistEntity a
, PersistQuery (PersistEntityBackend a) , PersistQuery (PersistEntityBackend a)
@ -674,7 +675,7 @@ optionsPersist :: ( YesodPersist site, PersistEntity a
=> [Filter a] => [Filter a]
-> [SelectOpt a] -> [SelectOpt a]
-> (a -> msg) -> (a -> msg)
-> HandlerT site IO (OptionList (Entity a)) -> HandlerFor site (OptionList (Entity a))
#endif #endif
optionsPersist filts ords toDisplay = fmap mkOptionList $ do optionsPersist filts ords toDisplay = fmap mkOptionList $ do
mr <- getMessageRender mr <- getMessageRender
@ -701,7 +702,7 @@ optionsPersistKey
=> [Filter a] => [Filter a]
-> [SelectOpt a] -> [SelectOpt a]
-> (a -> msg) -> (a -> msg)
-> HandlerT site IO (OptionList (Key a)) -> HandlerFor site (OptionList (Key a))
#else #else
optionsPersistKey optionsPersistKey
:: (YesodPersist site :: (YesodPersist site
@ -714,7 +715,7 @@ optionsPersistKey
=> [Filter a] => [Filter a]
-> [SelectOpt a] -> [SelectOpt a]
-> (a -> msg) -> (a -> msg)
-> HandlerT site IO (OptionList (Key a)) -> HandlerFor site (OptionList (Key a))
#endif #endif
optionsPersistKey filts ords toDisplay = fmap mkOptionList $ do optionsPersistKey filts ords toDisplay = fmap mkOptionList $ do
@ -728,11 +729,11 @@ optionsPersistKey filts ords toDisplay = fmap mkOptionList $ do
selectFieldHelper selectFieldHelper
:: (Eq a, RenderMessage site FormMessage) :: (Eq a, RenderMessage site FormMessage)
=> (Text -> Text -> [(Text, Text)] -> WidgetT site IO () -> WidgetT site IO ()) => (Text -> Text -> [(Text, Text)] -> WidgetFor site () -> WidgetFor site ())
-> (Text -> Text -> Bool -> WidgetT site IO ()) -> (Text -> Text -> Bool -> WidgetFor site ())
-> (Text -> Text -> [(Text, Text)] -> Text -> Bool -> Text -> WidgetT site IO ()) -> (Text -> Text -> [(Text, Text)] -> Text -> Bool -> Text -> WidgetFor site ())
-> HandlerT site IO (OptionList a) -> HandlerFor site (OptionList a)
-> Field (HandlerT site IO) a -> Field (HandlerFor site) a
selectFieldHelper outside onOpt inside opts' = Field selectFieldHelper outside onOpt inside opts' = Field
{ fieldParse = \x _ -> do { fieldParse = \x _ -> do
opts <- opts' opts <- opts'

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

@ -385,8 +385,8 @@ getHelper form env = do
identifyForm identifyForm
:: Monad m :: Monad m
=> Text -- ^ Form identification string. => Text -- ^ Form identification string.
-> (Html -> MForm m (FormResult a, WidgetT (HandlerSite m) IO ())) -> (Html -> MForm m (FormResult a, WidgetFor (HandlerSite m) ()))
-> (Html -> MForm m (FormResult a, WidgetT (HandlerSite m) IO ())) -> (Html -> MForm m (FormResult a, WidgetFor (HandlerSite m) ()))
identifyForm identVal form = \fragment -> do identifyForm identVal form = \fragment -> do
-- Create hidden <input>. -- Create hidden <input>.
let fragment' = let fragment' =
@ -418,7 +418,7 @@ identifyFormKey = "_formid"
type FormRender m a = type FormRender m a =
AForm m a AForm m a
-> Html -> Html
-> MForm m (FormResult a, WidgetT (HandlerSite m) IO ()) -> MForm m (FormResult a, WidgetFor (HandlerSite m) ())
renderTable, renderDivs, renderDivsNoLabels :: Monad m => FormRender m a renderTable, renderDivs, renderDivsNoLabels :: Monad m => FormRender m a
-- | Render a form into a series of tr tags. Note that, in order to allow -- | 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 :: a -> Either (Route a) Text
urlJqueryUiDateTimePicker _ = Right "http://github.com/gregwebs/jquery.ui.datetimepicker/raw/master/jquery.ui.datetimepicker.js" 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" jqueryDayField = flip jqueryDayField' "date"
-- | Use jQuery's datepicker as the underlying implementation. -- | Use jQuery's datepicker as the underlying implementation.
-- --
-- Since 1.4.3 -- 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" 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 jqueryDayField' jds inputType = Field
{ fieldParse = parseHelper $ maybe { fieldParse = parseHelper $ maybe
(Left MsgInvalidDay) (Left MsgInvalidDay)
@ -107,13 +107,13 @@ $(function(){
] ]
jqueryAutocompleteField :: (RenderMessage site FormMessage, YesodJquery site) jqueryAutocompleteField :: (RenderMessage site FormMessage, YesodJquery site)
=> Route site -> Field (HandlerT site IO) Text => Route site -> Field (HandlerFor site) Text
jqueryAutocompleteField = jqueryAutocompleteField' 2 jqueryAutocompleteField = jqueryAutocompleteField' 2
jqueryAutocompleteField' :: (RenderMessage site FormMessage, YesodJquery site) jqueryAutocompleteField' :: (RenderMessage site FormMessage, YesodJquery site)
=> Int -- ^ autocomplete minimum length => Int -- ^ autocomplete minimum length
-> Route site -> Route site
-> Field (HandlerT site IO) Text -> Field (HandlerFor site) Text
jqueryAutocompleteField' minLen src = Field jqueryAutocompleteField' minLen src = Field
{ fieldParse = parseHelper $ Right { fieldParse = parseHelper $ Right
, fieldView = \theId name attrs val isReq -> do , 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 -- | Generate a form that accepts 0 or more values from the user, allowing the
-- user to specify that a new row is necessary. -- 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 => Html
-- ^ label for the form -- ^ label for the form
-> ([[FieldView site]] -> xml) -> ([[FieldView site]] -> xml)
-- ^ how to display the rows, usually either 'massDivs' or 'massTable' -- ^ 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 -- ^ display a single row of the form, where @Maybe a@ gives the
-- previously submitted value -- previously submitted value
-> Maybe [a] -> Maybe [a]
-- ^ default initial values for the form -- ^ default initial values for the form
-> AForm (HandlerT site IO) [a] -> AForm (HandlerFor site) [a]
inputList label fixXml single mdef = formToAForm $ do inputList label fixXml single mdef = formToAForm $ do
theId <- lift newIdent theId <- lift newIdent
down 1 down 1
@ -94,9 +94,9 @@ $newline never
, fvRequired = False , fvRequired = False
}]) }])
withDelete :: (xml ~ WidgetT site IO (), RenderMessage site FormMessage) withDelete :: (xml ~ WidgetFor site (), RenderMessage site FormMessage)
=> AForm (HandlerT site IO) a => AForm (HandlerFor site) a
-> MForm (HandlerT site IO) (Either xml (FormResult a, [FieldView site])) -> MForm (HandlerFor site) (Either xml (FormResult a, [FieldView site]))
withDelete af = do withDelete af = do
down 1 down 1
deleteName <- newFormIdent deleteName <- newFormIdent
@ -129,7 +129,7 @@ fixme eithers =
massDivs, massTable massDivs, massTable
:: [[FieldView site]] :: [[FieldView site]]
-> WidgetT site IO () -> WidgetFor site ()
massDivs viewss = [whamlet| massDivs viewss = [whamlet|
$newline never $newline never
$forall views <- viewss $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 :: a -> Either (Route a) Text
urlNicEdit _ = Right "http://js.nicedit.com/nicEdit-latest.js" 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 nicHtmlField = Field
{ fieldParse = \e _ -> return . Right . fmap (preEscapedToMarkup . sanitizeBalance) . listToMaybe $ e { fieldParse = \e _ -> return . Right . fmap (preEscapedToMarkup . sanitizeBalance) . listToMaybe $ e
, fieldView = \theId name attrs val _isReq -> do , 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 { fvLabel :: Html
, fvTooltip :: Maybe Html , fvTooltip :: Maybe Html
, fvId :: Text , fvId :: Text
, fvInput :: WidgetT site IO () , fvInput :: WidgetFor site ()
, fvErrors :: Maybe Html , fvErrors :: Maybe Html
, fvRequired :: Bool , fvRequired :: Bool
} }
@ -200,7 +200,7 @@ type FieldViewFunc m a
-> [(Text, Text)] -- ^ Attributes -> [(Text, Text)] -- ^ Attributes
-> Either Text a -- ^ Either (invalid text) or (legitimate result) -> Either Text a -- ^ Either (invalid text) or (legitimate result)
-> Bool -- ^ Required? -> Bool -- ^ Required?
-> WidgetT (HandlerSite m) IO () -> WidgetFor (HandlerSite m) ()
data Field m a = Field data Field m a = Field
{ fieldParse :: [Text] -> [FileInfo] -> m (Either (SomeMessage (HandlerSite m)) (Maybe a)) { 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 name: yesod-form
version: 1.4.16 version: 1.6.0
license: MIT license: MIT
license-file: LICENSE license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com> author: Michael Snoyman <michael@snoyman.com>
@ -20,8 +20,8 @@ flag network-uri
library library
build-depends: base >= 4 && < 5 build-depends: base >= 4 && < 5
, yesod-core >= 1.4.14 && < 1.5 , yesod-core >= 1.6 && < 1.7
, yesod-persistent >= 1.4 && < 1.5 , yesod-persistent >= 1.6 && < 1.7
, time >= 1.1.4 , time >= 1.1.4
, shakespeare >= 2.0 , shakespeare >= 2.0
, persistent , persistent

4
yesod-newsfeed/ChangeLog.md
View File

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

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

@ -1,5 +1,5 @@
name: yesod-newsfeed name: yesod-newsfeed
version: 1.6 version: 1.6.1.0
license: MIT license: MIT
license-file: LICENSE license-file: LICENSE
author: Michael Snoyman, Patrick Brisbin author: Michael Snoyman, Patrick Brisbin
@ -15,7 +15,7 @@ extra-source-files: README.md ChangeLog.md
library library
build-depends: base >= 4 && < 5 build-depends: base >= 4 && < 5
, yesod-core >= 1.4 && < 1.5 , yesod-core >= 1.6 && < 1.7
, time >= 1.1.4 , time >= 1.1.4
, shakespeare >= 2.0 , shakespeare >= 2.0
, bytestring >= 0.9.1.4 , 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 ## 1.4.3
* Fix overly powerful constraints on get404 and getBy404. * 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 :: a -> a
unSqlPersistT = id 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 class Monad (YesodDB site) => YesodPersist site where
type YesodPersistBackend site type YesodPersistBackend site
runDB :: YesodDB site a -> HandlerT site IO a runDB :: YesodDB site a -> HandlerFor site a
-- | Helper for creating 'runDB'. -- | Helper for creating 'runDB'.
-- --
@ -49,8 +49,8 @@ class Monad (YesodDB site) => YesodPersist site where
defaultRunDB :: PersistConfig c defaultRunDB :: PersistConfig c
=> (site -> c) => (site -> c)
-> (site -> PersistConfigPool c) -> (site -> PersistConfigPool c)
-> PersistConfigBackend c (HandlerT site IO) a -> PersistConfigBackend c (HandlerFor site) a
-> HandlerT site IO a -> HandlerFor site a
defaultRunDB getConfig getPool f = do defaultRunDB getConfig getPool f = do
master <- getYesod master <- getYesod
Database.Persist.runPool Database.Persist.runPool
@ -74,10 +74,10 @@ class YesodPersist site => YesodPersistRunner site where
-- least, a rollback will be used instead. -- least, a rollback will be used instead.
-- --
-- Since 1.2.0 -- Since 1.2.0
getDBRunner :: HandlerT site IO (DBRunner site, HandlerT site IO ()) getDBRunner :: HandlerFor site (DBRunner site, HandlerFor site ())
newtype DBRunner site = DBRunner 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'. -- | Helper for implementing 'getDBRunner'.
@ -86,11 +86,11 @@ newtype DBRunner site = DBRunner
#if MIN_VERSION_persistent(2,5,0) #if MIN_VERSION_persistent(2,5,0)
defaultGetDBRunner :: (SQL.IsSqlBackend backend, YesodPersistBackend site ~ backend) defaultGetDBRunner :: (SQL.IsSqlBackend backend, YesodPersistBackend site ~ backend)
=> (site -> Pool backend) => (site -> Pool backend)
-> HandlerT site IO (DBRunner site, HandlerT site IO ()) -> HandlerFor site (DBRunner site, HandlerFor site ())
#else #else
defaultGetDBRunner :: YesodPersistBackend site ~ SQL.SqlBackend defaultGetDBRunner :: YesodPersistBackend site ~ SQL.SqlBackend
=> (site -> Pool SQL.SqlBackend) => (site -> Pool SQL.SqlBackend)
-> HandlerT site IO (DBRunner site, HandlerT site IO ()) -> HandlerFor site (DBRunner site, HandlerFor site ())
#endif #endif
defaultGetDBRunner getPool = do defaultGetDBRunner getPool = do
pool <- fmap getPool getYesod pool <- fmap getPool getYesod
@ -118,8 +118,8 @@ defaultGetDBRunner getPool = do
-- --
-- Since 1.2.0 -- Since 1.2.0
runDBSource :: YesodPersistRunner site runDBSource :: YesodPersistRunner site
=> Source (YesodDB site) a => ConduitT () a (YesodDB site) ()
-> Source (HandlerT site IO) a -> ConduitT () a (HandlerFor site) ()
runDBSource src = do runDBSource src = do
(dbrunner, cleanup) <- lift getDBRunner (dbrunner, cleanup) <- lift getDBRunner
transPipe (runDBRunner dbrunner) src transPipe (runDBRunner dbrunner) src
@ -128,8 +128,8 @@ runDBSource src = do
-- | Extends 'respondSource' to create a streaming database response body. -- | Extends 'respondSource' to create a streaming database response body.
respondSourceDB :: YesodPersistRunner site respondSourceDB :: YesodPersistRunner site
=> ContentType => ContentType
-> Source (YesodDB site) (Flush Builder) -> ConduitT () (Flush Builder) (YesodDB site) ()
-> HandlerT site IO TypedContent -> HandlerFor site TypedContent
respondSourceDB ctype = respondSource ctype . runDBSource respondSourceDB ctype = respondSource ctype . runDBSource
-- | Get the given entity by ID, or return a 404 not found if it doesn't exist. -- | 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 "Charlie"
insert_ $ Person "Alice" insert_ $ Person "Alice"
insert_ $ Person "Bob" insert_ $ Person "Bob"
respondSourceDB typePlain $ selectSource [] [Asc PersonName] $= awaitForever toBuilder respondSourceDB typePlain $ selectSource [] [Asc PersonName] .| awaitForever toBuilder
where where
toBuilder (Entity _ (Person name)) = do toBuilder (Entity _ (Person name)) = do
yield $ Chunk $ fromText name yield $ Chunk $ fromText name

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

@ -1,5 +1,5 @@
name: yesod-persistent name: yesod-persistent
version: 1.4.3 version: 1.6.0
license: MIT license: MIT
license-file: LICENSE license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com> author: Michael Snoyman <michael@snoyman.com>
@ -15,8 +15,8 @@ extra-source-files: README.md ChangeLog.md
library library
build-depends: base >= 4 && < 5 build-depends: base >= 4 && < 5
, yesod-core >= 1.4.0 && < 1.5 , yesod-core >= 1.6 && < 1.7
, persistent >= 2.1 && < 2.8 , persistent >= 2.8 && < 2.9
, persistent-template >= 2.1 && < 2.8 , persistent-template >= 2.1 && < 2.8
, transformers >= 0.2.2 , transformers >= 0.2.2
, blaze-builder , blaze-builder
@ -36,7 +36,7 @@ test-suite test
, hspec , hspec
, wai-extra , wai-extra
, yesod-core , yesod-core
, persistent-sqlite , persistent-sqlite >= 2.8
, yesod-persistent , yesod-persistent
, conduit , conduit
, blaze-builder , 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. -- | Serve a stream of @SitemapUrl@s as a sitemap.
-- --
-- Since 1.2.0 -- Since 1.2.0
sitemap :: Source (HandlerT site IO) (SitemapUrl (Route site)) sitemap :: ConduitT () (SitemapUrl (Route site)) (HandlerFor site) ()
-> HandlerT site IO TypedContent -> HandlerFor site TypedContent
sitemap urls = do sitemap urls = do
render <- getUrlRender render <- getUrlRender
respondSource typeXml $ do respondSource typeXml $ do
yield Flush 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 -- | Convenience wrapper for @sitemap@ for the case when the input is an
-- in-memory list. -- in-memory list.
-- --
-- Since 1.2.0 -- Since 1.2.0
sitemapList :: [SitemapUrl (Route site)] -> HandlerT site IO TypedContent sitemapList :: [SitemapUrl (Route site)] -> HandlerFor site TypedContent
sitemapList = sitemap . mapM_ yield sitemapList = sitemap . mapM_ yield
-- | Convert a stream of @SitemapUrl@s to XML @Event@s using the given URL -- | 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 -- Since 1.2.0
sitemapConduit :: Monad m sitemapConduit :: Monad m
=> (a -> Text) => (a -> Text)
-> Conduit (SitemapUrl a) m Event -> ConduitT (SitemapUrl a) Event m ()
sitemapConduit render = do sitemapConduit render = do
yield EventBeginDocument yield EventBeginDocument
element "urlset" [] $ awaitForever goUrl element "urlset" [] $ awaitForever goUrl

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

@ -1,5 +1,5 @@
name: yesod-sitemap name: yesod-sitemap
version: 1.4.0.1 version: 1.6.0
license: MIT license: MIT
license-file: LICENSE license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com> author: Michael Snoyman <michael@snoyman.com>
@ -15,7 +15,7 @@ extra-source-files: README.md ChangeLog.md
library library
build-depends: base >= 4 && < 5 build-depends: base >= 4 && < 5
, yesod-core >= 1.4 && < 1.5 , yesod-core >= 1.6 && < 1.7
, time >= 1.1.4 , time >= 1.1.4
, xml-conduit >= 1.0 , xml-conduit >= 1.0
, text , 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 ## 1.5.3.1
* Switch to cryptonite * 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 (responseLBS, pathInfo)
import Network.Wai.Application.Static (staticApp) import Network.Wai.Application.Static (staticApp)
import System.IO.Unsafe (unsafePerformIO) import System.IO.Unsafe (unsafePerformIO)
import Yesod.Core import Yesod.Core (YesodSubDispatch(..))
( HandlerT
, YesodSubDispatch(..)
)
import Yesod.Core.Types import Yesod.Core.Types
( YesodSubRunnerEnv(..) ( YesodSubRunnerEnv(..)
, YesodRunnerEnv(..) , YesodRunnerEnv(..)
@ -81,7 +78,7 @@ import Yesod.EmbeddedStatic.Generators
embeddedResourceR :: [T.Text] -> [(T.Text, T.Text)] -> Route EmbeddedStatic embeddedResourceR :: [T.Text] -> [(T.Text, T.Text)] -> Route EmbeddedStatic
embeddedResourceR = EmbeddedResourceR embeddedResourceR = EmbeddedResourceR
instance YesodSubDispatch EmbeddedStatic (HandlerT master IO) where instance YesodSubDispatch EmbeddedStatic master where
yesodSubDispatch YesodSubRunnerEnv {..} req = resp yesodSubDispatch YesodSubRunnerEnv {..} req = resp
where where
master = yreSite ysreParentEnv master = yreSite ysreParentEnv

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

@ -24,9 +24,9 @@ module Yesod.EmbeddedStatic.Generators (
-- * Util -- * Util
, pathToName , pathToName
-- * Custom Generators -- * Custom Generators
-- $example -- $example
) where ) where
@ -34,7 +34,6 @@ import Control.Applicative as A ((<$>), (<*>))
import Control.Exception (try, SomeException) import Control.Exception (try, SomeException)
import Control.Monad (forM, when) import Control.Monad (forM, when)
import Data.Char (isDigit, isLower) import Data.Char (isDigit, isLower)
import Data.Conduit (($$))
import Data.Default (def) import Data.Default (def)
import Data.Maybe (isNothing) import Data.Maybe (isNothing)
import Language.Haskell.TH import Language.Haskell.TH
@ -44,8 +43,7 @@ import System.FilePath ((</>))
import Text.Jasmine (minifym) import Text.Jasmine (minifym)
import qualified Data.ByteString as BS import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy as BL
import qualified Data.Conduit.List as C import Conduit
import Data.Conduit.Binary (sourceHandle)
import qualified Data.Text as T import qualified Data.Text as T
import qualified System.Process as Proc import qualified System.Process as Proc
import System.Exit (ExitCode (ExitSuccess)) import System.Exit (ExitCode (ExitSuccess))
@ -208,13 +206,13 @@ compressTool f opts ct = do
} }
(Just hin, Just hout, _, ph) <- Proc.createProcess p (Just hin, Just hout, _, ph) <- Proc.createProcess p
(compressed, (), code) <- runConcurrently $ (,,) (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 (BL.hPut hin ct >> hClose hin)
A.<*> Concurrently (Proc.waitForProcess ph) A.<*> Concurrently (Proc.waitForProcess ph)
if code == ExitSuccess if code == ExitSuccess
then do then do
putStrLn $ "Compressed successfully with " ++ f putStrLn $ "Compressed successfully with " ++ f
return $ BL.fromChunks compressed return compressed
else error $ "compressTool: compression failed with " ++ f 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 Network.Wai.Application.Static (defaultWebAppSettings, staticApp)
import WaiAppStatic.Types import WaiAppStatic.Types
import Yesod.Core import Yesod.Core
( HandlerT ( HandlerFor
, ParseRoute(..) , ParseRoute(..)
, RenderRoute(..) , RenderRoute(..)
, getYesod , getYesod
@ -136,7 +136,7 @@ develApp settings extra req sendResponse = do
-- | The type of 'addStaticContent' -- | The type of 'addStaticContent'
type AddStaticContent site = T.Text -> T.Text -> BL.ByteString 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. -- | Helper for embedStaticContent and embedLicensedStaticContent.
staticContentHelper :: (site -> EmbeddedStatic) 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 Control.Monad
import Data.FileEmbed (embedDir) import Data.FileEmbed (embedDir)
import Control.Monad.Trans.Resource (runResourceT)
import Yesod.Core import Yesod.Core
import Yesod.Core.Types import Yesod.Core.Types
@ -78,7 +77,6 @@ import Language.Haskell.TH.Syntax as TH
import Crypto.Hash.Conduit (hashFile, sinkHash) import Crypto.Hash.Conduit (hashFile, sinkHash)
import Crypto.Hash (MD5, Digest) import Crypto.Hash (MD5, Digest)
import Control.Monad.Catch (MonadThrow)
import Control.Monad.Trans.State import Control.Monad.Trans.State
import qualified Data.ByteArray as ByteArray import qualified Data.ByteArray as ByteArray
@ -94,11 +92,7 @@ import Data.List (foldl')
import qualified Data.ByteString as S import qualified Data.ByteString as S
import System.PosixCompat.Files (getFileStatus, modificationTime) import System.PosixCompat.Files (getFileStatus, modificationTime)
import System.Posix.Types (EpochTime) import System.Posix.Types (EpochTime)
import Data.Conduit import 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 System.FilePath ((</>), (<.>), takeDirectory) import System.FilePath ((</>), (<.>), takeDirectory)
import qualified System.FilePath as F import qualified System.FilePath as F
import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy as TL
@ -175,12 +169,10 @@ instance RenderRoute Static where
instance ParseRoute Static where instance ParseRoute Static where
parseRoute (x, y) = Just $ StaticRoute x y parseRoute (x, y) = Just $ StaticRoute x y
instance (MonadThrow m, MonadIO m, MonadBaseControl IO m) instance YesodSubDispatch Static master where
=> YesodSubDispatch Static (HandlerT master m) where
yesodSubDispatch YesodSubRunnerEnv {..} req = yesodSubDispatch YesodSubRunnerEnv {..} req =
ysreParentRunner base ysreParentEnv (fmap ysreToParentRoute route) req ysreParentRunner handlert ysreParentEnv (fmap ysreToParentRoute route) req
where where
base = stripHandlerT handlert ysreGetSub ysreToParentRoute route
route = Just $ StaticRoute (pathInfo req) [] route = Just $ StaticRoute (pathInfo req) []
Static set = ysreGetSub $ yreSite $ ysreParentEnv Static set = ysreGetSub $ yreSite $ ysreParentEnv
@ -425,8 +417,8 @@ base64md5File = fmap (base64 . encode) . hashFile
base64md5 :: L.ByteString -> String base64md5 :: L.ByteString -> String
base64md5 lbs = base64md5 lbs =
base64 $ encode base64 $ encode
$ runIdentity $ runConduitPure
$ sourceList (L.toChunks lbs) $$ sinkHash $ Conduit.sourceLazy lbs .| sinkHash
where where
encode d = ByteArray.convert (d :: Digest MD5) encode d = ByteArray.convert (d :: Digest MD5)
@ -461,8 +453,11 @@ combineStatics' :: CombineType
-> [Route Static] -- ^ files to combine -> [Route Static] -- ^ files to combine
-> Q Exp -> Q Exp
combineStatics' combineType CombineSettings {..} routes = do combineStatics' combineType CombineSettings {..} routes = do
texts <- qRunIO $ runResourceT $ mapM_ yield fps $$ awaitForever readUTFFile =$ consume texts <- qRunIO $ runConduitRes
ltext <- qRunIO $ preProcess $ TL.fromChunks texts $ yieldMany fps
.| awaitForever readUTFFile
.| sinkLazy
ltext <- qRunIO $ preProcess texts
bs <- qRunIO $ postProcess fps $ TLE.encodeUtf8 ltext bs <- qRunIO $ postProcess fps $ TLE.encodeUtf8 ltext
let hash' = base64md5 bs let hash' = base64md5 bs
suffix = csCombinedFolder </> hash' <.> extension suffix = csCombinedFolder </> hash' <.> extension
@ -476,7 +471,7 @@ combineStatics' combineType CombineSettings {..} routes = do
fps :: [FilePath] fps :: [FilePath]
fps = map toFP routes fps = map toFP routes
toFP (StaticRoute pieces _) = csStaticDir </> F.joinPath (map T.unpack pieces) toFP (StaticRoute pieces _) = csStaticDir </> F.joinPath (map T.unpack pieces)
readUTFFile fp = sourceFile fp =$= CT.decode CT.utf8 readUTFFile fp = sourceFile fp .| decodeUtf8C
postProcess = postProcess =
case combineType of case combineType of
JS -> csJsPostProcess JS -> csJsPostProcess

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

@ -1,5 +1,5 @@
name: yesod-static name: yesod-static
version: 1.5.3.1 version: 1.6.0
license: MIT license: MIT
license-file: LICENSE license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com> author: Michael Snoyman <michael@snoyman.com>
@ -29,7 +29,7 @@ library
build-depends: base >= 4 && < 5 build-depends: base >= 4 && < 5
, containers >= 0.2 , containers >= 0.2
, old-time >= 1.0 , old-time >= 1.0
, yesod-core >= 1.4 && < 1.5 , yesod-core >= 1.6 && < 1.7
, base64-bytestring >= 0.1.0.1 , base64-bytestring >= 0.1.0.1
, byteable >= 0.1 , byteable >= 0.1
, bytestring >= 0.9.1.4 , bytestring >= 0.9.1.4
@ -42,8 +42,7 @@ library
, file-embed >= 0.0.4.1 && < 0.5 , file-embed >= 0.0.4.1 && < 0.5
, http-types >= 0.7 , http-types >= 0.7
, unix-compat >= 0.2 , unix-compat >= 0.2
, conduit >= 0.5 , conduit >= 1.3
, conduit-extra
, cryptonite-conduit >= 0.1 , cryptonite-conduit >= 0.1
, cryptonite >= 0.11 , cryptonite >= 0.11
, memory , memory
@ -92,7 +91,7 @@ test-suite tests
YesodStaticTest YesodStaticTest
build-depends: base build-depends: base
, hspec >= 1.3 , hspec >= 1.3
, yesod-test >= 1.4 , yesod-test >= 1.6
, wai-extra , wai-extra
, HUnit , HUnit
@ -124,7 +123,6 @@ test-suite tests
, unordered-containers , unordered-containers
, async , async
, process , process
, conduit-extra
, exceptions , exceptions
ghc-options: -Wall -threaded 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 ## 1.5.9.1
* Fixes a Haddock syntax error in 1.5.9 [#1473](https://github.com/yesodweb/yesod/pull/1473) * 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 TypeFamilies #-}
{-# LANGUAGE ImplicitParams #-} {-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-| {-|
Yesod.Test is a pragmatic framework for testing web applications built Yesod.Test is a pragmatic framework for testing web applications built
@ -63,6 +64,7 @@ module Yesod.Test
, addFile , addFile
, setRequestBody , setRequestBody
, RequestBuilder , RequestBuilder
, SIO
, setUrl , setUrl
, clickOn , clickOn
@ -135,7 +137,8 @@ import qualified Network.Socket.Internal as Sock
import Data.CaseInsensitive (CI) import Data.CaseInsensitive (CI)
import Network.Wai import Network.Wai
import Network.Wai.Test hiding (assertHeader, assertNoHeader, request) 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 Control.Monad.IO.Class
import System.IO import System.IO
import Yesod.Core.Unsafe (runFakeHandler) 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.XML.Cursor as C
import qualified Text.HTML.DOM as HD import qualified Text.HTML.DOM as HD
import Control.Monad.Trans.Writer import Control.Monad.Trans.Writer
import Data.IORef
import qualified Data.Map as M import qualified Data.Map as M
import qualified Web.Cookie as Cookie import qualified Web.Cookie as Cookie
import qualified Blaze.ByteString.Builder as Builder import qualified Blaze.ByteString.Builder as Builder
@ -180,7 +184,7 @@ data YesodExampleData site = YesodExampleData
-- | A single test case, to be run with 'yit'. -- | A single test case, to be run with 'yit'.
-- --
-- Since 1.2.0 -- Since 1.2.0
type YesodExample site = ST.StateT (YesodExampleData site) IO type YesodExample site = SIO (YesodExampleData site)
-- | Mapping from cookie name to value. -- | Mapping from cookie name to value.
-- --
@ -203,13 +207,13 @@ data YesodSpecTree site
-- --
-- Since 1.2.0 -- Since 1.2.0
getTestYesod :: YesodExample site site getTestYesod :: YesodExample site site
getTestYesod = fmap yedSite ST.get getTestYesod = fmap yedSite getSIO
-- | Get the most recently provided response value, if available. -- | Get the most recently provided response value, if available.
-- --
-- Since 1.2.0 -- Since 1.2.0
getResponse :: YesodExample site (Maybe SResponse) getResponse :: YesodExample site (Maybe SResponse)
getResponse = fmap yedResponse ST.get getResponse = fmap yedResponse getSIO
data RequestBuilderData site = RequestBuilderData data RequestBuilderData site = RequestBuilderData
{ rbdPostData :: RBDPostData { rbdPostData :: RBDPostData
@ -232,7 +236,7 @@ data RequestPart
-- | The 'RequestBuilder' state monad constructs a URL encoded string of arguments -- | 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 -- 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. -- 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' -- | Start describing a Tests suite keeping cookies and a reference to the tested 'Application'
-- and 'ConnectionPool' -- and 'ConnectionPool'
@ -249,7 +253,7 @@ yesodSpec site yspecs =
unYesod (YesodSpecGroup x y) = Hspec.specGroup x $ map unYesod y unYesod (YesodSpecGroup x y) = Hspec.specGroup x $ map unYesod y
unYesod (YesodSpecItem x y) = Hspec.specItem x $ do unYesod (YesodSpecItem x y) = Hspec.specItem x $ do
app <- toWaiAppPlain site app <- toWaiAppPlain site
ST.evalStateT y YesodExampleData evalSIO y YesodExampleData
{ yedApp = app { yedApp = app
, yedSite = site , yedSite = site
, yedCookies = M.empty , yedCookies = M.empty
@ -269,7 +273,7 @@ yesodSpecWithSiteGenerator getSiteAction yspecs =
unYesod getSiteAction' (YesodSpecItem x y) = Hspec.specItem x $ do unYesod getSiteAction' (YesodSpecItem x y) = Hspec.specItem x $ do
site <- getSiteAction' site <- getSiteAction'
app <- toWaiAppPlain site app <- toWaiAppPlain site
ST.evalStateT y YesodExampleData evalSIO y YesodExampleData
{ yedApp = app { yedApp = app
, yedSite = site , yedSite = site
, yedCookies = M.empty , yedCookies = M.empty
@ -290,7 +294,7 @@ yesodSpecApp site getApp yspecs =
unYesod (YesodSpecGroup x y) = Hspec.specGroup x $ map unYesod y unYesod (YesodSpecGroup x y) = Hspec.specGroup x $ map unYesod y
unYesod (YesodSpecItem x y) = Hspec.specItem x $ do unYesod (YesodSpecItem x y) = Hspec.specItem x $ do
app <- getApp app <- getApp
ST.evalStateT y YesodExampleData evalSIO y YesodExampleData
{ yedApp = app { yedApp = app
, yedSite = site , yedSite = site
, yedCookies = M.empty , 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 -- Performs a given action using the last response. Use this to create
-- response-level assertions -- response-level assertions
withResponse' :: MonadIO m withResponse' :: (state -> Maybe SResponse)
=> (state -> Maybe SResponse)
-> [T.Text] -> [T.Text]
-> (SResponse -> ST.StateT state m a) -> (SResponse -> SIO state a)
-> ST.StateT state m a -> SIO state a
withResponse' getter errTrace f = maybe err f . getter =<< ST.get withResponse' getter errTrace f = maybe err f . getter =<< getSIO
where err = failure msg where err = failure msg
msg = if null errTrace msg = if null errTrace
then "There was no response, you should make a request." then "There was no response, you should make a request."
@ -327,11 +330,10 @@ parseHTML :: HtmlLBS -> Cursor
parseHTML html = fromDocument $ HD.parseLBS html parseHTML html = fromDocument $ HD.parseLBS html
-- | Query the last response using CSS selectors, returns a list of matched fragments -- | Query the last response using CSS selectors, returns a list of matched fragments
htmlQuery' :: MonadIO m htmlQuery' :: (state -> Maybe SResponse)
=> (state -> Maybe SResponse)
-> [T.Text] -> [T.Text]
-> Query -> 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 -> 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 case findBySelector (simpleBody res) query of
Left err -> failure $ query <> " did not parse: " <> T.pack (show err) 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. -- | Add a parameter with the given name and value to the request body.
addPostParam :: T.Text -> T.Text -> RequestBuilder site () addPostParam :: T.Text -> T.Text -> RequestBuilder site ()
addPostParam name value = 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." where addPostData (BinaryPostData _) = error "Trying to add post param to binary content."
addPostData (MultipleItemsPostData posts) = addPostData (MultipleItemsPostData posts) =
MultipleItemsPostData $ ReqKvPart name value : posts MultipleItemsPostData $ ReqKvPart name value : posts
-- | Add a parameter with the given name and value to the query string. -- | Add a parameter with the given name and value to the query string.
addGetParam :: T.Text -> T.Text -> RequestBuilder site () 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 = (TE.encodeUtf8 name, Just $ TE.encodeUtf8 value)
: rbdGets rbd : rbdGets rbd
} }
@ -522,7 +524,7 @@ addFile :: T.Text -- ^ The parameter name for the file.
-> RequestBuilder site () -> RequestBuilder site ()
addFile name path mimetype = do addFile name path mimetype = do
contents <- liftIO $ BSL8.readFile path 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." where addPostData (BinaryPostData _) _ = error "Trying to add file after setting binary content."
addPostData (MultipleItemsPostData posts) contents = addPostData (MultipleItemsPostData posts) contents =
MultipleItemsPostData $ ReqFilePart name path contents mimetype : posts 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. -- 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 :: (T.Text -> T.Text -> Bool) -> T.Text -> RequestBuilder site T.Text
genericNameFromLabel match label = do genericNameFromLabel match label = do
mres <- fmap rbdResponse ST.get mres <- fmap rbdResponse getSIO
res <- res <-
case mres of case mres of
Nothing -> failure "genericNameFromLabel: No response available" Nothing -> failure "genericNameFromLabel: No response available"
@ -798,7 +800,7 @@ addTokenFromCookieNamedToHeaderNamed cookieName headerName = do
-- Since 1.4.3.2 -- Since 1.4.3.2
getRequestCookies :: RequestBuilder site Cookies getRequestCookies :: RequestBuilder site Cookies
getRequestCookies = do getRequestCookies = do
requestBuilderData <- ST.get requestBuilderData <- getSIO
headers <- case simpleHeaders Control.Applicative.<$> rbdResponse requestBuilderData of headers <- case simpleHeaders Control.Applicative.<$> rbdResponse requestBuilderData of
Just h -> return h Just h -> return h
Nothing -> failure "getRequestCookies: No request has been made yet; the cookies can't be looked up." Nothing -> failure "getRequestCookies: No request has been made yet; the cookies can't be looked up."
@ -906,7 +908,7 @@ getLocation = do
-- > request $ do -- > request $ do
-- > setMethod methodPut -- > setMethod methodPut
setMethod :: H.Method -> RequestBuilder site () 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. -- | Sets the URL used by the request.
-- --
@ -921,7 +923,7 @@ setUrl :: (Yesod site, RedirectUrl site url)
=> url => url
-> RequestBuilder site () -> RequestBuilder site ()
setUrl url' = do setUrl url' = do
site <- fmap rbdSite ST.get site <- fmap rbdSite getSIO
eurl <- Yesod.Core.Unsafe.runFakeHandler eurl <- Yesod.Core.Unsafe.runFakeHandler
M.empty M.empty
(const $ error "Yesod.Test: No logger available") (const $ error "Yesod.Test: No logger available")
@ -929,7 +931,7 @@ setUrl url' = do
(toTextUrl url') (toTextUrl url')
url <- either (error . show) return eurl url <- either (error . show) return eurl
let (urlPath, urlQuery) = T.break (== '?') url let (urlPath, urlQuery) = T.break (== '?') url
ST.modify $ \rbd -> rbd modifySIO $ \rbd -> rbd
{ rbdPath = { rbdPath =
case DL.filter (/="") $ H.decodePathSegments $ TE.encodeUtf8 urlPath of case DL.filter (/="") $ H.decodePathSegments $ TE.encodeUtf8 urlPath of
("http:":_:rest) -> rest ("http:":_:rest) -> rest
@ -968,7 +970,7 @@ clickOn query = do
-- > request $ do -- > request $ do
-- > setRequestBody $ encode $ object ["age" .= (1 :: Integer)] -- > setRequestBody $ encode $ object ["age" .= (1 :: Integer)]
setRequestBody :: BSL8.ByteString -> RequestBuilder site () 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. -- | 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 -- > request $ do
-- > addRequestHeader (hUserAgent, "Chrome/41.0.2228.0") -- > addRequestHeader (hUserAgent, "Chrome/41.0.2228.0")
addRequestHeader :: H.Header -> RequestBuilder site () addRequestHeader :: H.Header -> RequestBuilder site ()
addRequestHeader header = ST.modify $ \rbd -> rbd addRequestHeader header = modifySIO $ \rbd -> rbd
{ rbdHeaders = header : rbdHeaders rbd { rbdHeaders = header : rbdHeaders rbd
} }
@ -998,9 +1000,9 @@ addRequestHeader header = ST.modify $ \rbd -> rbd
request :: RequestBuilder site () request :: RequestBuilder site ()
-> YesodExample site () -> YesodExample site ()
request reqBuilder = do 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 [] { rbdPostData = MultipleItemsPostData []
, rbdResponse = mRes , rbdResponse = mRes
, rbdMethod = "GET" , rbdMethod = "GET"
@ -1040,7 +1042,7 @@ request reqBuilder = do
}) app }) app
let newCookies = parseSetCookies $ simpleHeaders response let newCookies = parseSetCookies $ simpleHeaders response
cookies' = M.fromList [(Cookie.setCookieName c, c) | c <- newCookies] `M.union` cookies 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 where
isFile (ReqFilePart _ _ _ _) = True isFile (ReqFilePart _ _ _ _) = True
isFile _ = False isFile _ = False
@ -1144,14 +1146,14 @@ testApp :: site -> Middleware -> TestApp site
testApp site middleware = (site, middleware) testApp site middleware = (site, middleware)
type YSpec site = Hspec.SpecWith (TestApp site) type YSpec site = Hspec.SpecWith (TestApp site)
instance YesodDispatch site => Hspec.Example (ST.StateT (YesodExampleData site) IO a) where instance YesodDispatch site => Hspec.Example (SIO (YesodExampleData site) a) where
type Arg (ST.StateT (YesodExampleData site) IO a) = TestApp site type Arg (SIO (YesodExampleData site) a) = TestApp site
evaluateExample example params action = evaluateExample example params action =
Hspec.evaluateExample Hspec.evaluateExample
(action $ \(site, middleware) -> do (action $ \(site, middleware) -> do
app <- toWaiAppPlain site app <- toWaiAppPlain site
_ <- ST.evalStateT example YesodExampleData _ <- evalSIO example YesodExampleData
{ yedApp = middleware app { yedApp = middleware app
, yedSite = site , yedSite = site
, yedCookies = M.empty , yedCookies = M.empty
@ -1160,3 +1162,27 @@ instance YesodDispatch site => Hspec.Example (ST.StateT (YesodExampleData site)
return ()) return ())
params 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 Data.Map as Map
import qualified Text.HTML.DOM as HD import qualified Text.HTML.DOM as HD
import Network.HTTP.Types.Status (status301, status303, unsupportedMediaType415) import Network.HTTP.Types.Status (status301, status303, unsupportedMediaType415)
import Control.Exception.Lifted(SomeException, try) import UnliftIO.Exception (tryAny, SomeException, try)
parseQuery_ :: Text -> [[SelectorGroup]] parseQuery_ :: Text -> [[SelectorGroup]]
parseQuery_ = either error id . parseQuery 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>" bodyEquals "<html><head><title>Hello</title></head><body><p>Hello World</p><p>Hello Moon</p></body></html>"
get ("/htmlWithLink" :: Text) get ("/htmlWithLink" :: Text)
(bad :: Either SomeException ()) <- try (clickOn "a#nonexistentlink") bad <- tryAny (clickOn "a#nonexistentlink")
assertEq "bad link" (isLeft bad) True assertEq "bad link" (isLeft bad) True

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

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

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

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

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

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

4
yesod/ChangeLog.md
View File

@ -1,3 +1,7 @@
## 1.6.0
* Upgrade to yesod-core 1.6
## 1.4.5 ## 1.4.5
* Fix warnings * 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 Data.Text (Text, pack, unpack)
import Yesod.Core -- purposely using complete import so that Haddock will see addStaticContent import Yesod.Core -- purposely using complete import so that Haddock will see addStaticContent
import Control.Monad (when, unless) import Control.Monad (when, unless)
import Control.Monad.Trans.Resource (runResourceT) import Conduit
import Data.Conduit (($$))
import Data.Conduit.Binary (sourceLbs, sinkFileCautious)
import System.Directory (doesFileExist, createDirectoryIfMissing) import System.Directory (doesFileExist, createDirectoryIfMissing)
import Language.Haskell.TH.Syntax import Language.Haskell.TH.Syntax
import Text.Lucius (luciusFile, luciusFileReload) import Text.Lucius (luciusFile, luciusFileReload)
@ -42,12 +40,12 @@ addStaticContentExternal
-> Text -- ^ filename extension -> Text -- ^ filename extension
-> Text -- ^ mime type -> Text -- ^ mime type
-> L.ByteString -- ^ file contents -> 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 addStaticContentExternal minify hash staticDir toRoute ext' _ content = do
liftIO $ createDirectoryIfMissing True statictmp liftIO $ createDirectoryIfMissing True statictmp
exists <- liftIO $ doesFileExist fn' exists <- liftIO $ doesFileExist fn'
unless exists $ unless exists $ withSinkFileCautious fn' $ \sink ->
liftIO $ runResourceT $ sourceLbs content' $$ sinkFileCautious fn' runConduit $ sourceLazy content' .| sink
return $ Just $ Right (toRoute ["tmp", pack fn], []) return $ Just $ Right (toRoute ["tmp", pack fn], [])
where where
fn, statictmp, fn' :: FilePath fn, statictmp, fn' :: FilePath

12
yesod/yesod.cabal
View File

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