diff --git a/.github/PULL_REQUEST_TEMPLATE.md b/.github/PULL_REQUEST_TEMPLATE.md index c9839a31..e704b0be 100644 --- a/.github/PULL_REQUEST_TEMPLATE.md +++ b/.github/PULL_REQUEST_TEMPLATE.md @@ -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: \ No newline at end of file +_If these checkboxes don't apply to your PR, you can delete them_--> diff --git a/CODE_OF_CONDUCT.md b/CODE_OF_CONDUCT.md index 1210bef0..b819c716 100644 --- a/CODE_OF_CONDUCT.md +++ b/CODE_OF_CONDUCT.md @@ -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. diff --git a/stack.yaml b/stack.yaml index 2e37e9d0..469cf4cd 100644 --- a/stack.yaml +++ b/stack.yaml @@ -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 diff --git a/yesod-auth/Yesod/Auth.hs b/yesod-auth/Yesod/Auth.hs index c5d137e8..08ad2722 100644 --- a/yesod-auth/Yesod/Auth.hs +++ b/yesod-auth/Yesod/Auth.hs @@ -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) diff --git a/yesod-auth/Yesod/Auth/GoogleEmail2.hs b/yesod-auth/Yesod/Auth/GoogleEmail2.hs index 01a00e3c..6a974a0e 100644 --- a/yesod-auth/Yesod/Auth/GoogleEmail2.hs +++ b/yesod-auth/Yesod/Auth/GoogleEmail2.hs @@ -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' diff --git a/yesod-auth/yesod-auth.cabal b/yesod-auth/yesod-auth.cabal index 6075cb6d..6cd8b187 100644 --- a/yesod-auth/yesod-auth.cabal +++ b/yesod-auth/yesod-auth.cabal @@ -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 diff --git a/yesod-bin/ChangeLog.md b/yesod-bin/ChangeLog.md index 1380e9af..0020b34a 100644 --- a/yesod-bin/ChangeLog.md +++ b/yesod-bin/ChangeLog.md @@ -1,3 +1,7 @@ +## 1.5.3 + +* Support typed-process-0.2.0.0 + ## 1.5.2.6 * Drop an upper bound diff --git a/yesod-bin/Devel.hs b/yesod-bin/Devel.hs index 701718a4..c871a772 100644 --- a/yesod-bin/Devel.hs +++ b/yesod-bin/Devel.hs @@ -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 diff --git a/yesod-bin/HsFile.hs b/yesod-bin/HsFile.hs index 38093a51..18868c24 100644 --- a/yesod-bin/HsFile.hs +++ b/yesod-bin/HsFile.hs @@ -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) diff --git a/yesod-bin/yesod-bin.cabal b/yesod-bin/yesod-bin.cabal index 76781ff8..2eefd423 100644 --- a/yesod-bin/yesod-bin.cabal +++ b/yesod-bin/yesod-bin.cabal @@ -1,5 +1,5 @@ name: yesod-bin -version: 1.5.2.6 +version: 1.5.3 license: MIT license-file: LICENSE author: Michael Snoyman @@ -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 diff --git a/yesod-core/Yesod/Core.hs b/yesod-core/Yesod/Core.hs index fdcb7c43..ae2f40bc 100644 --- a/yesod-core/Yesod/Core.hs +++ b/yesod-core/Yesod/Core.hs @@ -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 diff --git a/yesod-core/Yesod/Core/Class/Dispatch.hs b/yesod-core/Yesod/Core/Class/Dispatch.hs index 7c4d6bd8..106a0517 100644 --- a/yesod-core/Yesod/Core/Class/Dispatch.hs +++ b/yesod-core/Yesod/Core/Class/Dispatch.hs @@ -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) diff --git a/yesod-core/Yesod/Core/Class/Handler.hs b/yesod-core/Yesod/Core/Class/Handler.hs index f32e1477..c69a2524 100644 --- a/yesod-core/Yesod/Core/Class/Handler.hs +++ b/yesod-core/Yesod/Core/Class/Handler.hs @@ -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) diff --git a/yesod-core/Yesod/Core/Class/Yesod.hs b/yesod-core/Yesod/Core/Class/Yesod.hs index eafd1b34..01be1459 100644 --- a/yesod-core/Yesod/Core/Class/Yesod.hs +++ b/yesod-core/Yesod/Core/Class/Yesod.hs @@ -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' diff --git a/yesod-core/Yesod/Core/Content.hs b/yesod-core/Yesod/Core/Content.hs index d98d967e..8a01309a 100644 --- a/yesod-core/Yesod/Core/Content.hs +++ b/yesod-core/Yesod/Core/Content.hs @@ -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 diff --git a/yesod-core/Yesod/Core/Dispatch.hs b/yesod-core/Yesod/Core/Dispatch.hs index bd3c41c6..747d40d4 100644 --- a/yesod-core/Yesod/Core/Dispatch.hs +++ b/yesod-core/Yesod/Core/Dispatch.hs @@ -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: diff --git a/yesod-core/Yesod/Core/Handler.hs b/yesod-core/Yesod/Core/Handler.hs index f8cd1666..2bd06b93 100644 --- a/yesod-core/Yesod/Core/Handler.hs +++ b/yesod-core/Yesod/Core/Handler.hs @@ -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 diff --git a/yesod-core/Yesod/Core/Internal/Request.hs b/yesod-core/Yesod/Core/Internal/Request.hs index b7e4e3ca..65201b19 100644 --- a/yesod-core/Yesod/Core/Internal/Request.hs +++ b/yesod-core/Yesod/Core/Internal/Request.hs @@ -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) diff --git a/yesod-core/Yesod/Core/Internal/Response.hs b/yesod-core/Yesod/Core/Internal/Response.hs index a7263b61..a4be46bd 100644 --- a/yesod-core/Yesod/Core/Internal/Response.hs +++ b/yesod-core/Yesod/Core/Internal/Response.hs @@ -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 diff --git a/yesod-core/Yesod/Core/Internal/Run.hs b/yesod-core/Yesod/Core/Internal/Run.hs index 4f8e69a1..a755428f 100644 --- a/yesod-core/Yesod/Core/Internal/Run.hs +++ b/yesod-core/Yesod/Core/Internal/Run.hs @@ -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') diff --git a/yesod-core/Yesod/Core/Json.hs b/yesod-core/Yesod/Core/Json.hs index 441b3e92..b3187e4c 100644 --- a/yesod-core/Yesod/Core/Json.hs +++ b/yesod-core/Yesod/Core/Json.hs @@ -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 diff --git a/yesod-core/Yesod/Core/Types.hs b/yesod-core/Yesod/Core/Types.hs index 4211ba43..9542ceac 100644 --- a/yesod-core/Yesod/Core/Types.hs +++ b/yesod-core/Yesod/Core/Types.hs @@ -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)] diff --git a/yesod-core/Yesod/Core/Unsafe.hs b/yesod-core/Yesod/Core/Unsafe.hs index c4d75b1e..ebb22c5f 100644 --- a/yesod-core/Yesod/Core/Unsafe.hs +++ b/yesod-core/Yesod/Core/Unsafe.hs @@ -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 diff --git a/yesod-core/test/YesodCoreTest/Cache.hs b/yesod-core/test/YesodCoreTest/Cache.hs index 04282f81..e1ba9204 100644 --- a/yesod-core/test/YesodCoreTest/Cache.hs +++ b/yesod-core/test/YesodCoreTest/Cache.hs @@ -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 diff --git a/yesod-core/test/YesodCoreTest/CleanPath.hs b/yesod-core/test/YesodCoreTest/CleanPath.hs index 8decc03a..b60a3156 100644 --- a/yesod-core/test/YesodCoreTest/CleanPath.hs +++ b/yesod-core/test/YesodCoreTest/CleanPath.hs @@ -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' diff --git a/yesod-core/test/YesodCoreTest/ErrorHandling.hs b/yesod-core/test/YesodCoreTest/ErrorHandling.hs index f8517b36..f6fb6bb4 100644 --- a/yesod-core/test/YesodCoreTest/ErrorHandling.hs +++ b/yesod-core/test/YesodCoreTest/ErrorHandling.hs @@ -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) diff --git a/yesod-core/test/YesodCoreTest/Links.hs b/yesod-core/test/YesodCoreTest/Links.hs index f195368d..d461704d 100644 --- a/yesod-core/test/YesodCoreTest/Links.hs +++ b/yesod-core/test/YesodCoreTest/Links.hs @@ -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" diff --git a/yesod-core/test/YesodCoreTest/RawResponse.hs b/yesod-core/test/YesodCoreTest/RawResponse.hs index b55688d5..79f69900 100644 --- a/yesod-core/test/YesodCoreTest/RawResponse.hs +++ b/yesod-core/test/YesodCoreTest/RawResponse.hs @@ -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 diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index 84ae5ab0..bf61c3d6 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -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 diff --git a/yesod-eventsource/yesod-eventsource.cabal b/yesod-eventsource/yesod-eventsource.cabal index bb64a9e3..db77ea47 100644 --- a/yesod-eventsource/yesod-eventsource.cabal +++ b/yesod-eventsource/yesod-eventsource.cabal @@ -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 diff --git a/yesod-form/Yesod/Form/MassInput.hs b/yesod-form/Yesod/Form/MassInput.hs index a87b804c..e794ff27 100644 --- a/yesod-form/Yesod/Form/MassInput.hs +++ b/yesod-form/Yesod/Form/MassInput.hs @@ -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 diff --git a/yesod-static/Yesod/EmbeddedStatic/Generators.hs b/yesod-static/Yesod/EmbeddedStatic/Generators.hs index 2d8aeab1..b5c760e1 100644 --- a/yesod-static/Yesod/EmbeddedStatic/Generators.hs +++ b/yesod-static/Yesod/EmbeddedStatic/Generators.hs @@ -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 diff --git a/yesod-static/Yesod/Static.hs b/yesod-static/Yesod/Static.hs index 62918ebb..80d96ba1 100644 --- a/yesod-static/Yesod/Static.hs +++ b/yesod-static/Yesod/Static.hs @@ -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 diff --git a/yesod-static/yesod-static.cabal b/yesod-static/yesod-static.cabal index 2a9c8506..8ddf0dbc 100644 --- a/yesod-static/yesod-static.cabal +++ b/yesod-static/yesod-static.cabal @@ -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 diff --git a/yesod-test/ChangeLog.md b/yesod-test/ChangeLog.md index 41acb0c8..1ce26713 100644 --- a/yesod-test/ChangeLog.md +++ b/yesod-test/ChangeLog.md @@ -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) diff --git a/yesod-test/Yesod/Test.hs b/yesod-test/Yesod/Test.hs index 7c2a5be8..f6c13a40 100644 --- a/yesod-test/Yesod/Test.hs +++ b/yesod-test/Yesod/Test.hs @@ -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 @\