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

Merge branch 'better-monads' into no-transformers

Browse Source
This commit is contained in:
Michael Snoyman 2018-01-11 22:47:50 +02:00
commit fbccfe2306
No known key found for this signature in database
GPG Key ID: A048E8C057E86876
42 changed files with 420 additions and 315 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
.github/PULL_REQUEST_TEMPLATE.md vendored
View File

@ -2,7 +2,7 @@ Before submitting your PR, check that you've:
- [ ] Bumped the version number - [ ] Bumped the version number
- [ ] Documented new APIs with [Haddock markup](https://www.haskell.org/haddock/doc/html/index.html) - [ ] Documented new APIs with [Haddock markup](https://www.haskell.org/haddock/doc/html/index.html)
- [ ] Added [`@since` declarations](http://haskell-haddock.readthedocs.io/en/latest/markup.html#since) to the Haddock - [ ] Added [`@since` declarations](http://haskell-haddock.readthedocs.io/en/latest/markup.html#since) to the Haddocks for new, public APIs
After submitting your PR: After submitting your PR:
@ -11,4 +11,4 @@ After submitting your PR:
<!---Thanks so much for contributing! :) <!---Thanks so much for contributing! :)
_If these checkboxes don't apply to your PR, you can delete them_--> _If these checkboxes don't apply to your PR, you can delete them_-->

77
CODE_OF_CONDUCT.md
View File

@ -1,13 +1,74 @@
# Contributor Code of Conduct # Contributor Covenant Code of Conduct
Always be nice. ## Our Pledge
When communicating online treat people the way you would if In the interest of fostering an open and welcoming environment, we as
they were standing next to you. contributors and maintainers pledge to making participation in our project and
our community a harassment-free experience for everyone, regardless of age, body
size, disability, ethnicity, gender identity and expression, level of experience,
education, socio-economic status, nationality, personal appearance, race,
religion, or sexual identity and orientation.
Don't forget to be nice whenever representing the ## Our Standards
project to others outside the project.
If you are not nice, apologize. Examples of behavior that contributes to creating a positive environment
include:
* Using welcoming and inclusive language
* Being respectful of differing viewpoints and experiences
* Gracefully accepting constructive criticism
* Focusing on what is best for the community
* Showing empathy towards other community members
Examples of unacceptable behavior by participants include:
* The use of sexualized language or imagery and unwelcome sexual attention or
advances
* Trolling, insulting/derogatory comments, and personal or political attacks
* Public or private harassment
* Publishing others' private information, such as a physical or electronic
address, without explicit permission
* Other conduct which could reasonably be considered inappropriate in a
professional setting
## Our Responsibilities
Project maintainers are responsible for clarifying the standards of acceptable
behavior and are expected to take appropriate and fair corrective action in
response to any instances of unacceptable behavior.
Project maintainers have the right and responsibility to remove, edit, or
reject comments, commits, code, wiki edits, issues, and other contributions
that are not aligned to this Code of Conduct, or to ban temporarily or
permanently any contributor for other behaviors that they deem inappropriate,
threatening, offensive, or harmful.
## Scope
This Code of Conduct applies both within project spaces and in public spaces
when an individual is representing the project or its community. Examples of
representing a project or community include using an official project e-mail
address, posting via an official social media account, or acting as an appointed
representative at an online or offline event. Representation of a project may be
further defined and clarified by project maintainers.
## Enforcement
Instances of abusive, harassing, or otherwise unacceptable behavior may be
reported by contacting the project team at `michael at snoyman dot com`. All
complaints will be reviewed and investigated and will result in a response that
is deemed necessary and appropriate to the circumstances. The project team is
obligated to maintain confidentiality with regard to the reporter of an incident.
Further details of specific enforcement policies may be posted separately.
Project maintainers who do not follow or enforce the Code of Conduct in good
faith may face temporary or permanent repercussions as determined by other
members of the project's leadership.
## Attribution
This Code of Conduct is adapted from the [Contributor Covenant][homepage], version 1.4,
available at https://www.contributor-covenant.org/version/1/4/code-of-conduct.html
[homepage]: https://www.contributor-covenant.org
If someone is not being nice, tell them in a respectful way or tell a project maintainer: we care about fostering a welcoming community.

8
stack.yaml
View File

@ -14,6 +14,8 @@ packages:
- ./yesod-eventsource - ./yesod-eventsource
- ./yesod-websockets - ./yesod-websockets
extra-deps: extra-deps:
- unliftio-core-0.1.0.0 - conduit-extra-1.2.2
- unliftio-0.2.0.0 - unliftio-core-0.1.1.0
- ../.stable/authenticate/authenticate - unliftio-0.2.4.0
- authenticate-1.3.4
- typed-process-0.2.0.0

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

@ -86,7 +86,7 @@ type Piece = Text
-- | The result of an authentication based on credentials -- | The result of an authentication based on credentials
-- --
-- Since 1.4.4 -- @since 1.4.4
data AuthenticationResult master data AuthenticationResult master
= Authenticated (AuthId master) -- ^ Authenticated successfully = Authenticated (AuthId master) -- ^ Authenticated successfully
| UserError AuthMessage -- ^ Invalid credentials provided by user | UserError AuthMessage -- ^ Invalid credentials provided by user
@ -127,7 +127,7 @@ 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 -> AuthHandler master (AuthenticationResult master) authenticate :: Creds master -> AuthHandler master (AuthenticationResult master)
authenticate creds = do authenticate creds = do
muid <- getAuthId creds muid <- getAuthId creds
@ -185,7 +185,8 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage
-- | When being redirected to the login page should the current page -- | When being redirected to the login page should the current page
-- be set to redirect back to. Default is 'True'. -- be set to redirect back to. Default is 'True'.
-- @since 1.4.18 --
-- @since 1.4.21
redirectToCurrent :: master -> Bool redirectToCurrent :: master -> Bool
redirectToCurrent _ = True redirectToCurrent _ = True
@ -213,7 +214,7 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage
-- especially useful for creating an API to be accessed via some means -- especially useful for creating an API to be accessed via some means
-- other than a browser. -- other than a browser.
-- --
-- Since 1.2.0 -- @since 1.2.0
maybeAuthId :: AuthHandler master (Maybe (AuthId master)) maybeAuthId :: AuthHandler master (Maybe (AuthId master))
default maybeAuthId default maybeAuthId
@ -248,7 +249,7 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage
-- | Internal session key used to hold the authentication information. -- | Internal session key used to hold the authentication information.
-- --
-- Since 1.2.3 -- @since 1.2.3
credsKey :: Text credsKey :: Text
credsKey = "_ID" credsKey = "_ID"
@ -258,7 +259,7 @@ credsKey = "_ID"
-- 'maybeAuthIdRaw' for more information. The first call in a request -- 'maybeAuthIdRaw' for more information. The first call in a request
-- does a database request to make sure that the account is still in the database. -- does a database request to make sure that the account is still in the database.
-- --
-- Since 1.1.2 -- @since 1.1.2
defaultMaybeAuthId defaultMaybeAuthId
:: (YesodAuthPersist master, Typeable (AuthEntity master)) :: (YesodAuthPersist master, Typeable (AuthEntity master))
=> AuthHandler master (Maybe (AuthId master)) => AuthHandler master (Maybe (AuthId master))
@ -284,7 +285,7 @@ cachedAuth
-- This is the default 'loginHandler'. It concatenates plugin widgets and -- This is the default 'loginHandler'. It concatenates plugin widgets and
-- wraps the result in 'authLayout'. See 'loginHandler' for more details. -- wraps the result in 'authLayout'. See 'loginHandler' for more details.
-- --
-- Since 1.4.9 -- @since 1.4.9
defaultLoginHandler :: AuthHandler master Html defaultLoginHandler :: AuthHandler master Html
defaultLoginHandler = do defaultLoginHandler = do
tp <- getRouteToParent tp <- getRouteToParent
@ -410,7 +411,7 @@ 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 :: Bool -- ^ if HTTP redirect to 'logoutDest' should be done clearCreds :: Bool -- ^ if HTTP redirect to 'logoutDest' should be done
-> AuthHandler master () -> AuthHandler master ()
clearCreds doRedirects = do clearCreds doRedirects = do
@ -470,7 +471,7 @@ handlePluginR plugin pieces = do
-- with the user\'s database identifier to get the value in the database. This -- with the user\'s database identifier to get the value in the database. This
-- assumes that you are using a Persistent database. -- assumes that you are using a Persistent database.
-- --
-- Since 1.1.0 -- @since 1.1.0
maybeAuth :: ( YesodAuthPersist master maybeAuth :: ( YesodAuthPersist master
, val ~ AuthEntity master , val ~ AuthEntity master
, Key val ~ AuthId master , Key val ~ AuthId master
@ -482,7 +483,7 @@ maybeAuth = fmap (fmap (uncurry Entity)) maybeAuthPair
-- | 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 maybeAuthPair
:: (YesodAuthPersist master, Typeable (AuthEntity master)) :: (YesodAuthPersist master, Typeable (AuthEntity master))
=> AuthHandler master (Maybe (AuthId master, AuthEntity master)) => AuthHandler master (Maybe (AuthId master, AuthEntity master))
@ -504,7 +505,7 @@ newtype CachedMaybeAuth val = CachedMaybeAuth { unCachedMaybeAuth :: Maybe val }
-- given value. This is the common case in Yesod, and means that you can -- given value. This is the common case in Yesod, and means that you can
-- easily look up the full information on a given user. -- easily look up the full information on a given user.
-- --
-- Since 1.4.0 -- @since 1.4.0
class (YesodAuth master, YesodPersist master) => YesodAuthPersist master where class (YesodAuth master, YesodPersist master) => YesodAuthPersist master where
-- | If the @AuthId@ for a given site is a persistent ID, this will give the -- | If the @AuthId@ for a given site is a persistent ID, this will give the
-- value for that entity. E.g.: -- value for that entity. E.g.:
@ -512,7 +513,7 @@ class (YesodAuth master, YesodPersist master) => YesodAuthPersist master where
-- > type AuthId MySite = UserId -- > type AuthId MySite = UserId
-- > AuthEntity MySite ~ User -- > AuthEntity MySite ~ User
-- --
-- Since 1.2.0 -- @since 1.2.0
type AuthEntity master :: * type AuthEntity master :: *
type AuthEntity master = KeyEntity (AuthId master) type AuthEntity master = KeyEntity (AuthId master)
@ -524,8 +525,8 @@ class (YesodAuth master, YesodPersist master) => YesodAuthPersist master where
, Key (AuthEntity master) ~ AuthId master , Key (AuthEntity master) ~ AuthId master
, PersistStore backend , PersistStore backend
) )
=> AuthId master -> HandlerFor master (Maybe (AuthEntity master)) => AuthId master -> AuthHandler master (Maybe (AuthEntity master))
getAuthEntity = runDB . get getAuthEntity = liftHandler . runDB . get
type family KeyEntity key type family KeyEntity key
@ -534,14 +535,14 @@ type instance KeyEntity (Key x) = x
-- | Similar to 'maybeAuthId', but redirects to a login page if user is not -- | Similar to 'maybeAuthId', but redirects to a login page if user is not
-- 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 :: AuthHandler master (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
-- 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
requireAuth :: ( YesodAuthPersist master requireAuth :: ( YesodAuthPersist master
, val ~ AuthEntity master , val ~ AuthEntity master
, Key val ~ AuthId master , Key val ~ AuthId master
@ -553,7 +554,7 @@ 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 requireAuthPair
:: ( YesodAuthPersist master :: ( YesodAuthPersist master
, Typeable (AuthEntity master) , Typeable (AuthEntity master)

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

@ -65,7 +65,7 @@ import Yesod.Core (HandlerSite, MonadHandler,
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)
@ -84,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 (($$+-), ($$), (.|), runConduit)
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)
@ -262,7 +262,8 @@ authPlugin storeToken clientID clientSecret =
makeHttpRequest :: Request -> AuthHandler site A.Value makeHttpRequest :: Request -> AuthHandler site A.Value
makeHttpRequest req = makeHttpRequest req =
runHttpRequest req $ \res -> bodyReaderSource (responseBody res) $$ sinkParser json' liftSubHandler $ runHttpRequest req $ \res ->
runConduit $ 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'.
@ -270,7 +271,7 @@ makeHttpRequest req =
-- --
-- @since 1.4.3 -- @since 1.4.3
getPerson :: Manager -> Token -> AuthHandler site (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' responseBody res $$+- sinkParser json'

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

@ -44,6 +44,7 @@ library
, http-client-tls , http-client-tls
, http-conduit >= 2.1 , http-conduit >= 2.1
, aeson >= 0.7 , aeson >= 0.7
, unliftio
, blaze-html >= 0.5 , blaze-html >= 0.5
, blaze-markup >= 0.5.1 , blaze-markup >= 0.5.1
, http-types , http-types
@ -58,7 +59,7 @@ 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-core

4
yesod-bin/ChangeLog.md
View File

@ -1,3 +1,7 @@
## 1.5.3
* Support typed-process-0.2.0.0
## 1.5.2.6 ## 1.5.2.6
* Drop an upper bound * Drop an upper bound

13
yesod-bin/Devel.hs
View File

@ -17,9 +17,7 @@ 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
@ -61,7 +59,7 @@ import System.FilePath (takeDirectory,
import System.FSNotify import System.FSNotify
import System.IO (stdout, stderr) import System.IO (stdout, stderr)
import System.IO.Error (isDoesNotExistError) import System.IO.Error (isDoesNotExistError)
import System.Process.Typed import Data.Conduit.Process.Typed
-- We have two special files: -- We have two special files:
-- --
@ -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

16
yesod-bin/HsFile.hs
View File

@ -2,20 +2,18 @@
{-# 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 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)

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

@ -1,5 +1,5 @@
name: yesod-bin name: yesod-bin
version: 1.5.2.6 version: 1.5.3
license: MIT license: MIT
license-file: LICENSE license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com> author: Michael Snoyman <michael@snoyman.com>
@ -48,9 +48,9 @@ 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 , conduit-extra >= 1.3
, resourcet >= 0.3 && < 1.2 , resourcet >= 1.2
, base64-bytestring , base64-bytestring
, http-reverse-proxy >= 0.4 , http-reverse-proxy >= 0.4
, network >= 2.5 , network >= 2.5
@ -70,7 +70,6 @@ executable yesod
, warp-tls >= 3.0.1 , warp-tls >= 3.0.1
, async , async
, deepseq , deepseq
, typed-process
ghc-options: -Wall -threaded -rtsopts ghc-options: -Wall -threaded -rtsopts
main-is: main.hs main-is: main.hs

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

@ -76,6 +76,9 @@ module Yesod.Core
, getApprootText , getApprootText
-- * Subsites -- * Subsites
, MonadSubHandler (..) , MonadSubHandler (..)
, getSubYesod
, getRouteToParent
, getSubCurrentRoute
, SubsiteData , SubsiteData
-- * Misc -- * Misc
, yesodVersion , yesodVersion
@ -96,8 +99,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
@ -144,9 +146,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 Control.Monad.IO.Unlift (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

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

@ -45,32 +45,49 @@ data SubsiteData child parent = SubsiteData
class MonadHandler m => MonadSubHandler m where class MonadHandler m => MonadSubHandler m where
type SubHandlerSite m type SubHandlerSite m
getSubYesod :: m (SubHandlerSite m) liftSubHandler :: ReaderT (SubsiteData (SubHandlerSite m) (HandlerSite m)) (HandlerFor (HandlerSite m)) a -> m a
getRouteToParent :: m (Route (SubHandlerSite m) -> Route (HandlerSite m))
getSubCurrentRoute :: m (Maybe (Route (SubHandlerSite m))) getSubYesod :: MonadSubHandler m => m (SubHandlerSite m)
getSubYesod = liftSubHandler $ ReaderT $ return . sdSubsiteData
getRouteToParent :: MonadSubHandler m => m (Route (SubHandlerSite m) -> Route (HandlerSite m))
getRouteToParent = liftSubHandler $ ReaderT $ return . sdRouteToParent
getSubCurrentRoute :: MonadSubHandler m => m (Maybe (Route (SubHandlerSite m)))
getSubCurrentRoute = liftSubHandler $ ReaderT $ return . sdCurrentRoute
instance MonadSubHandler (HandlerFor site) where instance MonadSubHandler (HandlerFor site) where
type SubHandlerSite (HandlerFor site) = site type SubHandlerSite (HandlerFor site) = site
getSubYesod = getYesod liftSubHandler (ReaderT x) = do
getRouteToParent = return id parent <- getYesod
getSubCurrentRoute = getCurrentRoute currentRoute <- getCurrentRoute
x SubsiteData
{ sdRouteToParent = id
, sdCurrentRoute = currentRoute
, sdSubsiteData = parent
}
instance MonadSubHandler (WidgetFor site) where instance MonadSubHandler (WidgetFor site) where
type SubHandlerSite (WidgetFor site) = site type SubHandlerSite (WidgetFor site) = site
getSubYesod = getYesod liftSubHandler (ReaderT x) = do
getRouteToParent = return id parent <- getYesod
getSubCurrentRoute = getCurrentRoute currentRoute <- getCurrentRoute
liftHandler $ x SubsiteData
{ sdRouteToParent = id
, sdCurrentRoute = currentRoute
, sdSubsiteData = parent
}
instance (MonadSubHandler m, parent ~ SubHandlerSite m) => MonadSubHandler (ReaderT (SubsiteData child parent) m) where instance (MonadSubHandler m, parent ~ SubHandlerSite m) => MonadSubHandler (ReaderT (SubsiteData child parent) m) where
type SubHandlerSite (ReaderT (SubsiteData child parent) m) = child type SubHandlerSite (ReaderT (SubsiteData child parent) m) = child
getSubYesod = fmap sdSubsiteData ask liftSubHandler (ReaderT f) = ReaderT $ \env -> do
getSubCurrentRoute = fmap sdCurrentRoute ask
getRouteToParent = ReaderT $ \sd -> do
toParent' <- getRouteToParent toParent' <- getRouteToParent
return $ toParent' . sdRouteToParent sd liftHandler $ f env
{ sdRouteToParent = toParent' . sdRouteToParent env
}
subHelper subHelper
:: (ToTypedContent content, MonadSubHandler m, master ~ HandlerSite m, parent ~ SubHandlerSite m) :: (ToTypedContent content, MonadSubHandler m, master ~ HandlerSite m, parent ~ SubHandlerSite m)

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

@ -5,7 +5,6 @@
{-# 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 (..)
@ -15,6 +14,7 @@ module Yesod.Core.Class.Handler
import Yesod.Core.Types import Yesod.Core.Types
import Control.Monad.Logger (MonadLogger) import Control.Monad.Logger (MonadLogger)
import Control.Monad.IO.Unlift (liftIO, MonadUnliftIO, MonadIO)
import Control.Monad.Trans.Resource (MonadResource) import Control.Monad.Trans.Resource (MonadResource)
import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Class (lift)
#if __GLASGOW_HASKELL__ < 710 #if __GLASGOW_HASKELL__ < 710
@ -25,7 +25,6 @@ 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)
import Control.Monad.Trans.Except ( ExceptT ) import Control.Monad.Trans.Except ( ExceptT )
import Control.Monad.Trans.Reader ( ReaderT ) import Control.Monad.Trans.Reader ( ReaderT )
import Control.Monad.Trans.State ( StateT ) import Control.Monad.Trans.State ( StateT )
@ -59,7 +58,6 @@ instance MonadHandler (WidgetFor site) where
GO(IdentityT) GO(IdentityT)
GO(ListT) GO(ListT)
GO(MaybeT) GO(MaybeT)
GOX(Error e, ErrorT e)
GO(ExceptT e) GO(ExceptT e)
GO(ReaderT r) GO(ReaderT r)
GO(StateT s) GO(StateT s)
@ -88,7 +86,6 @@ liftWidgetT = liftWidget
GO(IdentityT) GO(IdentityT)
GO(ListT) GO(ListT)
GO(MaybeT) GO(MaybeT)
GOX(Error e, ErrorT e)
GO(ExceptT e) GO(ExceptT e)
GO(ReaderT r) GO(ReaderT r)
GO(StateT s) GO(StateT s)

18
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, toLazyByteString)
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
@ -25,6 +24,7 @@ import Control.Monad.Logger (LogLevel (LevelInfo, LevelO
import Control.Monad.Trans.Resource (InternalState, createInternalState, closeInternalState) import Control.Monad.Trans.Resource (InternalState, createInternalState, closeInternalState)
import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Lazy.Char8 as BL8
import Data.Aeson (object, (.=)) import Data.Aeson (object, (.=))
import Data.List (foldl', nub) import Data.List (foldl', nub)
import qualified Data.Map as Map import qualified Data.Map as Map
@ -112,10 +112,10 @@ class RenderRoute site => Yesod site where
-- | 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
@ -125,11 +125,11 @@ class RenderRoute site => Yesod site where
where where
addParams [] routeBldr = routeBldr addParams [] routeBldr = routeBldr
addParams nonEmptyParams routeBldr = addParams nonEmptyParams routeBldr =
let routeBS = toByteString routeBldr let routeBS = toLazyByteString routeBldr
qsSeparator = fromChar $ if S8.elem '?' routeBS then '&' else '?' qsSeparator = if BL8.elem '?' routeBS then "&" else "?"
valueToMaybe t = if t == "" then Nothing else Just t valueToMaybe t = if t == "" then Nothing else Just t
queryText = map (id *** valueToMaybe) nonEmptyParams queryText = map (id *** valueToMaybe) nonEmptyParams
in copyByteString routeBS `mappend` qsSeparator `mappend` renderQueryText False queryText in routeBldr `mappend` qsSeparator `mappend` renderQueryText False queryText
-- | Determine if a request is authorized or not. -- | Determine if a request is authorized or not.
-- --
@ -191,7 +191,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'

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

@ -53,20 +53,21 @@ 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), ResumableSource, 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 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
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)
@ -93,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
@ -117,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 (ResumableSource (ResourceT IO) builder) where
toContent (ResumableSource src _) = toContent src toContent (ResumableSource 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.
@ -131,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

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

@ -52,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
@ -114,7 +115,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:
@ -128,7 +129,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:

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

@ -194,12 +194,12 @@ import Data.Monoid (mempty, mappend)
#endif #endif
import Control.Applicative ((<|>)) import Control.Applicative ((<|>))
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 Control.Monad.IO.Unlift (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
@ -233,21 +233,20 @@ import Yesod.Core.Content (ToTypedContent (..), simpleConte
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
@ -449,7 +448,8 @@ forkHandler :: (SomeException -> HandlerFor site ()) -- ^ error handler
-> HandlerFor site () -> 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
@ -666,10 +666,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
@ -681,10 +681,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
@ -1339,7 +1340,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
@ -1351,7 +1352,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.
@ -1372,7 +1373,7 @@ respond ct = return . TypedContent ct . toContent
-- --
-- @since 1.2.0 -- @since 1.2.0
respondSource :: ContentType respondSource :: ContentType
-> Source (HandlerFor site) (Flush Builder) -> ConduitT () (Flush Builder) (HandlerFor site) ()
-> HandlerFor site TypedContent -> HandlerFor site TypedContent
respondSource ctype src = HandlerFor $ \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
@ -1385,44 +1386,44 @@ respondSource ctype src = HandlerFor $ \hd ->
-- 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
-- $ajaxCSRFOverview -- $ajaxCSRFOverview

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

@ -33,9 +33,7 @@ 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.Monad.Trans.Resource (runResourceT, ResourceT)
import Control.Exception (throwIO) import Control.Exception (throwIO)
@ -176,7 +174,7 @@ 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 -> runResourceT $ sourceFile fp $$ sinkFile dst)

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

@ -6,6 +6,7 @@ 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 qualified Data.CaseInsensitive as CI
import Network.Wai import Network.Wai
@ -18,8 +19,7 @@ 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)
@ -83,7 +83,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
@ -100,7 +100,7 @@ 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

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

@ -14,7 +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 qualified Data.ByteString.Lazy as BL
import Control.Exception (fromException, evaluate) import Control.Exception (fromException, evaluate)
import qualified Control.Exception as E import qualified Control.Exception as E
import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.IO.Class (MonadIO, liftIO)
@ -371,7 +372,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')

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

@ -104,7 +104,7 @@ provideJson = provideRep . return . J.toEncoding
-- @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

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

@ -10,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 ((<$>))
@ -20,16 +19,13 @@ import Data.Monoid (Monoid (..))
import Control.Arrow (first) import Control.Arrow (first)
import Control.Exception (Exception) import Control.Exception (Exception)
import Control.Monad (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 (..), 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.Conduit (Flush, ConduitT)
import Data.IORef (IORef, modifyIORef') 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
@ -62,7 +58,6 @@ import Control.Monad.Reader (MonadReader (..))
import Data.Monoid ((<>)) import Data.Monoid ((<>))
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)
import Control.Monad.Logger (MonadLoggerIO (..)) import Control.Monad.Logger (MonadLoggerIO (..))
import Data.Semigroup (Semigroup) import Data.Semigroup (Semigroup)
@ -137,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.
-- --
@ -293,8 +288,8 @@ data PageContent url = PageContent
, 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
@ -417,14 +412,6 @@ instance Monad (WidgetFor site) where
unWidgetFor (f a) wd unWidgetFor (f a) wd
instance MonadIO (WidgetFor site) where instance MonadIO (WidgetFor site) where
liftIO = WidgetFor . const liftIO = WidgetFor . const
instance b ~ IO => MonadBase b (WidgetFor site) where
liftBase = WidgetFor . const
instance b ~ IO => MonadBaseControl b (WidgetFor site) where
type StM (WidgetFor site) a = a
liftBaseWith f = WidgetFor $ \wd ->
liftBaseWith $ \runInBase ->
f $ runInBase . (flip unWidgetFor wd)
restoreM = WidgetFor . const . return
-- | @since 1.4.38 -- | @since 1.4.38
instance MonadUnliftIO (WidgetFor site) where instance MonadUnliftIO (WidgetFor site) where
{-# INLINE askUnliftIO #-} {-# INLINE askUnliftIO #-}
@ -437,23 +424,6 @@ instance MonadReader (WidgetData site) (WidgetFor site) where
instance MonadThrow (WidgetFor site) where instance MonadThrow (WidgetFor site) where
throwM = liftIO . throwM throwM = liftIO . throwM
instance MonadCatch (HandlerFor site) where
catch (HandlerFor m) c = HandlerFor $ \r -> m r `catch` \e -> unHandlerFor (c e) r
instance MonadMask (HandlerFor site) where
mask a = HandlerFor $ \e -> mask $ \u -> unHandlerFor (a $ q u) e
where q u (HandlerFor b) = HandlerFor (u . b)
uninterruptibleMask a =
HandlerFor $ \e -> uninterruptibleMask $ \u -> unHandlerFor (a $ q u) e
where q u (HandlerFor b) = HandlerFor (u . b)
instance MonadCatch (WidgetFor site) where
catch (WidgetFor m) c = WidgetFor $ \r -> m r `catch` \e -> unWidgetFor (c e) r
instance MonadMask (WidgetFor site) where
mask a = WidgetFor $ \e -> mask $ \u -> unWidgetFor (a $ q u) e
where q u (WidgetFor b) = WidgetFor (u . b)
uninterruptibleMask a =
WidgetFor $ \e -> uninterruptibleMask $ \u -> unWidgetFor (a $ q u) e
where q u (WidgetFor b) = WidgetFor (u . b)
instance MonadResource (WidgetFor site) where instance MonadResource (WidgetFor site) where
liftResourceT f = WidgetFor $ runInternalState f . handlerResource . wdHandler liftResourceT f = WidgetFor $ runInternalState f . handlerResource . wdHandler
@ -464,12 +434,6 @@ instance MonadLogger (WidgetFor site) where
instance MonadLoggerIO (WidgetFor site) where instance MonadLoggerIO (WidgetFor site) where
askLoggerIO = WidgetFor $ return . rheLog . handlerEnv . wdHandler askLoggerIO = WidgetFor $ return . rheLog . handlerEnv . wdHandler
-- FIXME look at implementation of ResourceT
instance MonadActive (WidgetFor site) where
monadActive = liftIO monadActive
instance MonadActive (HandlerFor site) where
monadActive = liftIO monadActive
-- Instances for HandlerT -- Instances for HandlerT
instance Applicative (HandlerFor site) where instance Applicative (HandlerFor site) where
pure = HandlerFor . const . return pure = HandlerFor . const . return
@ -479,26 +443,10 @@ instance Monad (HandlerFor site) where
HandlerFor x >>= f = HandlerFor $ \r -> x r >>= \x' -> unHandlerFor (f x') r HandlerFor x >>= f = HandlerFor $ \r -> x r >>= \x' -> unHandlerFor (f x') r
instance MonadIO (HandlerFor site) where instance MonadIO (HandlerFor site) where
liftIO = HandlerFor . const liftIO = HandlerFor . const
instance b ~ IO => MonadBase b (HandlerFor site) where
liftBase = liftIO
instance MonadReader (HandlerData site) (HandlerFor site) where instance MonadReader (HandlerData site) (HandlerFor site) where
ask = HandlerFor return ask = HandlerFor return
local f (HandlerFor g) = HandlerFor $ g . f local f (HandlerFor g) = HandlerFor $ g . f
-- | 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 b ~ IO => MonadBaseControl b (HandlerFor site) where
type StM (HandlerFor site) a = a
liftBaseWith f = HandlerFor $ \reader' ->
liftBaseWith $ \runInBase ->
f $ runInBase . (flip unHandlerFor reader')
restoreM = HandlerFor . const . return
-- | @since 1.4.38 -- | @since 1.4.38
instance MonadUnliftIO (HandlerFor site) where instance MonadUnliftIO (HandlerFor site) where
{-# INLINE askUnliftIO #-} {-# INLINE askUnliftIO #-}
@ -524,7 +472,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)]

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

@ -1,7 +1,7 @@
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
-- | This is designed to be used as -- | This is designed to be used as
-- --
-- > qualified import Yesod.Core.Unsafe as Unsafe -- > import qualified Yesod.Core.Unsafe as Unsafe
-- --
-- This serves as a reminder that the functions are unsafe to use in many situations. -- This serves as a reminder that the functions are unsafe to use in many situations.
module Yesod.Core.Unsafe (runFakeHandler, fakeHandlerGetLogger) where module Yesod.Core.Unsafe (runFakeHandler, fakeHandlerGetLogger) where

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)

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"

9
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
@ -46,16 +45,16 @@ getHomeR = do
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

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

@ -25,12 +25,11 @@ library
, time >= 1.5 , 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.4
, mtl , mtl
, clientsession >= 0.9.1 && < 0.10 , clientsession >= 0.9.1 && < 0.10
@ -39,8 +38,6 @@ 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 >= 1.0 && < 1.1
, transformers-base >= 0.4
, cookie >= 0.4.2 && < 0.5 , cookie >= 0.4.2 && < 0.5
, http-types >= 0.7 , http-types >= 0.7
, case-insensitive >= 0.2 , case-insensitive >= 0.2
@ -51,19 +48,19 @@ library
, fast-logger >= 2.2 , fast-logger >= 2.2
, wai-logger >= 0.2 , wai-logger >= 0.2
, monad-logger >= 0.3.10 && < 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
-- FIXME remove!
, data-default , 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
-- FIXME remove
, mwc-random , mwc-random
, primitive , primitive
, word8 , word8
@ -190,13 +187,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
@ -206,6 +201,7 @@ test-suite tests
, wai-extra , wai-extra
, mwc-random , 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

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

@ -16,7 +16,7 @@ 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.4.*
, 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

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

@ -2,7 +2,7 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE CPP#-} {-# LANGUAGE CPP #-}
-- | A module providing a means of creating multiple input forms, such as a -- | A module providing a means of creating multiple input forms, such as a
-- list of 0 or more recipients. -- list of 0 or more recipients.
module Yesod.Form.MassInput module Yesod.Form.MassInput

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

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

@ -93,10 +93,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 Data.Functor.Identity (runIdentity)
import System.FilePath ((</>), (<.>), takeDirectory) import System.FilePath ((</>), (<.>), takeDirectory)
import qualified System.FilePath as F import qualified System.FilePath as F
@ -422,8 +419,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)
@ -458,8 +455,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
@ -473,7 +473,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

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

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

8
yesod-test/ChangeLog.md
View File

@ -1,3 +1,11 @@
## 1.5.9.1
* Fixes a Haddock syntax error in 1.5.9 [#1473](https://github.com/yesodweb/yesod/pull/1473)
## 1.5.9
* Add byLabelExact and related functions
[#1459](https://github.com/yesodweb/yesod/pull/1459)
## 1.5.8 ## 1.5.8
* Added implicit parameter HasCallStack to assertions. * Added implicit parameter HasCallStack to assertions.
[#1421](https://github.com/yesodweb/yesod/pull/1421) [#1421](https://github.com/yesodweb/yesod/pull/1421)

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

@ -73,7 +73,9 @@ module Yesod.Test
-- These functions let you add parameters to your request based -- These functions let you add parameters to your request based
-- on currently displayed label names. -- on currently displayed label names.
, byLabel , byLabel
, byLabelExact
, fileByLabel , fileByLabel
, fileByLabelExact
-- *** CSRF Tokens -- *** CSRF Tokens
-- | In order to prevent CSRF exploits, yesod-form adds a hidden input -- | In order to prevent CSRF exploits, yesod-form adds a hidden input
@ -163,6 +165,8 @@ import GHC.Exts (Constraint)
type HasCallStack = (() :: Constraint) type HasCallStack = (() :: Constraint)
#endif #endif
{-# DEPRECATED byLabel "This function seems to have multiple bugs (ref: https://github.com/yesodweb/yesod/pull/1459). Use byLabelExact instead" #-}
{-# DEPRECATED fileByLabel "This function seems to have multiple bugs (ref: https://github.com/yesodweb/yesod/pull/1459). Use fileByLabelExact instead" #-}
-- | The state used in a single test case defined using 'yit' -- | The state used in a single test case defined using 'yit'
-- --
@ -524,23 +528,24 @@ addFile name path mimetype = do
addPostData (MultipleItemsPostData posts) contents = addPostData (MultipleItemsPostData posts) contents =
MultipleItemsPostData $ ReqFilePart name path contents mimetype : posts MultipleItemsPostData $ ReqFilePart name path contents mimetype : posts
-- |
-- 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.
nameFromLabel :: T.Text -> RequestBuilder site T.Text genericNameFromLabel :: (T.Text -> T.Text -> Bool) -> T.Text -> RequestBuilder site T.Text
nameFromLabel label = do genericNameFromLabel match label = do
mres <- fmap rbdResponse getState mres <- fmap rbdResponse getState
res <- res <-
case mres of case mres of
Nothing -> failure "nameFromLabel: No response available" Nothing -> failure "genericNameFromLabel: No response available"
Just res -> return res Just res -> return res
let let
body = simpleBody res body = simpleBody res
mlabel = parseHTML body mlabel = parseHTML body
$// C.element "label" $// C.element "label"
>=> contentContains label >=> isContentMatch label
mfor = mlabel >>= attribute "for" mfor = mlabel >>= attribute "for"
contentContains x c isContentMatch x c
| x `T.isInfixOf` T.concat (c $// content) = [c] | x `match` T.concat (c $// content) = [c]
| otherwise = [] | otherwise = []
case mfor of case mfor of
@ -567,6 +572,14 @@ nameFromLabel label = do
(<>) :: T.Text -> T.Text -> T.Text (<>) :: T.Text -> T.Text -> T.Text
(<>) = T.append (<>) = T.append
byLabelWithMatch :: (T.Text -> T.Text -> Bool) -- ^ The matching method which is used to find labels (i.e. exact, contains)
-> T.Text -- ^ The text contained in the @\<label>@.
-> T.Text -- ^ The value to set the parameter to.
-> RequestBuilder site ()
byLabelWithMatch match label value = do
name <- genericNameFromLabel match label
addPostParam name value
-- How does this work for the alternate <label><input></label> syntax? -- How does this work for the alternate <label><input></label> syntax?
-- | Finds the @\<label>@ with the given value, finds its corresponding @\<input>@, then adds a parameter -- | Finds the @\<label>@ with the given value, finds its corresponding @\<input>@, then adds a parameter
@ -592,12 +605,60 @@ nameFromLabel label = do
-- > <form method="POST"> -- > <form method="POST">
-- > <label>Username <input name="f1"> </label> -- > <label>Username <input name="f1"> </label>
-- > </form> -- > </form>
--
-- Warning: This function looks for any label that contains the provided text.
-- If multiple labels contain that text, this function will throw an error,
-- as in the example below:
--
-- > <form method="POST">
-- > <label for="nickname">Nickname</label>
-- > <input id="nickname" name="f1" />
--
-- > <label for="nickname2">Nickname2</label>
-- > <input id="nickname2" name="f2" />
-- > </form>
--
-- > request $ do
-- > byLabel "Nickname" "Snoyberger"
--
-- Then, it throws "More than one label contained" error.
--
-- Therefore, this function is deprecated. Please consider using 'byLabelExact',
-- which performs the exact match over the provided text.
byLabel :: T.Text -- ^ The text contained in the @\<label>@. byLabel :: T.Text -- ^ The text contained in the @\<label>@.
-> T.Text -- ^ The value to set the parameter to. -> T.Text -- ^ The value to set the parameter to.
-> RequestBuilder site () -> RequestBuilder site ()
byLabel label value = do byLabel = byLabelWithMatch T.isInfixOf
name <- nameFromLabel label
addPostParam name value -- | Finds the @\<label>@ with the given value, finds its corresponding @\<input>@, then adds a parameter
-- for that input to the request body.
--
-- ==== __Examples__
--
-- Given this HTML, we want to submit @f1=Michael@ to the server:
--
-- > <form method="POST">
-- > <label for="user">Username</label>
-- > <input id="user" name="f1" />
-- > </form>
--
-- You can set this parameter like so:
--
-- > request $ do
-- > byLabel "Username" "Michael"
--
-- This function also supports the implicit label syntax, in which
-- the @\<input>@ is nested inside the @\<label>@ rather than specified with @for@:
--
-- > <form method="POST">
-- > <label>Username <input name="f1"> </label>
-- > </form>
--
-- @since 1.5.9
byLabelExact :: T.Text -- ^ The text in the @\<label>@.
-> T.Text -- ^ The value to set the parameter to.
-> RequestBuilder site ()
byLabelExact = byLabelWithMatch (==)
-- | Finds the @\<label>@ with the given value, finds its corresponding @\<input>@, then adds a file for that input to the request body. -- | Finds the @\<label>@ with the given value, finds its corresponding @\<input>@, then adds a file for that input to the request body.
-- --
@ -621,12 +682,46 @@ byLabel label value = do
-- > <form method="POST"> -- > <form method="POST">
-- > <label>Please submit an image <input type="file" name="f1"> </label> -- > <label>Please submit an image <input type="file" name="f1"> </label>
-- > </form> -- > </form>
--
-- Warning: This function has the same issue as 'byLabel'. Please use 'fileByLabelExact' instead.
fileByLabel :: T.Text -- ^ The text contained in the @\<label>@. fileByLabel :: T.Text -- ^ The text contained in the @\<label>@.
-> FilePath -- ^ The path to the file. -> FilePath -- ^ The path to the file.
-> T.Text -- ^ The MIME type of the file, e.g. "image/png". -> T.Text -- ^ The MIME type of the file, e.g. "image/png".
-> RequestBuilder site () -> RequestBuilder site ()
fileByLabel label path mime = do fileByLabel label path mime = do
name <- nameFromLabel label name <- genericNameFromLabel T.isInfixOf label
addFile name path mime
-- | Finds the @\<label>@ with the given value, finds its corresponding @\<input>@, then adds a file for that input to the request body.
--
-- ==== __Examples__
--
-- Given this HTML, we want to submit a file with the parameter name @f1@ to the server:
--
-- > <form method="POST">
-- > <label for="imageInput">Please submit an image</label>
-- > <input id="imageInput" type="file" name="f1" accept="image/*">
-- > </form>
--
-- You can set this parameter like so:
--
-- > request $ do
-- > fileByLabel "Please submit an image" "static/img/picture.png" "img/png"
--
-- This function also supports the implicit label syntax, in which
-- the @\<input>@ is nested inside the @\<label>@ rather than specified with @for@:
--
-- > <form method="POST">
-- > <label>Please submit an image <input type="file" name="f1"> </label>
-- > </form>
--
-- @since 1.5.9
fileByLabelExact :: T.Text -- ^ The text contained in the @\<label>@.
-> FilePath -- ^ The path to the file.
-> T.Text -- ^ The MIME type of the file, e.g. "image/png".
-> RequestBuilder site ()
fileByLabelExact label path mime = do
name <- genericNameFromLabel (==) label
addFile name path mime addFile name path mime
-- | Lookups the hidden input named "_token" and adds its value to the params. -- | Lookups the hidden input named "_token" and adds its value to the params.

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

@ -1,3 +1,6 @@
-- Ignore warnings about using deprecated byLabel/fileByLabel functions
{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
@ -34,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 UnliftIO (tryAny) import UnliftIO (tryAny, SomeException, try)
parseQuery_ :: Text -> [[SelectorGroup]] parseQuery_ :: Text -> [[SelectorGroup]]
parseQuery_ = either error id . parseQuery parseQuery_ = either error id . parseQuery
@ -215,6 +218,22 @@ main = hspec $ do
setMethod "POST" setMethod "POST"
setUrl ("/labels" :: Text) setUrl ("/labels" :: Text)
byLabel "Foo Bar" "yes" byLabel "Foo Bar" "yes"
ydescribe "labels2" $ do
yit "fails with \"More than one label contained\" error" $ do
get ("/labels2" :: Text)
(bad :: Either SomeException ()) <- try (request $ do
setMethod "POST"
setUrl ("labels2" :: Text)
byLabel "hobby" "fishing")
assertEq "failure wasn't called" (isLeft bad) True
yit "byLabelExact performs an exact match over the given label name" $ do
get ("/labels2" :: Text)
(bad :: Either SomeException ()) <- try (request $ do
setMethod "POST"
setUrl ("labels2" :: Text)
byLabelExact "hobby" "fishing")
assertEq "failure was called" (isRight bad) True
ydescribe "Content-Type handling" $ do ydescribe "Content-Type handling" $ do
yit "can set a content-type" $ do yit "can set a content-type" $ do
request $ do request $ do
@ -362,6 +381,8 @@ app = liteApp $ do
return ("<html><head><title>A link</title></head><body><a href=\"/html\" id=\"thelink\">Link!</a></body></html>" :: Text) return ("<html><head><title>A link</title></head><body><a href=\"/html\" id=\"thelink\">Link!</a></body></html>" :: Text)
onStatic "labels" $ dispatchTo $ onStatic "labels" $ dispatchTo $
return ("<html><label><input type='checkbox' name='fooname' id='foobar'>Foo Bar</label></html>" :: Text) return ("<html><label><input type='checkbox' name='fooname' id='foobar'>Foo Bar</label></html>" :: Text)
onStatic "labels2" $ dispatchTo $
return ("<html><label for='hobby'>hobby</label><label for='hobby2'>hobby2</label><input type='text' name='hobby' id='hobby'><input type='text' name='hobby2' id='hobby2'></html>" :: Text)
onStatic "checkContentType" $ dispatchTo $ do onStatic "checkContentType" $ dispatchTo $ do
headers <- requestHeaders <$> waiRequest headers <- requestHeaders <$> waiRequest

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

@ -1,5 +1,5 @@
name: yesod-test name: yesod-test
version: 1.5.8 version: 1.5.9.1
license: MIT license: MIT
license-file: LICENSE license-file: LICENSE
author: Nubis <nubis@woobiz.com.ar> author: Nubis <nubis@woobiz.com.ar>

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

@ -34,19 +34,14 @@ module Yesod.WebSockets
, WS.ConnectionOptions (..) , WS.ConnectionOptions (..)
) where ) where
import qualified Control.Concurrent.Async as A
import Control.Monad (forever, void, when) import Control.Monad (forever, void, when)
import Control.Monad.IO.Class (MonadIO (liftIO))
import Control.Monad.Trans.Control (control)
import Control.Monad.Trans.Control (MonadBaseControl (liftBaseWith, restoreM))
import Control.Monad.Trans.Reader (ReaderT (ReaderT, runReaderT)) import Control.Monad.Trans.Reader (ReaderT (ReaderT, runReaderT))
import qualified Data.Conduit as C import qualified Data.Conduit as C
import qualified Data.Conduit.List as CL 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,14 +55,14 @@ 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 :: (Y.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 :: (Y.MonadUnliftIO m, Y.MonadHandler m)
=> WS.ConnectionOptions => WS.ConnectionOptions
-> WebSocketsT m () -> WebSocketsT m ()
-> m () -> m ()
@ -81,7 +76,7 @@ webSocketsOptions opts = webSocketsOptionsWith opts $ const $ return $ Just $ WS
-- 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 :: (Y.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 +93,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 :: (Y.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 +114,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
@ -227,35 +222,3 @@ sinkWSText = CL.mapM_ sendTextData
-- Since 0.1.0 -- Since 0.1.0
sinkWSBinary :: (MonadIO m, WS.WebSocketsData a) => C.Consumer a (WebSocketsT m) () sinkWSBinary :: (MonadIO m, WS.WebSocketsData a) => C.Consumer a (WebSocketsT m) ()
sinkWSBinary = CL.mapM_ sendBinaryData sinkWSBinary = CL.mapM_ sendBinaryData
-- | Generalized version of 'A.race'.
--
-- Since 0.1.0
race :: MonadBaseControl IO m => m a -> m b -> m (Either a b)
race x y = liftBaseWith (\run -> A.race (run x) (run y))
>>= either (fmap Left . restoreM) (fmap Right . restoreM)
-- | Generalized version of 'A.race_'.
--
-- Since 0.1.0
race_ :: MonadBaseControl IO m => m a -> m b -> m ()
race_ x y = void $ race x y
-- | Generalized version of 'A.concurrently'. Note that if your underlying
-- monad has some kind of mutable state, the state from the second action will
-- overwrite the state from the first.
--
-- Since 0.1.0
concurrently :: MonadBaseControl IO m => m a -> m b -> m (a, b)
concurrently x y = do
(resX, resY) <- liftBaseWith $ \run -> A.concurrently (run x) (run y)
x' <- restoreM resX
y' <- restoreM resY
return (x', y')
-- | Run two actions concurrently (like 'A.concurrently'), but discard their
-- results and any modified monadic state.
--
-- Since 0.1.0
concurrently_ :: MonadBaseControl IO m => m a -> m b -> m ()
concurrently_ x y = void $ liftBaseWith $ \run -> A.concurrently (run x) (run y)

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

@ -24,10 +24,8 @@ library
, websockets >= 0.9 , websockets >= 0.9
, transformers >= 0.2 , transformers >= 0.2
, yesod-core >= 1.4 , yesod-core >= 1.4
, monad-control >= 0.3 , unliftio
, conduit >= 1.0.15.1 , conduit >= 1.0.15.1
, async >= 2.0.1.5
, enclosed-exceptions >= 1.0
source-repository head source-repository head
type: git type: git

8
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)
@ -46,8 +44,8 @@ addStaticContentExternal
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

3
yesod/yesod.cabal
View File

@ -38,8 +38,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