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
- [ ] 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:
@ -11,4 +11,4 @@ After submitting your PR:
<!---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
they were standing next to you.
In the interest of fostering an open and welcoming environment, we as
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
project to others outside the project.
## Our Standards
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-websockets
extra-deps:
- unliftio-core-0.1.0.0
- unliftio-0.2.0.0
- ../.stable/authenticate/authenticate
- conduit-extra-1.2.2
- unliftio-core-0.1.1.0
- 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
--
-- Since 1.4.4
-- @since 1.4.4
data AuthenticationResult master
= Authenticated (AuthId master) -- ^ Authenticated successfully
| 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'@
--
-- Since: 1.4.4
-- @since: 1.4.4
authenticate :: Creds master -> AuthHandler master (AuthenticationResult master)
authenticate creds = do
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
-- be set to redirect back to. Default is 'True'.
-- @since 1.4.18
--
-- @since 1.4.21
redirectToCurrent :: master -> Bool
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
-- other than a browser.
--
-- Since 1.2.0
-- @since 1.2.0
maybeAuthId :: AuthHandler master (Maybe (AuthId master))
default maybeAuthId
@ -248,7 +249,7 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage
-- | Internal session key used to hold the authentication information.
--
-- Since 1.2.3
-- @since 1.2.3
credsKey :: Text
credsKey = "_ID"
@ -258,7 +259,7 @@ credsKey = "_ID"
-- '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.
--
-- Since 1.1.2
-- @since 1.1.2
defaultMaybeAuthId
:: (YesodAuthPersist master, Typeable (AuthEntity master))
=> AuthHandler master (Maybe (AuthId master))
@ -284,7 +285,7 @@ cachedAuth
-- This is the default 'loginHandler'. It concatenates plugin widgets and
-- wraps the result in 'authLayout'. See 'loginHandler' for more details.
--
-- Since 1.4.9
-- @since 1.4.9
defaultLoginHandler :: AuthHandler master Html
defaultLoginHandler = do
tp <- getRouteToParent
@ -410,7 +411,7 @@ authLayoutJson w json = selectRep $ do
-- | 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
-> AuthHandler master ()
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
-- assumes that you are using a Persistent database.
--
-- Since 1.1.0
-- @since 1.1.0
maybeAuth :: ( YesodAuthPersist master
, val ~ AuthEntity 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
-- Persistent database.
--
-- Since 1.4.0
-- @since 1.4.0
maybeAuthPair
:: (YesodAuthPersist master, Typeable (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
-- 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
-- | If the @AuthId@ for a given site is a persistent ID, this will give the
-- value for that entity. E.g.:
@ -512,7 +513,7 @@ class (YesodAuth master, YesodPersist master) => YesodAuthPersist master where
-- > type AuthId MySite = UserId
-- > AuthEntity MySite ~ User
--
-- Since 1.2.0
-- @since 1.2.0
type AuthEntity master :: *
type AuthEntity master = KeyEntity (AuthId master)
@ -524,8 +525,8 @@ class (YesodAuth master, YesodPersist master) => YesodAuthPersist master where
, Key (AuthEntity master) ~ AuthId master
, PersistStore backend
)
=> AuthId master -> HandlerFor master (Maybe (AuthEntity master))
getAuthEntity = runDB . get
=> AuthId master -> AuthHandler master (Maybe (AuthEntity master))
getAuthEntity = liftHandler . runDB . get
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
-- 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 = maybeAuthId >>= maybe handleAuthLack return
-- | 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).
--
-- Since 1.1.0
-- @since 1.1.0
requireAuth :: ( YesodAuthPersist master
, val ~ AuthEntity 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.
-- Instead, the 'AuthId' and 'AuthEntity' are returned in a tuple.
--
-- Since 1.4.0
-- @since 1.4.0
requireAuthPair
:: ( YesodAuthPersist 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,
setSession, whamlet, (.:),
addMessage, getYesod,
toHtml)
toHtml, liftSubHandler)
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.Types (FromJSON (parseJSON), parseEither,
parseMaybe, withObject, withText)
import Data.Conduit (($$+-), ($$))
import Data.Conduit (($$+-), ($$), (.|), runConduit)
import Data.Conduit.Attoparsec (sinkParser)
import qualified Data.HashMap.Strict as M
import Data.Maybe (fromMaybe)
@ -262,7 +262,8 @@ authPlugin storeToken clientID clientSecret =
makeHttpRequest :: Request -> AuthHandler site A.Value
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.
-- In case of parsing error returns 'Nothing'.
@ -270,7 +271,7 @@ makeHttpRequest req =
--
-- @since 1.4.3
getPerson :: Manager -> Token -> AuthHandler site (Maybe Person)
getPerson manager token = parseMaybe parseJSON <$> (do
getPerson manager token = liftSubHandler $ parseMaybe parseJSON <$> (do
req <- personValueRequest token
res <- http req manager
responseBody res $$+- sinkParser json'

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

@ -44,6 +44,7 @@ library
, http-client-tls
, http-conduit >= 2.1
, aeson >= 0.7
, unliftio
, blaze-html >= 0.5
, blaze-markup >= 0.5.1
, http-types
@ -58,7 +59,7 @@ library
, binary
, http-client
, blaze-builder
, conduit
, conduit >= 1.3
, conduit-extra
, nonce >= 1.0.2 && < 1.1
, 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
* Drop an upper bound

13
yesod-bin/Devel.hs
View File

@ -17,9 +17,7 @@ import Control.Monad (forever, unless, void,
when)
import Data.ByteString (ByteString, isInfixOf)
import qualified Data.ByteString.Lazy as LB
import Data.Conduit (($$), (=$))
import qualified Data.Conduit.Binary as CB
import qualified Data.Conduit.List as CL
import Conduit
import Data.Default.Class (def)
import Data.FileEmbed (embedFile)
import qualified Data.Map as Map
@ -61,7 +59,7 @@ import System.FilePath (takeDirectory,
import System.FSNotify
import System.IO (stdout, stderr)
import System.IO.Error (isDoesNotExistError)
import System.Process.Typed
import Data.Conduit.Process.Typed
-- We have two special files:
--
@ -368,9 +366,10 @@ devel opts passThroughArgs = do
-- process is piped to the actual stdout and stderr handles.
withProcess_ procConfig $ \p -> do
let helper getter h =
getter p
$$ CL.iterM (\(str :: ByteString) -> atomically (updateAppPort str buildStarted appPortVar))
=$ CB.sinkHandle h
runConduit
$ getter p
.| iterMC (\(str :: ByteString) -> atomically (updateAppPort str buildStarted appPortVar))
.| sinkHandle h
race_ (helper getStdout stdout) (helper getStderr stderr)
-- Run the inner action with a TVar which will be set to True

16
yesod-bin/HsFile.hs
View File

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

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

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

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

@ -76,6 +76,9 @@ module Yesod.Core
, getApprootText
-- * Subsites
, MonadSubHandler (..)
, getSubYesod
, getRouteToParent
, getSubCurrentRoute
, SubsiteData
-- * Misc
, yesodVersion
@ -96,8 +99,7 @@ module Yesod.Core
, module Text.Blaze.Html
, MonadTrans (..)
, MonadIO (..)
, MonadBase (..)
, MonadBaseControl
, MonadUnliftIO (..)
, MonadResource (..)
, MonadLogger
-- * Commonly referenced functions/datatypes
@ -144,9 +146,7 @@ import qualified Yesod.Core.Internal.Run
import qualified Paths_yesod_core
import Data.Version (showVersion)
import Yesod.Routes.Class
import Control.Monad.IO.Class (MonadIO (..))
import Control.Monad.Base (MonadBase (..))
import Control.Monad.Trans.Control (MonadBaseControl (..))
import Control.Monad.IO.Unlift (MonadIO (..), MonadUnliftIO (..))
import Control.Monad.Trans.Resource (MonadResource (..))
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
type SubHandlerSite m
getSubYesod :: m (SubHandlerSite m)
getRouteToParent :: m (Route (SubHandlerSite m) -> Route (HandlerSite m))
getSubCurrentRoute :: m (Maybe (Route (SubHandlerSite m)))
liftSubHandler :: ReaderT (SubsiteData (SubHandlerSite m) (HandlerSite m)) (HandlerFor (HandlerSite m)) a -> m a
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
type SubHandlerSite (HandlerFor site) = site
getSubYesod = getYesod
getRouteToParent = return id
getSubCurrentRoute = getCurrentRoute
liftSubHandler (ReaderT x) = do
parent <- getYesod
currentRoute <- getCurrentRoute
x SubsiteData
{ sdRouteToParent = id
, sdCurrentRoute = currentRoute
, sdSubsiteData = parent
}
instance MonadSubHandler (WidgetFor site) where
type SubHandlerSite (WidgetFor site) = site
getSubYesod = getYesod
getRouteToParent = return id
getSubCurrentRoute = getCurrentRoute
liftSubHandler (ReaderT x) = do
parent <- getYesod
currentRoute <- getCurrentRoute
liftHandler $ x SubsiteData
{ sdRouteToParent = id
, sdCurrentRoute = currentRoute
, sdSubsiteData = parent
}
instance (MonadSubHandler m, parent ~ SubHandlerSite m) => MonadSubHandler (ReaderT (SubsiteData child parent) m) where
type SubHandlerSite (ReaderT (SubsiteData child parent) m) = child
getSubYesod = fmap sdSubsiteData ask
getSubCurrentRoute = fmap sdCurrentRoute ask
getRouteToParent = ReaderT $ \sd -> do
liftSubHandler (ReaderT f) = ReaderT $ \env -> do
toParent' <- getRouteToParent
return $ toParent' . sdRouteToParent sd
liftHandler $ f env
{ sdRouteToParent = toParent' . sdRouteToParent env
}
subHelper
:: (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 FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} -- Because of ErrorT
module Yesod.Core.Class.Handler
( MonadHandler (..)
, MonadWidget (..)
@ -15,6 +14,7 @@ module Yesod.Core.Class.Handler
import Yesod.Core.Types
import Control.Monad.Logger (MonadLogger)
import Control.Monad.IO.Unlift (liftIO, MonadUnliftIO, MonadIO)
import Control.Monad.Trans.Resource (MonadResource)
import Control.Monad.Trans.Class (lift)
#if __GLASGOW_HASKELL__ < 710
@ -25,7 +25,6 @@ import Data.Conduit.Internal (Pipe, ConduitM)
import Control.Monad.Trans.Identity ( IdentityT)
import Control.Monad.Trans.List ( ListT )
import Control.Monad.Trans.Maybe ( MaybeT )
import Control.Monad.Trans.Error ( ErrorT, Error)
import Control.Monad.Trans.Except ( ExceptT )
import Control.Monad.Trans.Reader ( ReaderT )
import Control.Monad.Trans.State ( StateT )
@ -59,7 +58,6 @@ instance MonadHandler (WidgetFor site) where
GO(IdentityT)
GO(ListT)
GO(MaybeT)
GOX(Error e, ErrorT e)
GO(ExceptT e)
GO(ReaderT r)
GO(StateT s)
@ -88,7 +86,6 @@ liftWidgetT = liftWidget
GO(IdentityT)
GO(ListT)
GO(MaybeT)
GOX(Error e, ErrorT e)
GO(ExceptT e)
GO(ReaderT r)
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 Blaze.ByteString.Builder (Builder, toByteString)
import Blaze.ByteString.Builder.ByteString (copyByteString)
import Blaze.ByteString.Builder.Char.Utf8 (fromText, fromChar)
import Data.ByteString.Builder (Builder, toLazyByteString)
import Data.Text.Encoding (encodeUtf8Builder)
import Control.Arrow ((***), second)
import Control.Exception (bracket)
#if __GLASGOW_HASKELL__ < 710
@ -25,6 +24,7 @@ import Control.Monad.Logger (LogLevel (LevelInfo, LevelO
import Control.Monad.Trans.Resource (InternalState, createInternalState, closeInternalState)
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Lazy.Char8 as BL8
import Data.Aeson (object, (.=))
import Data.List (foldl', nub)
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
-- parameters. One use case for this is to offload static hosting to a
-- different domain name to avoid sending cookies.
--
--
-- For backward compatibility default implementation is in terms of
-- 'urlRenderOverride', probably ineffective
--
--
-- Since 1.4.23
urlParamRenderOverride :: site
-> Route site
@ -125,11 +125,11 @@ class RenderRoute site => Yesod site where
where
addParams [] routeBldr = routeBldr
addParams nonEmptyParams routeBldr =
let routeBS = toByteString routeBldr
qsSeparator = fromChar $ if S8.elem '?' routeBS then '&' else '?'
let routeBS = toLazyByteString routeBldr
qsSeparator = if BL8.elem '?' routeBS then "&" else "?"
valueToMaybe t = if t == "" then Nothing else Just t
queryText = map (id *** valueToMaybe) nonEmptyParams
in copyByteString routeBS `mappend` qsSeparator `mappend` renderQueryText False queryText
in routeBldr `mappend` qsSeparator `mappend` renderQueryText False queryText
-- | Determine if a request is authorized or not.
--
@ -191,7 +191,7 @@ class RenderRoute site => Yesod site where
-> [(T.Text, T.Text)] -- ^ query string
-> Builder
joinPath _ ar pieces' qs' =
fromText ar `mappend` encodePath pieces qs
encodeUtf8Builder ar `mappend` encodePath pieces qs
where
pieces = if null pieces' then [""] else map addDash pieces'
qs = map (TE.encodeUtf8 *** go) qs'

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 Data.Text.Lazy (Text, pack)
import qualified Data.Text as T
import Blaze.ByteString.Builder (Builder, fromByteString, fromLazyByteString)
import Data.Text.Encoding (encodeUtf8Builder)
import qualified Data.Text.Lazy as TL
import Data.ByteString.Builder (Builder, byteString, lazyByteString, stringUtf8)
#if __GLASGOW_HASKELL__ < 710
import Data.Monoid (mempty)
#endif
import Text.Hamlet (Html)
import Text.Blaze.Html.Renderer.Utf8 (renderHtmlBuilder)
import Data.Conduit (Source, Flush (Chunk), ResumableSource, mapOutput)
import Data.Conduit (Flush (Chunk), ResumableSource, mapOutput)
import Control.Monad (liftM)
import Control.Monad.Trans.Resource (ResourceT)
import Data.Conduit.Internal (ResumableSource (ResumableSource))
import qualified Data.Conduit.Internal as CI
import qualified Data.Aeson as J
import qualified Blaze.ByteString.Builder.Char.Utf8 as Blaze
import Data.Text.Lazy.Builder (toLazyText)
import Yesod.Core.Types
import Text.Lucius (Css, renderCss)
@ -93,15 +94,15 @@ instance ToContent Content where
instance ToContent Builder where
toContent = flip ContentBuilder Nothing
instance ToContent B.ByteString where
toContent bs = ContentBuilder (fromByteString bs) $ Just $ B.length bs
toContent bs = ContentBuilder (byteString bs) $ Just $ B.length bs
instance ToContent L.ByteString where
toContent = flip ContentBuilder Nothing . fromLazyByteString
toContent = flip ContentBuilder Nothing . lazyByteString
instance ToContent T.Text where
toContent = toContent . Blaze.fromText
toContent = toContent . encodeUtf8Builder
instance ToContent Text where
toContent = toContent . Blaze.fromLazyText
toContent = toContent . foldMap encodeUtf8Builder . TL.toChunks
instance ToContent String where
toContent = toContent . Blaze.fromString
toContent = toContent . stringUtf8
instance ToContent Html where
toContent bs = ContentBuilder (renderHtmlBuilder bs) Nothing
instance ToContent () where
@ -117,12 +118,12 @@ instance ToContent Javascript where
toContent = toContent . toLazyText . unJavascript
instance ToFlushBuilder builder => ToContent (CI.Pipe () () builder () (ResourceT IO) ()) where
toContent src = ContentSource $ CI.ConduitM (CI.mapOutput toFlushBuilder src >>=)
toContent src = ContentSource $ CI.ConduitT (CI.mapOutput toFlushBuilder src >>=)
instance ToFlushBuilder builder => ToContent (Source (ResourceT IO) builder) where
instance ToFlushBuilder builder => ToContent (CI.ConduitT () builder (ResourceT IO) ()) where
toContent src = ContentSource $ mapOutput toFlushBuilder src
instance ToFlushBuilder builder => ToContent (ResumableSource (ResourceT IO) builder) where
toContent (ResumableSource src _) = toContent src
toContent (ResumableSource src) = toContent src
-- | A class for all data which can be sent in a streaming response. Note that
-- for textual data, instances must use UTF-8 encoding.
@ -131,16 +132,16 @@ instance ToFlushBuilder builder => ToContent (ResumableSource (ResourceT IO) bui
class ToFlushBuilder a where toFlushBuilder :: a -> Flush Builder
instance ToFlushBuilder (Flush Builder) where toFlushBuilder = id
instance ToFlushBuilder Builder where toFlushBuilder = Chunk
instance ToFlushBuilder (Flush B.ByteString) where toFlushBuilder = fmap fromByteString
instance ToFlushBuilder B.ByteString where toFlushBuilder = Chunk . fromByteString
instance ToFlushBuilder (Flush L.ByteString) where toFlushBuilder = fmap fromLazyByteString
instance ToFlushBuilder L.ByteString where toFlushBuilder = Chunk . fromLazyByteString
instance ToFlushBuilder (Flush Text) where toFlushBuilder = fmap Blaze.fromLazyText
instance ToFlushBuilder Text where toFlushBuilder = Chunk . Blaze.fromLazyText
instance ToFlushBuilder (Flush T.Text) where toFlushBuilder = fmap Blaze.fromText
instance ToFlushBuilder T.Text where toFlushBuilder = Chunk . Blaze.fromText
instance ToFlushBuilder (Flush String) where toFlushBuilder = fmap Blaze.fromString
instance ToFlushBuilder String where toFlushBuilder = Chunk . Blaze.fromString
instance ToFlushBuilder (Flush B.ByteString) where toFlushBuilder = fmap byteString
instance ToFlushBuilder B.ByteString where toFlushBuilder = Chunk . byteString
instance ToFlushBuilder (Flush L.ByteString) where toFlushBuilder = fmap lazyByteString
instance ToFlushBuilder L.ByteString where toFlushBuilder = Chunk . lazyByteString
instance ToFlushBuilder (Flush Text) where toFlushBuilder = fmap (foldMap encodeUtf8Builder . TL.toChunks)
instance ToFlushBuilder Text where toFlushBuilder = Chunk . foldMap encodeUtf8Builder . TL.toChunks
instance ToFlushBuilder (Flush T.Text) where toFlushBuilder = fmap encodeUtf8Builder
instance ToFlushBuilder T.Text where toFlushBuilder = Chunk . encodeUtf8Builder
instance ToFlushBuilder (Flush String) where toFlushBuilder = fmap stringUtf8
instance ToFlushBuilder String where toFlushBuilder = Chunk . stringUtf8
instance ToFlushBuilder (Flush Html) where toFlushBuilder = fmap renderHtmlBuilder
instance ToFlushBuilder Html where toFlushBuilder = Chunk . renderHtmlBuilder

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

@ -52,8 +52,9 @@ import Data.Text (Text)
import Data.Monoid (mappend)
#endif
import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Char8 as S8
import qualified Blaze.ByteString.Builder
import Data.ByteString.Builder (byteString, toLazyByteString)
import Network.HTTP.Types (status301, status307)
import Yesod.Routes.Parse
import Yesod.Core.Types
@ -114,7 +115,7 @@ toWaiAppYre yre req =
sendRedirect y segments' env sendResponse =
sendResponse $ W.responseLBS status
[ ("Content-Type", "text/plain")
, ("Location", Blaze.ByteString.Builder.toByteString dest')
, ("Location", BL.toStrict $ toLazyByteString dest')
] "Redirecting"
where
-- Ensure that non-GET requests get redirected correctly. See:
@ -128,7 +129,7 @@ toWaiAppYre yre req =
if S.null (W.rawQueryString env)
then dest
else dest `mappend`
Blaze.ByteString.Builder.fromByteString (W.rawQueryString env)
byteString (W.rawQueryString env)
-- | Same as 'toWaiAppPlain', but provides a default set of middlewares. This
-- set may change with future releases, but currently covers:

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

@ -194,12 +194,12 @@ import Data.Monoid (mempty, mappend)
#endif
import Control.Applicative ((<|>))
import Control.Exception (evaluate, SomeException, throwIO)
import Control.Exception.Lifted (handle)
import Control.Exception (handle)
import Control.Monad (void, liftM, unless)
import qualified Control.Monad.Trans.Writer as Writer
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.IO.Unlift (MonadIO, liftIO, MonadUnliftIO, withRunInIO)
import qualified Network.HTTP.Types as H
import qualified Network.Wai as W
@ -233,21 +233,20 @@ import Yesod.Core.Content (ToTypedContent (..), simpleConte
import Yesod.Core.Internal.Util (formatRFC1123)
import Text.Blaze.Html (preEscapedToHtml, toHtml)
import qualified Data.IORef.Lifted as I
import qualified Data.IORef as I
import Data.Maybe (listToMaybe, mapMaybe)
import Data.Typeable (Typeable)
import Web.PathPieces (PathPiece(..))
import Yesod.Core.Class.Handler
import Yesod.Core.Types
import Yesod.Routes.Class (Route)
import Blaze.ByteString.Builder (Builder)
import Data.ByteString.Builder (Builder)
import Safe (headMay)
import Data.CaseInsensitive (CI, original)
import qualified Data.Conduit.List as CL
import Control.Monad.Trans.Resource (MonadResource, InternalState, runResourceT, withInternalState, getInternalState, liftResourceT, resourceForkIO)
import qualified System.PosixCompat.Files as PC
import Control.Monad.Trans.Control (control, MonadBaseControl)
import Data.Conduit (Source, transPipe, Flush (Flush), yield, Producer, Sink)
import Data.Conduit (ConduitT, transPipe, Flush (Flush), yield, Void)
import qualified Yesod.Core.TypeCache as Cache
import qualified Data.Word8 as W8
import qualified Data.Foldable as Fold
@ -449,7 +448,8 @@ forkHandler :: (SomeException -> HandlerFor site ()) -- ^ error handler
-> HandlerFor site ()
forkHandler onErr handler = do
yesRunner <- handlerToIO
void $ liftResourceT $ resourceForkIO $ yesRunner $ handle onErr handler
void $ liftResourceT $ resourceForkIO $
liftIO $ handle (yesRunner . onErr) (yesRunner handler)
-- | Redirect to the given route.
-- HTTP status code 303 for HTTP 1.1 clients and 302 for HTTP 1.0
@ -666,10 +666,10 @@ sendWaiApplication = handlerError . HCWaiApp
--
-- @since 1.2.16
sendRawResponseNoConduit
:: (MonadHandler m, MonadBaseControl IO m)
:: (MonadHandler m, MonadUnliftIO m)
=> (IO S8.ByteString -> (S8.ByteString -> IO ()) -> m ())
-> m a
sendRawResponseNoConduit raw = control $ \runInIO ->
sendRawResponseNoConduit raw = withRunInIO $ \runInIO ->
liftIO $ throwIO $ HCWai $ flip W.responseRaw fallback
$ \src sink -> void $ runInIO (raw src sink)
where
@ -681,10 +681,11 @@ sendRawResponseNoConduit raw = control $ \runInIO ->
-- Warp).
--
-- @since 1.2.7
sendRawResponse :: (MonadHandler m, MonadBaseControl IO m)
=> (Source IO S8.ByteString -> Sink S8.ByteString IO () -> m ())
-> m a
sendRawResponse raw = control $ \runInIO ->
sendRawResponse
:: (MonadHandler m, MonadUnliftIO m)
=> (ConduitT () S8.ByteString IO () -> ConduitT S8.ByteString Void IO () -> m ())
-> m a
sendRawResponse raw = withRunInIO $ \runInIO ->
liftIO $ throwIO $ HCWai $ flip W.responseRaw fallback
$ \src sink -> void $ runInIO $ raw (src' src) (CL.mapM_ sink)
where
@ -1339,7 +1340,7 @@ provideRepType ct handler =
-- | Stream in the raw request body without any parsing.
--
-- @since 1.2.0
rawRequestBody :: MonadHandler m => Source m S.ByteString
rawRequestBody :: MonadHandler m => ConduitT i S.ByteString m ()
rawRequestBody = do
req <- lift waiRequest
let loop = do
@ -1351,7 +1352,7 @@ rawRequestBody = do
-- | Stream the data from the file. Since Yesod 1.2, this has been generalized
-- to work in any @MonadResource@.
fileSource :: MonadResource m => FileInfo -> Source m S.ByteString
fileSource :: MonadResource m => FileInfo -> ConduitT () S.ByteString m ()
fileSource = transPipe liftResourceT . fileSourceRaw
-- | Provide a pure value for the response body.
@ -1372,7 +1373,7 @@ respond ct = return . TypedContent ct . toContent
--
-- @since 1.2.0
respondSource :: ContentType
-> Source (HandlerFor site) (Flush Builder)
-> ConduitT () (Flush Builder) (HandlerFor site) ()
-> HandlerFor site TypedContent
respondSource ctype src = HandlerFor $ \hd ->
-- 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@.
--
-- @since 1.2.0
sendChunk :: Monad m => ToFlushBuilder a => a -> Producer m (Flush Builder)
sendChunk :: Monad m => ToFlushBuilder a => a -> ConduitT i (Flush Builder) m ()
sendChunk = yield . toFlushBuilder
-- | In a streaming response, send a flush command, causing all buffered data
-- to be immediately sent to the client.
--
-- @since 1.2.0
sendFlush :: Monad m => Producer m (Flush Builder)
sendFlush :: Monad m => ConduitT i (Flush Builder) m ()
sendFlush = yield Flush
-- | Type-specialized version of 'sendChunk' for strict @ByteString@s.
--
-- @since 1.2.0
sendChunkBS :: Monad m => S.ByteString -> Producer m (Flush Builder)
sendChunkBS :: Monad m => S.ByteString -> ConduitT i (Flush Builder) m ()
sendChunkBS = sendChunk
-- | Type-specialized version of 'sendChunk' for lazy @ByteString@s.
--
-- @since 1.2.0
sendChunkLBS :: Monad m => L.ByteString -> Producer m (Flush Builder)
sendChunkLBS :: Monad m => L.ByteString -> ConduitT i (Flush Builder) m ()
sendChunkLBS = sendChunk
-- | Type-specialized version of 'sendChunk' for strict @Text@s.
--
-- @since 1.2.0
sendChunkText :: Monad m => T.Text -> Producer m (Flush Builder)
sendChunkText :: Monad m => T.Text -> ConduitT i (Flush Builder) m ()
sendChunkText = sendChunk
-- | Type-specialized version of 'sendChunk' for lazy @Text@s.
--
-- @since 1.2.0
sendChunkLazyText :: Monad m => TL.Text -> Producer m (Flush Builder)
sendChunkLazyText :: Monad m => TL.Text -> ConduitT i (Flush Builder) m ()
sendChunkLazyText = sendChunk
-- | Type-specialized version of 'sendChunk' for @Html@s.
--
-- @since 1.2.0
sendChunkHtml :: Monad m => Html -> Producer m (Flush Builder)
sendChunkHtml :: Monad m => Html -> ConduitT i (Flush Builder) m ()
sendChunkHtml = sendChunk
-- $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 Data.Text.Encoding (decodeUtf8With, decodeUtf8)
import Data.Text.Encoding.Error (lenientDecode)
import Data.Conduit
import Data.Conduit.List (sourceList)
import Data.Conduit.Binary (sourceFile, sinkFile)
import Conduit
import Data.Word (Word8, Word64)
import Control.Monad.Trans.Resource (runResourceT, ResourceT)
import Control.Exception (throwIO)
@ -176,7 +174,7 @@ fromByteVector v =
mkFileInfoLBS :: Text -> Text -> L.ByteString -> FileInfo
mkFileInfoLBS name ct lbs =
FileInfo name ct (sourceList $ L.toChunks lbs) (`L.writeFile` lbs)
FileInfo name ct (sourceLazy lbs) (`L.writeFile` lbs)
mkFileInfoFile :: Text -> Text -> FilePath -> FileInfo
mkFileInfoFile name ct fp = FileInfo name ct (sourceFile fp) (\dst -> runResourceT $ sourceFile fp $$ sinkFile dst)

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 qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as BL
import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI
import Network.Wai
@ -18,8 +19,7 @@ import Yesod.Core.Types
import qualified Network.HTTP.Types as H
import qualified Data.Text as T
import Control.Exception (SomeException, handle)
import Blaze.ByteString.Builder (fromLazyByteString,
toLazyByteString, toByteString)
import Data.ByteString.Builder (lazyByteString, toLazyByteString)
import qualified Data.ByteString.Lazy as L
import qualified Data.Map as Map
import Yesod.Core.Internal.Request (tokenKey)
@ -83,7 +83,7 @@ defaultStatus = H.mkStatus (-1) "INVALID DEFAULT STATUS"
headerToPair :: Header
-> (CI ByteString, ByteString)
headerToPair (AddCookie sc) =
("Set-Cookie", toByteString $ renderSetCookie sc)
("Set-Cookie", BL.toStrict $ toLazyByteString $ renderSetCookie sc)
headerToPair (DeleteCookie key path) =
( "Set-Cookie"
, S.concat
@ -100,7 +100,7 @@ evaluateContent (ContentBuilder b mlen) = handle f $ do
let lbs = toLazyByteString b
len = L.length lbs
mlen' = mlen `mplus` Just (fromIntegral len)
len `seq` return (Right $ ContentBuilder (fromLazyByteString lbs) mlen')
len `seq` return (Right $ ContentBuilder (lazyByteString lbs) mlen')
where
f :: SomeException -> IO (Either ErrorResponse Content)
f = return . Left . InternalError . T.pack . show

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

@ -14,7 +14,8 @@ import Data.Monoid (Monoid, mempty)
import Control.Applicative ((<$>))
#endif
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 qualified Control.Exception as E
import Control.Monad.IO.Class (MonadIO, liftIO)
@ -371,7 +372,7 @@ yesodRender :: Yesod y
-> [(Text, Text)] -- ^ url query string
-> Text
yesodRender y ar url params =
decodeUtf8With lenientDecode $ toByteString $
decodeUtf8With lenientDecode $ BL.toStrict $ toLazyByteString $
fromMaybe
(joinPath y ar ps
$ params ++ params')

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

@ -104,7 +104,7 @@ provideJson = provideRep . return . J.toEncoding
-- @since 0.3.0
parseJsonBody :: (MonadHandler m, J.FromJSON a) => m (J.Result a)
parseJsonBody = do
eValue <- rawRequestBody $$ runCatchC (sinkParser JP.value')
eValue <- runConduit $ rawRequestBody .| runCatchC (sinkParser JP.value')
return $ case eValue of
Left e -> J.Error $ show e
Right value -> J.fromJSON value

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

@ -10,8 +10,7 @@
{-# LANGUAGE UndecidableInstances #-}
module Yesod.Core.Types where
import qualified Blaze.ByteString.Builder as BBuilder
import qualified Blaze.ByteString.Builder.Char.Utf8
import qualified Data.ByteString.Builder as BB
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative (Applicative (..))
import Control.Applicative ((<$>))
@ -20,16 +19,13 @@ import Data.Monoid (Monoid (..))
import Control.Arrow (first)
import Control.Exception (Exception)
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.Logger (LogLevel, LogSource,
MonadLogger (..))
import Control.Monad.Trans.Control (MonadBaseControl (..))
import Control.Monad.Trans.Resource (MonadResource (..), InternalState, runInternalState, MonadThrow (..), ResourceT)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy as L
import Data.Conduit (Flush, Source)
import Data.Conduit (Flush, ConduitT)
import Data.IORef (IORef, modifyIORef')
import Data.Map (Map, unionWith)
import qualified Data.Map as Map
@ -62,7 +58,6 @@ import Control.Monad.Reader (MonadReader (..))
import Data.Monoid ((<>))
import Control.DeepSeq (NFData (rnf))
import Control.DeepSeq.Generics (genericRnf)
import Data.Conduit.Lazy (MonadActive, monadActive)
import Yesod.Core.TypeCache (TypeMap, KeyedTypeMap)
import Control.Monad.Logger (MonadLoggerIO (..))
import Data.Semigroup (Semigroup)
@ -137,13 +132,13 @@ type RequestBodyContents =
data FileInfo = FileInfo
{ fileName :: !Text
, fileContentType :: !Text
, fileSourceRaw :: !(Source (ResourceT IO) ByteString)
, fileSourceRaw :: !(ConduitT () ByteString (ResourceT IO) ())
, fileMove :: !(FilePath -> IO ())
}
data FileUpload = FileUploadMemory !(NWP.BackEnd L.ByteString)
| FileUploadDisk !(InternalState -> NWP.BackEnd FilePath)
| FileUploadSource !(NWP.BackEnd (Source (ResourceT IO) ByteString))
| FileUploadSource !(NWP.BackEnd (ConduitT () ByteString (ResourceT IO) ()))
-- | How to determine the root of the application for constructing URLs.
--
@ -293,8 +288,8 @@ data PageContent url = PageContent
, pageBody :: HtmlUrl url
}
data Content = ContentBuilder !BBuilder.Builder !(Maybe Int) -- ^ The content and optional content length.
| ContentSource !(Source (ResourceT IO) (Flush BBuilder.Builder))
data Content = ContentBuilder !BB.Builder !(Maybe Int) -- ^ The content and optional content length.
| ContentSource !(ConduitT () (Flush BB.Builder) (ResourceT IO) ())
| ContentFile !FilePath !(Maybe FilePart)
| ContentDontEvaluate !Content
@ -417,14 +412,6 @@ instance Monad (WidgetFor site) where
unWidgetFor (f a) wd
instance MonadIO (WidgetFor site) where
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
instance MonadUnliftIO (WidgetFor site) where
{-# INLINE askUnliftIO #-}
@ -437,23 +424,6 @@ instance MonadReader (WidgetData site) (WidgetFor site) where
instance MonadThrow (WidgetFor site) where
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
liftResourceT f = WidgetFor $ runInternalState f . handlerResource . wdHandler
@ -464,12 +434,6 @@ instance MonadLogger (WidgetFor site) where
instance MonadLoggerIO (WidgetFor site) where
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
instance Applicative (HandlerFor site) where
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
instance MonadIO (HandlerFor site) where
liftIO = HandlerFor . const
instance b ~ IO => MonadBase b (HandlerFor site) where
liftBase = liftIO
instance MonadReader (HandlerData site) (HandlerFor site) where
ask = HandlerFor return
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
instance MonadUnliftIO (HandlerFor site) where
{-# INLINE askUnliftIO #-}
@ -524,7 +472,7 @@ instance Monoid (UniqueList x) where
instance Semigroup (UniqueList x)
instance IsString Content where
fromString = flip ContentBuilder Nothing . Blaze.ByteString.Builder.Char.Utf8.fromString
fromString = flip ContentBuilder Nothing . BB.stringUtf8
instance RenderRoute WaiSubsite where
data Route WaiSubsite = WaiSubsiteRoute [Text] [(Text, Text)]

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

@ -1,7 +1,7 @@
{-# LANGUAGE CPP #-}
-- | 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.
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 Yesod.Core
import Data.IORef.Lifted
import UnliftIO.IORef
import Data.Typeable (Typeable)
import qualified Data.ByteString.Lazy.Char8 as L8

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

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

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

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

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

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

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

@ -22,7 +22,6 @@ import Control.Monad.Trans.Resource (register)
import Data.IORef
import Data.Streaming.Network (bindPortTCP)
import Network.HTTP.Types (status200)
import Blaze.ByteString.Builder (fromByteString)
mkYesod "App" [parseRoutes|
/ HomeR GET
@ -46,16 +45,16 @@ getHomeR = do
getWaiStreamR :: Handler ()
getWaiStreamR = sendWaiResponse $ responseStream status200 [] $ \send flush -> do
flush
send $ fromByteString "hello"
send "hello"
flush
send $ fromByteString " world"
send " world"
getWaiAppStreamR :: Handler ()
getWaiAppStreamR = sendWaiApplication $ \_ f -> f $ responseStream status200 [] $ \send flush -> do
flush
send $ fromByteString "hello"
send "hello"
flush
send $ fromByteString " world"
send " world"
getFreePort :: IO Int
getFreePort = do

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

@ -25,12 +25,11 @@ library
, time >= 1.5
, wai >= 3.0
, wai-extra >= 3.0.7
, bytestring >= 0.10
, bytestring >= 0.10.2
, text >= 0.7
, template-haskell
, path-pieces >= 0.1.2 && < 0.3
, shakespeare >= 2.0
, blaze-builder >= 0.2.1.4 && < 0.5
, transformers >= 0.4
, mtl
, clientsession >= 0.9.1 && < 0.10
@ -39,8 +38,6 @@ library
, old-locale >= 1.0.0.2 && < 1.1
, containers >= 0.2
, unordered-containers >= 0.2
, monad-control >= 1.0 && < 1.1
, transformers-base >= 0.4
, cookie >= 0.4.2 && < 0.5
, http-types >= 0.7
, case-insensitive >= 0.2
@ -51,19 +48,19 @@ library
, fast-logger >= 2.2
, wai-logger >= 0.2
, monad-logger >= 0.3.10 && < 0.4
, conduit >= 1.2
, resourcet >= 0.4.9 && < 1.2
, lifted-base >= 0.1.2
, conduit >= 1.3
, resourcet >= 1.2
, blaze-html >= 0.5
, blaze-markup >= 0.7.1
-- FIXME remove!
, data-default
, safe
, warp >= 3.0.2
, unix-compat
, conduit-extra
, exceptions >= 0.6
, deepseq >= 1.3
, deepseq-generics
-- FIXME remove
, mwc-random
, primitive
, word8
@ -190,13 +187,11 @@ test-suite tests
,text
,http-types
, random
, blaze-builder
,HUnit
,QuickCheck >= 2 && < 3
,transformers
, conduit
, containers
, lifted-base
, resourcet
, network
, async
@ -206,6 +201,7 @@ test-suite tests
, wai-extra
, mwc-random
, cookie >= 0.4.1 && < 0.5
, unliftio
ghc-options: -Wall
extensions: TemplateHaskell

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

@ -16,7 +16,7 @@ extra-source-files: README.md ChangeLog.md
library
build-depends: base >= 4 && < 5
, yesod-core == 1.4.*
, conduit >= 0.5 && < 1.3
, conduit >= 1.3
, wai >= 1.3
, wai-eventsource >= 1.3
, wai-extra

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

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

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

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

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

@ -93,10 +93,7 @@ import Data.List (foldl')
import qualified Data.ByteString as S
import System.PosixCompat.Files (getFileStatus, modificationTime)
import System.Posix.Types (EpochTime)
import Data.Conduit
import Data.Conduit.List (sourceList, consume)
import Data.Conduit.Binary (sourceFile)
import qualified Data.Conduit.Text as CT
import Conduit
import Data.Functor.Identity (runIdentity)
import System.FilePath ((</>), (<.>), takeDirectory)
import qualified System.FilePath as F
@ -422,8 +419,8 @@ base64md5File = fmap (base64 . encode) . hashFile
base64md5 :: L.ByteString -> String
base64md5 lbs =
base64 $ encode
$ runIdentity
$ sourceList (L.toChunks lbs) $$ sinkHash
$ runConduitPure
$ Conduit.sourceLazy lbs .| sinkHash
where
encode d = ByteArray.convert (d :: Digest MD5)
@ -458,8 +455,11 @@ combineStatics' :: CombineType
-> [Route Static] -- ^ files to combine
-> Q Exp
combineStatics' combineType CombineSettings {..} routes = do
texts <- qRunIO $ runResourceT $ mapM_ yield fps $$ awaitForever readUTFFile =$ consume
ltext <- qRunIO $ preProcess $ TL.fromChunks texts
texts <- qRunIO $ runConduitRes
$ yieldMany fps
.| awaitForever readUTFFile
.| sinkLazy
ltext <- qRunIO $ preProcess texts
bs <- qRunIO $ postProcess fps $ TLE.encodeUtf8 ltext
let hash' = base64md5 bs
suffix = csCombinedFolder </> hash' <.> extension
@ -473,7 +473,7 @@ combineStatics' combineType CombineSettings {..} routes = do
fps :: [FilePath]
fps = map toFP routes
toFP (StaticRoute pieces _) = csStaticDir </> F.joinPath (map T.unpack pieces)
readUTFFile fp = sourceFile fp =$= CT.decode CT.utf8
readUTFFile fp = sourceFile fp .| decodeUtf8C
postProcess =
case combineType of
JS -> csJsPostProcess

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

@ -42,8 +42,7 @@ library
, file-embed >= 0.0.4.1 && < 0.5
, http-types >= 0.7
, unix-compat >= 0.2
, conduit >= 0.5
, conduit-extra
, conduit >= 1.3
, cryptonite-conduit >= 0.1
, cryptonite >= 0.11
, memory
@ -124,7 +123,6 @@ test-suite tests
, unordered-containers
, async
, process
, conduit-extra
, exceptions
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
* Added implicit parameter HasCallStack to assertions.
[#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
-- on currently displayed label names.
, byLabel
, byLabelExact
, fileByLabel
, fileByLabelExact
-- *** CSRF Tokens
-- | In order to prevent CSRF exploits, yesod-form adds a hidden input
@ -163,6 +165,8 @@ import GHC.Exts (Constraint)
type HasCallStack = (() :: Constraint)
#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'
--
@ -524,23 +528,24 @@ addFile name path mimetype = do
addPostData (MultipleItemsPostData posts) contents =
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.
nameFromLabel :: T.Text -> RequestBuilder site T.Text
nameFromLabel label = do
genericNameFromLabel :: (T.Text -> T.Text -> Bool) -> T.Text -> RequestBuilder site T.Text
genericNameFromLabel match label = do
mres <- fmap rbdResponse getState
res <-
case mres of
Nothing -> failure "nameFromLabel: No response available"
Nothing -> failure "genericNameFromLabel: No response available"
Just res -> return res
let
body = simpleBody res
mlabel = parseHTML body
$// C.element "label"
>=> contentContains label
>=> isContentMatch label
mfor = mlabel >>= attribute "for"
contentContains x c
| x `T.isInfixOf` T.concat (c $// content) = [c]
isContentMatch x c
| x `match` T.concat (c $// content) = [c]
| otherwise = []
case mfor of
@ -567,6 +572,14 @@ nameFromLabel label = do
(<>) :: T.Text -> T.Text -> T.Text
(<>) = 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?
-- | 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">
-- > <label>Username <input name="f1"> </label>
-- > </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>@.
-> T.Text -- ^ The value to set the parameter to.
-> RequestBuilder site ()
byLabel label value = do
name <- nameFromLabel label
addPostParam name value
byLabel = byLabelWithMatch T.isInfixOf
-- | 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.
--
@ -621,12 +682,46 @@ byLabel label value = do
-- > <form method="POST">
-- > <label>Please submit an image <input type="file" name="f1"> </label>
-- > </form>
--
-- Warning: This function has the same issue as 'byLabel'. Please use 'fileByLabelExact' instead.
fileByLabel :: 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 ()
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
-- | 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 ScopedTypeVariables #-}
{-# LANGUAGE CPP #-}
@ -34,7 +37,7 @@ import Data.ByteString.Lazy.Char8 ()
import qualified Data.Map as Map
import qualified Text.HTML.DOM as HD
import Network.HTTP.Types.Status (status301, status303, unsupportedMediaType415)
import UnliftIO (tryAny)
import UnliftIO (tryAny, SomeException, try)
parseQuery_ :: Text -> [[SelectorGroup]]
parseQuery_ = either error id . parseQuery
@ -215,6 +218,22 @@ main = hspec $ do
setMethod "POST"
setUrl ("/labels" :: Text)
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
yit "can set a content-type" $ 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)
onStatic "labels" $ dispatchTo $
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
headers <- requestHeaders <$> waiRequest

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

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

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

@ -34,19 +34,14 @@ module Yesod.WebSockets
, WS.ConnectionOptions (..)
) where
import qualified Control.Concurrent.Async as A
import Control.Monad (forever, void, when)
import Control.Monad.IO.Class (MonadIO (liftIO))
import Control.Monad.Trans.Control (control)
import Control.Monad.Trans.Control (MonadBaseControl (liftBaseWith, restoreM))
import Control.Monad.Trans.Reader (ReaderT (ReaderT, runReaderT))
import qualified Data.Conduit as C
import qualified Data.Conduit.List as CL
import qualified Network.Wai.Handler.WebSockets as WaiWS
import qualified Network.WebSockets as WS
import qualified Yesod.Core as Y
import Control.Exception (SomeException)
import Control.Exception.Enclosed (tryAny)
import UnliftIO (SomeException, tryAny, MonadIO, liftIO, MonadUnliftIO, withRunInIO, race, race_, concurrently, concurrently_)
-- | A transformer for a WebSockets handler.
--
@ -60,14 +55,14 @@ type WebSocketsT = ReaderT WS.Connection
-- instead.
--
-- 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
-- | Varient of 'webSockets' which allows you to specify
-- the WS.ConnectionOptions setttings when upgrading to a websocket connection.
--
-- Since 0.2.5
webSocketsOptions :: (Y.MonadBaseControl IO m, Y.MonadHandler m)
webSocketsOptions :: (Y.MonadUnliftIO m, Y.MonadHandler m)
=> WS.ConnectionOptions
-> WebSocketsT m ()
-> m ()
@ -81,7 +76,7 @@ webSocketsOptions opts = webSocketsOptionsWith opts $ const $ return $ Just $ WS
-- setttings when upgrading to a websocket connection.
--
-- 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))
-- ^ A Nothing indicates that the websocket upgrade request should not happen
-- and instead the rest of the handler will be called instead. This allows
@ -98,7 +93,7 @@ webSocketsWith = webSocketsOptionsWith WS.defaultConnectionOptions
-- setttings when upgrading to a websocket connection.
--
-- Since 0.2.5
webSocketsOptionsWith :: (Y.MonadBaseControl IO m, Y.MonadHandler m)
webSocketsOptionsWith :: (Y.MonadUnliftIO m, Y.MonadHandler m)
=> WS.ConnectionOptions
-- ^ Custom websockets options
-> (WS.RequestHead -> m (Maybe WS.AcceptRequest))
@ -119,7 +114,7 @@ webSocketsOptionsWith wsConnOpts buildAr inner = do
Nothing -> return ()
Just ar ->
Y.sendRawResponseNoConduit
$ \src sink -> control $ \runInIO -> WaiWS.runWebSockets
$ \src sink -> withRunInIO $ \runInIO -> WaiWS.runWebSockets
wsConnOpts
rhead
(\pconn -> do
@ -227,35 +222,3 @@ sinkWSText = CL.mapM_ sendTextData
-- Since 0.1.0
sinkWSBinary :: (MonadIO m, WS.WebSocketsData a) => C.Consumer a (WebSocketsT m) ()
sinkWSBinary = CL.mapM_ sendBinaryData
-- | Generalized version of 'A.race'.
--
-- Since 0.1.0
race :: MonadBaseControl IO m => m a -> m b -> m (Either a b)
race x y = liftBaseWith (\run -> A.race (run x) (run y))
>>= either (fmap Left . restoreM) (fmap Right . restoreM)
-- | Generalized version of 'A.race_'.
--
-- Since 0.1.0
race_ :: MonadBaseControl IO m => m a -> m b -> m ()
race_ x y = void $ race x y
-- | Generalized version of 'A.concurrently'. Note that if your underlying
-- monad has some kind of mutable state, the state from the second action will
-- overwrite the state from the first.
--
-- Since 0.1.0
concurrently :: MonadBaseControl IO m => m a -> m b -> m (a, b)
concurrently x y = do
(resX, resY) <- liftBaseWith $ \run -> A.concurrently (run x) (run y)
x' <- restoreM resX
y' <- restoreM resY
return (x', y')
-- | Run two actions concurrently (like 'A.concurrently'), but discard their
-- results and any modified monadic state.
--
-- Since 0.1.0
concurrently_ :: MonadBaseControl IO m => m a -> m b -> m ()
concurrently_ x y = void $ liftBaseWith $ \run -> A.concurrently (run x) (run y)

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

@ -24,10 +24,8 @@ library
, websockets >= 0.9
, transformers >= 0.2
, yesod-core >= 1.4
, monad-control >= 0.3
, unliftio
, conduit >= 1.0.15.1
, async >= 2.0.1.5
, enclosed-exceptions >= 1.0
source-repository head
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 Yesod.Core -- purposely using complete import so that Haddock will see addStaticContent
import Control.Monad (when, unless)
import Control.Monad.Trans.Resource (runResourceT)
import Data.Conduit (($$))
import Data.Conduit.Binary (sourceLbs, sinkFileCautious)
import Conduit
import System.Directory (doesFileExist, createDirectoryIfMissing)
import Language.Haskell.TH.Syntax
import Text.Lucius (luciusFile, luciusFileReload)
@ -46,8 +44,8 @@ addStaticContentExternal
addStaticContentExternal minify hash staticDir toRoute ext' _ content = do
liftIO $ createDirectoryIfMissing True statictmp
exists <- liftIO $ doesFileExist fn'
unless exists $
liftIO $ runResourceT $ sourceLbs content' $$ sinkFileCautious fn'
unless exists $ withSinkFileCautious fn' $ \sink ->
runConduit $ sourceLazy content' .| sink
return $ Just $ Right (toRoute ["tmp", pack fn], [])
where
fn, statictmp, fn' :: FilePath

3
yesod/yesod.cabal
View File

@ -38,8 +38,7 @@ library
, bytestring
, monad-logger
, fast-logger
, conduit
, conduit-extra >= 1.1.14
, conduit >= 1.3
, resourcet
, shakespeare
, streaming-commons