yesod-core 1.4.37.3 → 1.6.0
raw patch · 35 files changed
+610/−812 lines, 35 filesdep +gaugedep +unliftiodep −blaze-builderdep −criteriondep −data-defaultdep ~aesondep ~basedep ~bytestring
Dependencies added: gauge, unliftio
Dependencies removed: blaze-builder, criterion, data-default, exceptions, lifted-base, monad-control, mwc-random, transformers-base
Dependency ranges changed: aeson, base, bytestring, conduit, conduit-extra, cookie, monad-logger, resourcet, time, transformers
Files
- ChangeLog.md +14/−0
- Yesod/Core.hs +3/−17
- Yesod/Core/Class/Breadcrumbs.hs +2/−2
- Yesod/Core/Class/Dispatch.hs +23/−22
- Yesod/Core/Class/Handler.hs +55/−33
- Yesod/Core/Class/Yesod.hs +52/−86
- Yesod/Core/Content.hs +27/−50
- Yesod/Core/Dispatch.hs +10/−9
- Yesod/Core/Handler.hs +66/−70
- Yesod/Core/Internal/LiteApp.hs +2/−2
- Yesod/Core/Internal/Request.hs +18/−18
- Yesod/Core/Internal/Response.hs +8/−13
- Yesod/Core/Internal/Run.hs +30/−44
- Yesod/Core/Internal/TH.hs +37/−62
- Yesod/Core/Internal/Util.hs +1/−6
- Yesod/Core/Json.hs +6/−22
- Yesod/Core/Types.hs +168/−208
- Yesod/Core/Unsafe.hs +4/−1
- Yesod/Core/Widget.hs +9/−43
- Yesod/Routes/TH/ParseRoute.hs +2/−6
- Yesod/Routes/TH/RenderRoute.hs +2/−9
- Yesod/Routes/TH/RouteAttrs.hs +2/−6
- bench/widget.hs +4/−4
- test/Hierarchy.hs +3/−3
- test/RouteSpec.hs +3/−11
- test/YesodCoreTest/Cache.hs +1/−1
- test/YesodCoreTest/CleanPath.hs +2/−2
- test/YesodCoreTest/ErrorHandling.hs +6/−4
- test/YesodCoreTest/InternalRequest.hs +11/−11
- test/YesodCoreTest/Links.hs +2/−2
- test/YesodCoreTest/NoOverloadedStrings.hs +8/−7
- test/YesodCoreTest/NoOverloadedStringsSub.hs +2/−2
- test/YesodCoreTest/RawResponse.hs +12/−13
- test/YesodCoreTest/RequestBodySize.hs +2/−2
- yesod-core.cabal +13/−21
ChangeLog.md view
@@ -1,3 +1,17 @@+## 1.6.0++* Upgrade to conduit 1.3.0+* Switch to `MonadUnliftIO`+* Drop `mwc-random` and `blaze-builder` dependencies+* Strictify some internal data structures+* Add `CI` wrapper to first field in `Header` data constructor+ [#1418](https://github.com/yesodweb/yesod/issues/1418)+* Internal only change, users of stable API are unaffected: `WidgetT`+ holds its data in an `IORef` so that it is isomorphic to `ReaderT`,+ avoiding state-loss issues..+* Overhaul of `HandlerT`/`WidgetT` to no longer be transformers.+* Fix Haddock comment & simplify implementation for `contentTypeTypes` [#1476](https://github.com/yesodweb/yesod/issues/1476)+ ## 1.4.37.3 * Improve error message when request body is too large [#1477](https://github.com/yesodweb/yesod/pull/1477)
Yesod/Core.hs view
@@ -31,7 +31,6 @@ -- * Logging , defaultMakeLogger , defaultMessageLoggerSource- , defaultShouldLog , defaultShouldLogIO , formatLogMessage , LogLevel (..)@@ -67,11 +66,9 @@ -- * JS loaders , ScriptLoadPosition (..) , BottomOfHeadAsync- -- * Subsites+ -- * Generalizing type classes , MonadHandler (..) , MonadWidget (..)- , getRouteToParent- , defaultLayoutSub -- * Approot , guessApproot , guessApprootOr@@ -95,8 +92,7 @@ , module Text.Blaze.Html , MonadTrans (..) , MonadIO (..)- , MonadBase (..)- , MonadBaseControl+ , MonadUnliftIO (..) , MonadResource (..) , MonadLogger -- * Commonly referenced functions/datatypes@@ -143,9 +139,7 @@ import qualified Paths_yesod_core import Data.Version (showVersion) import Yesod.Routes.Class-import Control.Monad.IO.Class (MonadIO (..))-import Control.Monad.Base (MonadBase (..))-import Control.Monad.Trans.Control (MonadBaseControl (..))+import UnliftIO (MonadIO (..), MonadUnliftIO (..)) import Control.Monad.Trans.Resource (MonadResource (..)) import Yesod.Core.Internal.LiteApp@@ -184,14 +178,6 @@ maybeAuthorized r isWrite = do x <- isAuthorized r isWrite return $ if x == Authorized then Just r else Nothing--getRouteToParent :: Monad m => HandlerT child (HandlerT parent m) (Route child -> Route parent)-getRouteToParent = HandlerT $ return . handlerToParent--defaultLayoutSub :: Yesod parent- => WidgetT child IO ()- -> HandlerT child (HandlerT parent IO) Html-defaultLayoutSub cwidget = widgetToParentWidget cwidget >>= lift . defaultLayout showIntegral :: Integral a => a -> String showIntegral x = show (fromIntegral x :: Integer)
Yesod/Core/Class/Breadcrumbs.hs view
@@ -11,11 +11,11 @@ class YesodBreadcrumbs site where -- | Returns the title and the parent resource, if available. If you return -- a 'Nothing', then this is considered a top-level page.- breadcrumb :: Route site -> HandlerT site IO (Text , Maybe (Route site))+ breadcrumb :: Route site -> HandlerFor site (Text , Maybe (Route site)) -- | Gets the title of the current page and the hierarchy of parent pages, -- along with their respective titles.-breadcrumbs :: YesodBreadcrumbs site => HandlerT site IO (Text, [(Route site, Text)])+breadcrumbs :: YesodBreadcrumbs site => HandlerFor site (Text, [(Route site, Text)]) breadcrumbs = do x <- getCurrentRoute case x of
Yesod/Core/Class/Dispatch.hs view
@@ -6,46 +6,47 @@ {-# LANGUAGE FlexibleContexts #-} module Yesod.Core.Class.Dispatch where -import Yesod.Routes.Class import qualified Network.Wai as W import Yesod.Core.Types-import Yesod.Core.Content-import Yesod.Core.Handler (sendWaiApplication, stripHandlerT)+import Yesod.Core.Content (ToTypedContent (..))+import Yesod.Core.Handler (sendWaiApplication) import Yesod.Core.Class.Yesod-import Yesod.Core.Class.Handler -- | This class is automatically instantiated when you use the template haskell -- mkYesod function. You should never need to deal with it directly. class Yesod site => YesodDispatch site where yesodDispatch :: YesodRunnerEnv site -> W.Application -class YesodSubDispatch sub m where- yesodSubDispatch :: YesodSubRunnerEnv sub (HandlerSite m) m- -> W.Application+class YesodSubDispatch sub master where+ yesodSubDispatch :: YesodSubRunnerEnv sub master -> W.Application instance YesodSubDispatch WaiSubsite master where yesodSubDispatch YesodSubRunnerEnv {..} = app where WaiSubsite app = ysreGetSub $ yreSite ysreParentEnv -instance YesodSubDispatch WaiSubsiteWithAuth (HandlerT master IO) where+instance YesodSubDispatch WaiSubsiteWithAuth master where yesodSubDispatch YesodSubRunnerEnv {..} req =- ysreParentRunner base ysreParentEnv (fmap ysreToParentRoute route) req+ ysreParentRunner handlert ysreParentEnv (fmap ysreToParentRoute route) req where- base = stripHandlerT handlert ysreGetSub ysreToParentRoute route route = Just $ WaiSubsiteWithAuthRoute (W.pathInfo req) [] WaiSubsiteWithAuth set = ysreGetSub $ yreSite $ ysreParentEnv- handlert = sendWaiApplication $ set+ handlert = sendWaiApplication set --- | A helper function for creating YesodSubDispatch instances, used by the--- internal generated code. This function has been exported since 1.4.11.--- It promotes a subsite handler to a wai application.-subHelper :: Monad m -- NOTE: This is incredibly similar in type signature to yesodRunner, should probably be pointed out/explained.- => HandlerT child (HandlerT parent m) TypedContent- -> YesodSubRunnerEnv child parent (HandlerT parent m)- -> Maybe (Route child)- -> W.Application-subHelper handlert YesodSubRunnerEnv {..} route =- ysreParentRunner base ysreParentEnv (fmap ysreToParentRoute route)+subHelper+ :: ToTypedContent content+ => SubHandlerFor child master content+ -> YesodSubRunnerEnv child master+ -> Maybe (Route child)+ -> W.Application+subHelper (SubHandlerFor f) YesodSubRunnerEnv {..} mroute =+ ysreParentRunner handler ysreParentEnv (fmap ysreToParentRoute mroute) where- base = stripHandlerT (fmap toTypedContent handlert) ysreGetSub ysreToParentRoute route+ handler = fmap toTypedContent $ HandlerFor $ \hd ->+ let rhe = handlerEnv hd+ rhe' = rhe+ { rheRoute = mroute+ , rheChild = ysreGetSub $ yreSite ysreParentEnv+ , rheRouteToMaster = ysreToParentRoute+ }+ in f hd { handlerEnv = rhe' }
Yesod/Core/Class/Handler.hs view
@@ -5,29 +5,26 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-}-{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} -- Because of ErrorT module Yesod.Core.Class.Handler ( MonadHandler (..) , MonadWidget (..)+ , liftHandlerT+ , liftWidgetT ) where import Yesod.Core.Types-import Control.Monad (liftM)-import Control.Monad.IO.Class (liftIO)-import Control.Monad.Trans.Resource (MonadResource, MonadResourceBase)+import Control.Monad.Logger (MonadLogger)+import Control.Monad.Trans.Resource (MonadResource) import Control.Monad.Trans.Class (lift) #if __GLASGOW_HASKELL__ < 710-import Data.Monoid (Monoid, mempty)+import Data.Monoid (Monoid) #endif import Data.Conduit.Internal (Pipe, ConduitM) import Control.Monad.Trans.Identity ( IdentityT) import Control.Monad.Trans.List ( ListT ) import Control.Monad.Trans.Maybe ( MaybeT )-import Control.Monad.Trans.Error ( ErrorT, Error)-#if MIN_VERSION_transformers(0,4,0) import Control.Monad.Trans.Except ( ExceptT )-#endif import Control.Monad.Trans.Reader ( ReaderT ) import Control.Monad.Trans.State ( StateT ) import Control.Monad.Trans.Writer ( WriterT )@@ -36,32 +33,55 @@ import qualified Control.Monad.Trans.State.Strict as Strict ( StateT ) import qualified Control.Monad.Trans.Writer.Strict as Strict ( WriterT ) -class MonadResource m => MonadHandler m where+-- FIXME should we just use MonadReader instances instead?+class (MonadResource m, MonadLogger m) => MonadHandler m where type HandlerSite m- liftHandlerT :: HandlerT (HandlerSite m) IO a -> m a+ type SubHandlerSite m+ liftHandler :: HandlerFor (HandlerSite m) a -> m a+ liftSubHandler :: SubHandlerFor (SubHandlerSite m) (HandlerSite m) a -> m a -replaceToParent :: HandlerData site route -> HandlerData site ()-replaceToParent hd = hd { handlerToParent = const () }+liftHandlerT :: MonadHandler m => HandlerFor (HandlerSite m) a -> m a+liftHandlerT = liftHandler+{-# DEPRECATED liftHandlerT "Use liftHandler instead" #-} -instance MonadResourceBase m => MonadHandler (HandlerT site m) where- type HandlerSite (HandlerT site m) = site- liftHandlerT (HandlerT f) = HandlerT $ liftIO . f . replaceToParent-{-# RULES "liftHandlerT (HandlerT site IO)" liftHandlerT = id #-}+instance MonadHandler (HandlerFor site) where+ type HandlerSite (HandlerFor site) = site+ type SubHandlerSite (HandlerFor site) = site+ liftHandler = id+ {-# INLINE liftHandler #-}+ liftSubHandler (SubHandlerFor f) = HandlerFor f+ {-# INLINE liftSubHandler #-} -instance MonadResourceBase m => MonadHandler (WidgetT site m) where- type HandlerSite (WidgetT site m) = site- liftHandlerT (HandlerT f) = WidgetT $ liftIO . liftM (, mempty) . f . replaceToParent-{-# RULES "liftHandlerT (WidgetT site IO)" forall f. liftHandlerT (HandlerT f) = WidgetT $ liftM (, mempty) . f #-}+instance MonadHandler (SubHandlerFor sub master) where+ type HandlerSite (SubHandlerFor sub master) = master+ type SubHandlerSite (SubHandlerFor sub master) = sub+ liftHandler (HandlerFor f) = SubHandlerFor $ \hd -> f hd+ { handlerEnv =+ let rhe = handlerEnv hd+ in rhe+ { rheRoute = fmap (rheRouteToMaster rhe) (rheRoute rhe)+ , rheRouteToMaster = id+ , rheChild = rheSite rhe+ }+ }+ {-# INLINE liftHandler #-}+ liftSubHandler = id+ {-# INLINE liftSubHandler #-} -#define GO(T) instance MonadHandler m => MonadHandler (T m) where type HandlerSite (T m) = HandlerSite m; liftHandlerT = lift . liftHandlerT-#define GOX(X, T) instance (X, MonadHandler m) => MonadHandler (T m) where type HandlerSite (T m) = HandlerSite m; liftHandlerT = lift . liftHandlerT+instance MonadHandler (WidgetFor site) where+ type HandlerSite (WidgetFor site) = site+ type SubHandlerSite (WidgetFor site) = site+ liftHandler (HandlerFor f) = WidgetFor $ f . wdHandler+ {-# INLINE liftHandler #-}+ liftSubHandler (SubHandlerFor f) = WidgetFor $ f . wdHandler+ {-# INLINE liftSubHandler #-}++#define GO(T) instance MonadHandler m => MonadHandler (T m) where type HandlerSite (T m) = HandlerSite m; type SubHandlerSite (T m) = SubHandlerSite m; liftHandler = lift . liftHandler; liftSubHandler = lift . liftSubHandler+#define GOX(X, T) instance (X, MonadHandler m) => MonadHandler (T m) where type HandlerSite (T m) = HandlerSite m; type SubHandlerSite (T m) = SubHandlerSite m; liftHandler = lift . liftHandler; liftSubHandler = lift . liftSubHandler GO(IdentityT) GO(ListT) GO(MaybeT)-GOX(Error e, ErrorT e)-#if MIN_VERSION_transformers(0,4,0) GO(ExceptT e)-#endif GO(ReaderT r) GO(StateT s) GOX(Monoid w, WriterT w)@@ -75,19 +95,21 @@ #undef GOX class MonadHandler m => MonadWidget m where- liftWidgetT :: WidgetT (HandlerSite m) IO a -> m a-instance MonadResourceBase m => MonadWidget (WidgetT site m) where- liftWidgetT (WidgetT f) = WidgetT $ liftIO . f . replaceToParent+ liftWidget :: WidgetFor (HandlerSite m) a -> m a+instance MonadWidget (WidgetFor site) where+ liftWidget = id+ {-# INLINE liftWidget #-} -#define GO(T) instance MonadWidget m => MonadWidget (T m) where liftWidgetT = lift . liftWidgetT-#define GOX(X, T) instance (X, MonadWidget m) => MonadWidget (T m) where liftWidgetT = lift . liftWidgetT+liftWidgetT :: MonadWidget m => WidgetFor (HandlerSite m) a -> m a+liftWidgetT = liftWidget+{-# DEPRECATED liftWidgetT "Use liftWidget instead" #-}++#define GO(T) instance MonadWidget m => MonadWidget (T m) where liftWidget = lift . liftWidget+#define GOX(X, T) instance (X, MonadWidget m) => MonadWidget (T m) where liftWidget = lift . liftWidget GO(IdentityT) GO(ListT) GO(MaybeT)-GOX(Error e, ErrorT e)-#if MIN_VERSION_transformers(0,4,0) GO(ExceptT e)-#endif GO(ReaderT r) GO(StateT s) GOX(Monoid w, WriterT w)
Yesod/Core/Class/Yesod.hs view
@@ -10,9 +10,8 @@ import Yesod.Routes.Class -import Blaze.ByteString.Builder (Builder, toByteString)-import Blaze.ByteString.Builder.ByteString (copyByteString)-import Blaze.ByteString.Builder.Char.Utf8 (fromText, fromChar)+import Data.ByteString.Builder (Builder)+import Data.Text.Encoding (encodeUtf8Builder) import Control.Arrow ((***), second) import Control.Exception (bracket) #if __GLASGOW_HASKELL__ < 710@@ -37,9 +36,8 @@ import Data.Text.Lazy.Encoding (encodeUtf8) import Data.Word (Word64) import Language.Haskell.TH.Syntax (Loc (..))-import Network.HTTP.Types (encodePath, renderQueryText)+import Network.HTTP.Types (encodePath) import qualified Network.Wai as W-import Data.Default (def) import Network.Wai.Parse (lbsBackEnd, tempFileBackEnd) import Network.Wai.Logger (ZonedDate, clockDateCacher)@@ -52,13 +50,13 @@ import Text.Julius import qualified Web.ClientSession as CS import Web.Cookie (SetCookie (..), parseCookies, sameSiteLax,- sameSiteStrict, SameSiteOption)+ sameSiteStrict, SameSiteOption, defaultSetCookie) import Yesod.Core.Types import Yesod.Core.Internal.Session import Yesod.Core.Widget-import Control.Monad.Trans.Class (lift) import Data.CaseInsensitive (CI) import qualified Network.Wai.Request+import Data.IORef -- | Define settings for a Yesod applications. All methods have intelligent -- defaults, and therefore no implementation is required.@@ -66,27 +64,23 @@ -- | An absolute URL to the root of the application. Do not include -- trailing slash. --- -- Default value: 'ApprootRelative'. This is valid under the following- -- conditions:- --- -- * Your application is served from the root of the domain.- --- -- * You do not use any features that require absolute URLs, such as Atom- -- feeds and XML sitemaps.+ -- Default value: 'guessApproot'. If you know your application root+ -- statically, it will be more efficient and more reliable to instead use+ -- 'ApprootStatic' or 'ApprootMaster'. If you do not need full absolute+ -- URLs, you can use 'ApprootRelative' instead. --- -- If this is not true, you should override with a different- -- implementation.+ -- Note: Prior to yesod-core 1.5, the default value was 'ApprootRelative'. approot :: Approot site- approot = ApprootRelative+ approot = guessApproot -- | Output error response pages. -- -- Default value: 'defaultErrorHandler'.- errorHandler :: ErrorResponse -> HandlerT site IO TypedContent+ errorHandler :: ErrorResponse -> HandlerFor site TypedContent errorHandler = defaultErrorHandler -- | Applies some form of layout to the contents of a page.- defaultLayout :: WidgetT site IO () -> HandlerT site IO Html+ defaultLayout :: WidgetFor site () -> HandlerFor site Html defaultLayout w = do p <- widgetToPageContent w msgs <- getMessages@@ -103,33 +97,19 @@ ^{pageBody p} |] - -- | Override the rendering function for a particular URL. One use case for- -- this is to offload static hosting to a different domain name to avoid- -- sending cookies.- urlRenderOverride :: site -> Route site -> Maybe Builder- urlRenderOverride _ _ = Nothing- -- | Override the rendering function for a particular URL and query string -- parameters. One use case for this is to offload static hosting to a -- different domain name to avoid sending cookies.- -- + -- -- For backward compatibility default implementation is in terms of -- 'urlRenderOverride', probably ineffective- -- + -- -- Since 1.4.23 urlParamRenderOverride :: site -> Route site -> [(T.Text, T.Text)] -- ^ query string -> Maybe Builder- urlParamRenderOverride y route params = addParams params <$> urlRenderOverride y route- where- addParams [] routeBldr = routeBldr- addParams nonEmptyParams routeBldr =- let routeBS = toByteString routeBldr- qsSeparator = fromChar $ if S8.elem '?' routeBS then '&' else '?'- valueToMaybe t = if t == "" then Nothing else Just t- queryText = map (id *** valueToMaybe) nonEmptyParams- in copyByteString routeBS `mappend` qsSeparator `mappend` renderQueryText False queryText+ urlParamRenderOverride _ _ _ = Nothing -- | Determine if a request is authorized or not. --@@ -138,7 +118,7 @@ -- If authentication is required, return 'AuthenticationRequired'. isAuthorized :: Route site -> Bool -- ^ is this a write request?- -> HandlerT site IO AuthResult+ -> HandlerFor site AuthResult isAuthorized _ _ = return Authorized -- | Determines whether the current request is a write request. By default,@@ -148,7 +128,7 @@ -- -- This function is used to determine if a request is authorized; see -- 'isAuthorized'.- isWriteRequest :: Route site -> HandlerT site IO Bool+ isWriteRequest :: Route site -> HandlerFor site Bool isWriteRequest _ = do wai <- waiRequest return $ W.requestMethod wai `notElem`@@ -191,7 +171,7 @@ -> [(T.Text, T.Text)] -- ^ query string -> Builder joinPath _ ar pieces' qs' =- fromText ar `mappend` encodePath pieces qs+ encodeUtf8Builder ar `mappend` encodePath pieces qs where pieces = if null pieces' then [""] else map addDash pieces' qs = map (TE.encodeUtf8 *** go) qs'@@ -214,7 +194,7 @@ addStaticContent :: Text -- ^ filename extension -> Text -- ^ mime-type -> L.ByteString -- ^ content- -> HandlerT site IO (Maybe (Either Text (Route site, [(Text, Text)])))+ -> HandlerFor site (Maybe (Either Text (Route site, [(Text, Text)]))) addStaticContent _ _ _ = return Nothing -- | Maximum allowed length of the request body, in bytes.@@ -280,22 +260,11 @@ -- | Should we log the given log source/level combination. --- -- Default: the 'defaultShouldLog' function.- shouldLog :: site -> LogSource -> LogLevel -> Bool- shouldLog _ = defaultShouldLog-- -- | Should we log the given log source/level combination.- --- -- Note that this is almost identical to @shouldLog@, except the result- -- lives in @IO@. This allows you to dynamically alter the logging level of- -- your application by having this result depend on, e.g., an @IORef@.- --- -- The default implementation simply uses @shouldLog@. Future versions of- -- Yesod will remove @shouldLog@ and use this method exclusively.+ -- Default: the 'defaultShouldLogIO' function. -- -- Since 1.2.4 shouldLogIO :: site -> LogSource -> LogLevel -> IO Bool- shouldLogIO a b c = return (shouldLog a b c)+ shouldLogIO _ = defaultShouldLogIO -- | A Yesod middleware, which will wrap every handler function. This -- allows you to run code before and after a normal handler.@@ -303,7 +272,7 @@ -- Default: the 'defaultYesodMiddleware' function. -- -- Since: 1.1.6- yesodMiddleware :: ToTypedContent res => HandlerT site IO res -> HandlerT site IO res+ yesodMiddleware :: ToTypedContent res => HandlerFor site res -> HandlerFor site res yesodMiddleware = defaultYesodMiddleware -- | How to allocate an @InternalState@ for each request.@@ -324,7 +293,7 @@ -- primarily for wrapping up error messages for better display. -- -- @since 1.4.30- defaultMessageWidget :: Html -> HtmlUrl (Route site) -> WidgetT site IO ()+ defaultMessageWidget :: Html -> HtmlUrl (Route site) -> WidgetFor site () defaultMessageWidget title body = do setTitle title toWidget@@ -332,7 +301,6 @@ <h1>#{title} ^{body} |]-{-# DEPRECATED urlRenderOverride "Use urlParamRenderOverride instead" #-} -- | Default implementation of 'makeLogger'. Sends to stdout and -- automatically flushes on each write.@@ -369,21 +337,14 @@ -- above 'LevelInfo'. -- -- Since 1.4.10-defaultShouldLog :: LogSource -> LogLevel -> Bool-defaultShouldLog _ level = level >= LevelInfo---- | A default implementation of 'shouldLogIO' that can be used with--- 'defaultMessageLoggerSource'. Just uses 'defaultShouldLog'.------ Since 1.4.10 defaultShouldLogIO :: LogSource -> LogLevel -> IO Bool-defaultShouldLogIO a b = return $ defaultShouldLog a b+defaultShouldLogIO _ level = return $ level >= LevelInfo -- | Default implementation of 'yesodMiddleware'. Adds the response header -- \"Vary: Accept, Accept-Language\" and performs authorization checks. -- -- Since 1.2.0-defaultYesodMiddleware :: Yesod site => HandlerT site IO res -> HandlerT site IO res+defaultYesodMiddleware :: Yesod site => HandlerFor site res -> HandlerFor site res defaultYesodMiddleware handler = do addHeader "Vary" "Accept, Accept-Language" authorizationCheck@@ -443,8 +404,8 @@ -- -- Since 1.4.7 sslOnlyMiddleware :: Int -- ^ minutes- -> HandlerT site IO res- -> HandlerT site IO res+ -> HandlerFor site res+ -> HandlerFor site res sslOnlyMiddleware timeout handler = do addHeader "Strict-Transport-Security" $ T.pack $ concat [ "max-age="@@ -457,7 +418,7 @@ -- 'isWriteRequest'. -- -- Since 1.2.0-authorizationCheck :: Yesod site => HandlerT site IO ()+authorizationCheck :: Yesod site => HandlerFor site () authorizationCheck = getCurrentRoute >>= maybe (return ()) checkUrl where checkUrl url = do@@ -481,7 +442,7 @@ -- | Calls 'csrfCheckMiddleware' with 'isWriteRequest', 'defaultCsrfHeaderName', and 'defaultCsrfParamName' as parameters. -- -- Since 1.4.14-defaultCsrfCheckMiddleware :: Yesod site => HandlerT site IO res -> HandlerT site IO res+defaultCsrfCheckMiddleware :: Yesod site => HandlerFor site res -> HandlerFor site res defaultCsrfCheckMiddleware handler = csrfCheckMiddleware handler@@ -495,11 +456,11 @@ -- For details, see the "AJAX CSRF protection" section of "Yesod.Core.Handler". -- -- Since 1.4.14-csrfCheckMiddleware :: HandlerT site IO res- -> HandlerT site IO Bool -- ^ Whether or not to perform the CSRF check.+csrfCheckMiddleware :: HandlerFor site res+ -> HandlerFor site Bool -- ^ Whether or not to perform the CSRF check. -> CI S8.ByteString -- ^ The header name to lookup the CSRF token from. -> Text -- ^ The POST parameter name to lookup the CSRF token from.- -> HandlerT site IO res+ -> HandlerFor site res csrfCheckMiddleware handler shouldCheckFn headerName paramName = do shouldCheck <- shouldCheckFn when shouldCheck (checkCsrfHeaderOrParam headerName paramName)@@ -510,7 +471,7 @@ -- The cookie's path is set to @/@, making it valid for your whole website. -- -- Since 1.4.14-defaultCsrfSetCookieMiddleware :: HandlerT site IO res -> HandlerT site IO res+defaultCsrfSetCookieMiddleware :: HandlerFor site res -> HandlerFor site res defaultCsrfSetCookieMiddleware handler = setCsrfCookie >> handler -- | Takes a 'SetCookie' and overrides its value with a CSRF token, then sets the cookie. See 'setCsrfCookieWithCookie'.@@ -520,7 +481,7 @@ -- Make sure to set the 'setCookiePath' to the root path of your application, otherwise you'll generate a new CSRF token for every path of your app. If your app is run from from e.g. www.example.com\/app1, use @app1@. The vast majority of sites will just use @/@. -- -- Since 1.4.14-csrfSetCookieMiddleware :: HandlerT site IO res -> SetCookie -> HandlerT site IO res+csrfSetCookieMiddleware :: HandlerFor site res -> SetCookie -> HandlerFor site res csrfSetCookieMiddleware handler cookie = setCsrfCookieWithCookie cookie >> handler -- | Calls 'defaultCsrfSetCookieMiddleware' and 'defaultCsrfCheckMiddleware'.@@ -540,21 +501,26 @@ -- @ -- -- Since 1.4.14-defaultCsrfMiddleware :: Yesod site => HandlerT site IO res -> HandlerT site IO res+defaultCsrfMiddleware :: Yesod site => HandlerFor site res -> HandlerFor site res defaultCsrfMiddleware = defaultCsrfSetCookieMiddleware . defaultCsrfCheckMiddleware -- | Convert a widget to a 'PageContent'. widgetToPageContent :: Yesod site- => WidgetT site IO ()- -> HandlerT site IO (PageContent (Route site))-widgetToPageContent w = do- master <- getYesod- hd <- HandlerT return- ((), GWData (Body body) (Last mTitle) scripts' stylesheets' style jscript (Head head')) <- lift $ unWidgetT w hd- let title = maybe mempty unTitle mTitle- scripts = runUniqueList scripts'- stylesheets = runUniqueList stylesheets'+ => WidgetFor site ()+ -> HandlerFor site (PageContent (Route site))+widgetToPageContent w = HandlerFor $ \hd -> do+ master <- unHandlerFor getYesod hd+ ref <- newIORef mempty+ unWidgetFor w WidgetData+ { wdRef = ref+ , wdHandler = hd+ }+ GWData (Body body) (Last mTitle) scripts' stylesheets' style jscript (Head head') <- readIORef ref+ let title = maybe mempty unTitle mTitle+ scripts = runUniqueList scripts'+ stylesheets = runUniqueList stylesheets' + flip unHandlerFor hd $ do render <- getUrlRenderParams let renderLoc x = case x of@@ -642,7 +608,7 @@ runUniqueList (UniqueList x) = nub $ x [] -- | The default error handler for 'errorHandler'.-defaultErrorHandler :: Yesod site => ErrorResponse -> HandlerT site IO TypedContent+defaultErrorHandler :: Yesod site => ErrorResponse -> HandlerFor site TypedContent defaultErrorHandler NotFound = selectRep $ do provideRep $ defaultLayout $ do r <- waiRequest@@ -866,7 +832,7 @@ save date sess' = do -- We should never cache the IV! Be careful! iv <- liftIO CS.randomIV- return [AddCookie def+ return [AddCookie defaultSetCookie { setCookieName = sessionName , setCookieValue = encodeClientSession key iv date host sess' , setCookiePath = Just "/"
Yesod/Core/Content.hs view
@@ -53,31 +53,26 @@ import qualified Data.ByteString.Lazy as L import Data.Text.Lazy (Text, pack) import qualified Data.Text as T-import Blaze.ByteString.Builder (Builder, fromByteString, fromLazyByteString)+import Data.Text.Encoding (encodeUtf8Builder)+import qualified Data.Text.Lazy as TL+import Data.ByteString.Builder (Builder, byteString, lazyByteString, stringUtf8) #if __GLASGOW_HASKELL__ < 710 import Data.Monoid (mempty) #endif import Text.Hamlet (Html) import Text.Blaze.Html.Renderer.Utf8 (renderHtmlBuilder)-import Data.Conduit (Source, Flush (Chunk), ResumableSource, mapOutput)+import Data.Conduit (Flush (Chunk), SealedConduitT, mapOutput) import Control.Monad (liftM) import Control.Monad.Trans.Resource (ResourceT)-import Data.Conduit.Internal (ResumableSource (ResumableSource)) import qualified Data.Conduit.Internal as CI import qualified Data.Aeson as J-#if MIN_VERSION_aeson(1, 0, 0)-#elif MIN_VERSION_aeson(0, 7, 0)-import Data.Aeson.Encode (encodeToTextBuilder)-#else-import Data.Aeson.Encode (fromValue)-#endif-import qualified Blaze.ByteString.Builder.Char.Utf8 as Blaze import Data.Text.Lazy.Builder (toLazyText) import Yesod.Core.Types import Text.Lucius (Css, renderCss) import Text.Julius (Javascript, unJavascript) import Data.Word8 (_semicolon, _slash)+import Control.Arrow (second) -- | Zero-length enumerator. emptyContent :: Content@@ -99,15 +94,15 @@ instance ToContent Builder where toContent = flip ContentBuilder Nothing instance ToContent B.ByteString where- toContent bs = ContentBuilder (fromByteString bs) $ Just $ B.length bs+ toContent bs = ContentBuilder (byteString bs) $ Just $ B.length bs instance ToContent L.ByteString where- toContent = flip ContentBuilder Nothing . fromLazyByteString+ toContent = flip ContentBuilder Nothing . lazyByteString instance ToContent T.Text where- toContent = toContent . Blaze.fromText+ toContent = toContent . encodeUtf8Builder instance ToContent Text where- toContent = toContent . Blaze.fromLazyText+ toContent = toContent . foldMap encodeUtf8Builder . TL.toChunks instance ToContent String where- toContent = toContent . Blaze.fromString+ toContent = toContent . stringUtf8 instance ToContent Html where toContent bs = ContentBuilder (renderHtmlBuilder bs) Nothing instance ToContent () where@@ -123,12 +118,12 @@ toContent = toContent . toLazyText . unJavascript instance ToFlushBuilder builder => ToContent (CI.Pipe () () builder () (ResourceT IO) ()) where- toContent src = ContentSource $ CI.ConduitM (CI.mapOutput toFlushBuilder src >>=)+ toContent src = ContentSource $ CI.ConduitT (CI.mapOutput toFlushBuilder src >>=) -instance ToFlushBuilder builder => ToContent (Source (ResourceT IO) builder) where+instance ToFlushBuilder builder => ToContent (CI.ConduitT () builder (ResourceT IO) ()) where toContent src = ContentSource $ mapOutput toFlushBuilder src-instance ToFlushBuilder builder => ToContent (ResumableSource (ResourceT IO) builder) where- toContent (ResumableSource src _) = toContent src+instance ToFlushBuilder builder => ToContent (SealedConduitT () builder (ResourceT IO) ()) where+ toContent (CI.SealedConduitT src) = toContent src -- | A class for all data which can be sent in a streaming response. Note that -- for textual data, instances must use UTF-8 encoding.@@ -137,16 +132,16 @@ class ToFlushBuilder a where toFlushBuilder :: a -> Flush Builder instance ToFlushBuilder (Flush Builder) where toFlushBuilder = id instance ToFlushBuilder Builder where toFlushBuilder = Chunk-instance ToFlushBuilder (Flush B.ByteString) where toFlushBuilder = fmap fromByteString-instance ToFlushBuilder B.ByteString where toFlushBuilder = Chunk . fromByteString-instance ToFlushBuilder (Flush L.ByteString) where toFlushBuilder = fmap fromLazyByteString-instance ToFlushBuilder L.ByteString where toFlushBuilder = Chunk . fromLazyByteString-instance ToFlushBuilder (Flush Text) where toFlushBuilder = fmap Blaze.fromLazyText-instance ToFlushBuilder Text where toFlushBuilder = Chunk . Blaze.fromLazyText-instance ToFlushBuilder (Flush T.Text) where toFlushBuilder = fmap Blaze.fromText-instance ToFlushBuilder T.Text where toFlushBuilder = Chunk . Blaze.fromText-instance ToFlushBuilder (Flush String) where toFlushBuilder = fmap Blaze.fromString-instance ToFlushBuilder String where toFlushBuilder = Chunk . Blaze.fromString+instance ToFlushBuilder (Flush B.ByteString) where toFlushBuilder = fmap byteString+instance ToFlushBuilder B.ByteString where toFlushBuilder = Chunk . byteString+instance ToFlushBuilder (Flush L.ByteString) where toFlushBuilder = fmap lazyByteString+instance ToFlushBuilder L.ByteString where toFlushBuilder = Chunk . lazyByteString+instance ToFlushBuilder (Flush Text) where toFlushBuilder = fmap (foldMap encodeUtf8Builder . TL.toChunks)+instance ToFlushBuilder Text where toFlushBuilder = Chunk . foldMap encodeUtf8Builder . TL.toChunks+instance ToFlushBuilder (Flush T.Text) where toFlushBuilder = fmap encodeUtf8Builder+instance ToFlushBuilder T.Text where toFlushBuilder = Chunk . encodeUtf8Builder+instance ToFlushBuilder (Flush String) where toFlushBuilder = fmap stringUtf8+instance ToFlushBuilder String where toFlushBuilder = Chunk . stringUtf8 instance ToFlushBuilder (Flush Html) where toFlushBuilder = fmap renderHtmlBuilder instance ToFlushBuilder Html where toFlushBuilder = Chunk . renderHtmlBuilder @@ -228,13 +223,13 @@ simpleContentType :: ContentType -> ContentType simpleContentType = fst . B.break (== _semicolon) --- Give just the media types as a pair.+-- | Give just the media types as a pair.+-- -- For example, \"text/html; charset=utf-8\" returns ("text", "html") contentTypeTypes :: ContentType -> (B.ByteString, B.ByteString)-contentTypeTypes ct = (main, fst $ B.break (== _semicolon) (tailEmpty sub))+contentTypeTypes = second tailEmpty . B.break (== _slash) . simpleContentType where tailEmpty x = if B.null x then "" else B.tail x- (main, sub) = B.break (== _slash) ct instance HasContentType a => HasContentType (DontFullyEvaluate a) where getContentType = getContentType . liftM unDontFullyEvaluate@@ -243,34 +238,18 @@ toContent (DontFullyEvaluate a) = ContentDontEvaluate $ toContent a instance ToContent J.Value where-#if MIN_VERSION_aeson(1, 0, 0) toContent = flip ContentBuilder Nothing . J.fromEncoding . J.toEncoding-#else- toContent = flip ContentBuilder Nothing- . Blaze.fromLazyText- . toLazyText-#if MIN_VERSION_aeson(0, 7, 0)- . encodeToTextBuilder-#else- . fromValue-#endif -#endif--#if MIN_VERSION_aeson(0, 11, 0) instance ToContent J.Encoding where toContent = flip ContentBuilder Nothing . J.fromEncoding-#endif instance HasContentType J.Value where getContentType _ = typeJson -#if MIN_VERSION_aeson(0, 11, 0) instance HasContentType J.Encoding where getContentType _ = typeJson-#endif instance HasContentType Html where getContentType _ = typeHtml@@ -307,10 +286,8 @@ toTypedContent (RepXml c) = TypedContent typeXml c instance ToTypedContent J.Value where toTypedContent v = TypedContent typeJson (toContent v)-#if MIN_VERSION_aeson(0, 11, 0) instance ToTypedContent J.Encoding where toTypedContent e = TypedContent typeJson (toContent e)-#endif instance ToTypedContent Html where toTypedContent h = TypedContent typeHtml (toContent h) instance ToTypedContent T.Text where
Yesod/Core/Dispatch.hs view
@@ -35,7 +35,6 @@ -- * WAI subsites , WaiSubsite (..) , WaiSubsiteWithAuth (..)- , subHelper ) where import Prelude hiding (exp)@@ -53,8 +52,9 @@ import Data.Monoid (mappend) #endif import qualified Data.ByteString as S+import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Char8 as S8-import qualified Blaze.ByteString.Builder+import Data.ByteString.Builder (byteString, toLazyByteString) import Network.HTTP.Types (status301, status307) import Yesod.Routes.Parse import Yesod.Core.Types@@ -63,6 +63,7 @@ import Yesod.Core.Internal.Run import Safe (readMay) import System.Environment (getEnvironment)+import qualified System.Random as Random import Control.AutoUpdate (mkAutoUpdate, defaultUpdateSettings, updateAction, updateFreq) import Yesod.Core.Internal.Util (getCurrentMaxExpiresRFC1123) @@ -78,7 +79,6 @@ import Control.Monad (when) import qualified Paths_yesod_core import Data.Version (showVersion)-import qualified System.Random.MWC as MWC -- | Convert the given argument into a WAI application, executable with any WAI -- handler. This function will provide no middlewares; if you want commonly@@ -87,16 +87,18 @@ toWaiAppPlain site = do logger <- makeLogger site sb <- makeSessionBackend site- gen <- MWC.createSystemRandom getMaxExpires <- getGetMaxExpires return $ toWaiAppYre YesodRunnerEnv { yreLogger = logger , yreSite = site , yreSessionBackend = sb- , yreGen = gen+ , yreGen = defaultGen , yreGetMaxExpires = getMaxExpires } +defaultGen :: IO Int+defaultGen = Random.getStdRandom Random.next+ -- | Pure low level function to construct WAI application. Usefull -- when you need not standard way to run your app, or want to embed it -- inside another app.@@ -115,7 +117,7 @@ sendRedirect y segments' env sendResponse = sendResponse $ W.responseLBS status [ ("Content-Type", "text/plain")- , ("Location", Blaze.ByteString.Builder.toByteString dest')+ , ("Location", BL.toStrict $ toLazyByteString dest') ] "Redirecting" where -- Ensure that non-GET requests get redirected correctly. See:@@ -129,7 +131,7 @@ if S.null (W.rawQueryString env) then dest else dest `mappend`- Blaze.ByteString.Builder.fromByteString (W.rawQueryString env)+ byteString (W.rawQueryString env) -- | Same as 'toWaiAppPlain', but provides a default set of middlewares. This -- set may change with future releases, but currently covers:@@ -151,13 +153,12 @@ toWaiAppLogger :: YesodDispatch site => Logger -> site -> IO W.Application toWaiAppLogger logger site = do sb <- makeSessionBackend site- gen <- MWC.createSystemRandom getMaxExpires <- getGetMaxExpires let yre = YesodRunnerEnv { yreLogger = logger , yreSite = site , yreSessionBackend = sb- , yreGen = gen+ , yreGen = defaultGen , yreGetMaxExpires = getMaxExpires } messageLoggerSource
Yesod/Core/Handler.hs view
@@ -27,6 +27,7 @@ module Yesod.Core.Handler ( -- * Handler monad HandlerT+ , HandlerFor -- ** Read information from handler , getYesod , getsYesod@@ -146,6 +147,10 @@ , setMessage , setMessageI , getMessage+ -- * Subsites+ , getSubYesod+ , getRouteToParent+ , getSubCurrentRoute -- * Helpers for specific content -- ** Hamlet , hamletToRepHtml@@ -161,7 +166,6 @@ -- * Per-request caching , cached , cachedBy- , stripHandlerT -- * AJAX CSRF protection -- $ajaxCSRFOverview@@ -193,13 +197,14 @@ import Data.Monoid (mempty, mappend) #endif import Control.Applicative ((<|>))+import qualified Data.CaseInsensitive as CI import Control.Exception (evaluate, SomeException, throwIO)-import Control.Exception.Lifted (handle)+import Control.Exception (handle) import Control.Monad (void, liftM, unless) import qualified Control.Monad.Trans.Writer as Writer -import Control.Monad.IO.Class (MonadIO, liftIO)+import UnliftIO (MonadIO, liftIO, MonadUnliftIO, withRunInIO) import qualified Network.HTTP.Types as H import qualified Network.Wai as W@@ -228,40 +233,41 @@ import Data.Text (Text) import qualified Network.Wai.Parse as NWP import Text.Shakespeare.I18N (RenderMessage (..))-import Web.Cookie (SetCookie (..))+import Web.Cookie (SetCookie (..), defaultSetCookie) import Yesod.Core.Content (ToTypedContent (..), simpleContentType, contentTypeTypes, HasContentType (..), ToContent (..), ToFlushBuilder (..)) import Yesod.Core.Internal.Util (formatRFC1123) import Text.Blaze.Html (preEscapedToHtml, toHtml) -import qualified Data.IORef.Lifted as I+import qualified Data.IORef as I import Data.Maybe (listToMaybe, mapMaybe) import Data.Typeable (Typeable) import Web.PathPieces (PathPiece(..)) import Yesod.Core.Class.Handler import Yesod.Core.Types import Yesod.Routes.Class (Route)-import Blaze.ByteString.Builder (Builder)+import Data.ByteString.Builder (Builder) import Safe (headMay) import Data.CaseInsensitive (CI, original) import qualified Data.Conduit.List as CL import Control.Monad.Trans.Resource (MonadResource, InternalState, runResourceT, withInternalState, getInternalState, liftResourceT, resourceForkIO) import qualified System.PosixCompat.Files as PC-import Control.Monad.Trans.Control (control, MonadBaseControl)-import Data.Conduit (Source, transPipe, Flush (Flush), yield, Producer, Sink)+import Data.Conduit (ConduitT, transPipe, Flush (Flush), yield, Void) import qualified Yesod.Core.TypeCache as Cache import qualified Data.Word8 as W8 import qualified Data.Foldable as Fold-import Data.Default import Control.Monad.Logger (MonadLogger, logWarnS) +type HandlerT site (m :: * -> *) = HandlerFor site+{-# DEPRECATED HandlerT "Use HandlerFor directly" #-}+ get :: MonadHandler m => m GHState-get = liftHandlerT $ HandlerT $ I.readIORef . handlerState+get = liftHandler $ HandlerFor $ I.readIORef . handlerState put :: MonadHandler m => GHState -> m ()-put x = liftHandlerT $ HandlerT $ flip I.writeIORef x . handlerState+put x = liftHandler $ HandlerFor $ flip I.writeIORef x . handlerState modify :: MonadHandler m => (GHState -> GHState) -> m ()-modify f = liftHandlerT $ HandlerT $ flip I.modifyIORef f . handlerState+modify f = liftHandler $ HandlerFor $ flip I.modifyIORef f . handlerState tell :: MonadHandler m => Endo [Header] -> m () tell hs = modify $ \g -> g { ghsHeaders = ghsHeaders g `mappend` hs }@@ -273,14 +279,14 @@ hcError = handlerError . HCError getRequest :: MonadHandler m => m YesodRequest-getRequest = liftHandlerT $ HandlerT $ return . handlerRequest+getRequest = liftHandler $ HandlerFor $ return . handlerRequest runRequestBody :: MonadHandler m => m RequestBodyContents runRequestBody = do HandlerData { handlerEnv = RunHandlerEnv {..} , handlerRequest = req- } <- liftHandlerT $ HandlerT return+ } <- liftHandler $ HandlerFor return let len = W.requestBodyLength $ reqWaiRequest req upload = rheUpload len x <- get@@ -319,8 +325,8 @@ | otherwise = a' go = decodeUtf8With lenientDecode -askHandlerEnv :: MonadHandler m => m (RunHandlerEnv (HandlerSite m))-askHandlerEnv = liftHandlerT $ HandlerT $ return . handlerEnv+askHandlerEnv :: MonadHandler m => m (RunHandlerEnv (HandlerSite m) (HandlerSite m))+askHandlerEnv = liftHandler $ HandlerFor $ return . handlerEnv -- | Get the master site application argument. getYesod :: MonadHandler m => m (HandlerSite m)@@ -396,9 +402,9 @@ -- This allows the inner 'GHandler' to outlive the outer -- 'GHandler' (e.g., on the @forkIO@ example above, a response -- may be sent to the client without killing the new thread).-handlerToIO :: (MonadIO m1, MonadIO m2) => HandlerT site m1 (HandlerT site IO a -> m2 a)+handlerToIO :: MonadIO m => HandlerFor site (HandlerFor site a -> m a) handlerToIO =- HandlerT $ \oldHandlerData -> do+ HandlerFor $ \oldHandlerData -> do -- Take just the bits we need from oldHandlerData. let newReq = oldReq { reqWaiRequest = newWaiReq } where@@ -420,7 +426,7 @@ liftIO $ evaluate (newReq `seq` oldEnv `seq` newState `seq` ()) -- Return GHandler running function.- return $ \(HandlerT f) ->+ return $ \(HandlerFor f) -> liftIO $ runResourceT $ withInternalState $ \resState -> do -- The state IORef needs to be created here, otherwise it@@ -431,7 +437,6 @@ { handlerRequest = newReq , handlerEnv = oldEnv , handlerState = newStateIORef- , handlerToParent = const () , handlerResource = resState } liftIO (f newHandlerData)@@ -442,12 +447,13 @@ -- for correctness and efficiency -- -- @since 1.2.8-forkHandler :: (SomeException -> HandlerT site IO ()) -- ^ error handler- -> HandlerT site IO ()- -> HandlerT site IO ()+forkHandler :: (SomeException -> HandlerFor site ()) -- ^ error handler+ -> HandlerFor site ()+ -> HandlerFor site () forkHandler onErr handler = do yesRunner <- handlerToIO- void $ liftResourceT $ resourceForkIO $ yesRunner $ handle onErr handler+ void $ liftResourceT $ resourceForkIO $+ liftIO $ handle (yesRunner . onErr) (yesRunner handler) -- | Redirect to the given route. -- HTTP status code 303 for HTTP 1.1 clients and 302 for HTTP 1.0@@ -635,11 +641,7 @@ -- -- @since 1.4.18 sendStatusJSON :: (MonadHandler m, ToJSON c) => H.Status -> c -> m a-#if MIN_VERSION_aeson(0, 11, 0) sendStatusJSON s v = sendResponseStatus s (toEncoding v)-#else-sendStatusJSON s v = sendResponseStatus s (toJSON v)-#endif -- | Send a 201 "Created" response with the given route as the Location -- response header.@@ -668,10 +670,10 @@ -- -- @since 1.2.16 sendRawResponseNoConduit- :: (MonadHandler m, MonadBaseControl IO m)+ :: (MonadHandler m, MonadUnliftIO m) => (IO S8.ByteString -> (S8.ByteString -> IO ()) -> m ()) -> m a-sendRawResponseNoConduit raw = control $ \runInIO ->+sendRawResponseNoConduit raw = withRunInIO $ \runInIO -> liftIO $ throwIO $ HCWai $ flip W.responseRaw fallback $ \src sink -> void $ runInIO (raw src sink) where@@ -683,10 +685,11 @@ -- Warp). -- -- @since 1.2.7-sendRawResponse :: (MonadHandler m, MonadBaseControl IO m)- => (Source IO S8.ByteString -> Sink S8.ByteString IO () -> m ())- -> m a-sendRawResponse raw = control $ \runInIO ->+sendRawResponse+ :: (MonadHandler m, MonadUnliftIO m)+ => (ConduitT () S8.ByteString IO () -> ConduitT S8.ByteString Void IO () -> m ())+ -> m a+sendRawResponse raw = withRunInIO $ \runInIO -> liftIO $ throwIO $ HCWai $ flip W.responseRaw fallback $ \src sink -> void $ runInIO $ raw (src' src) (CL.mapM_ sink) where@@ -783,7 +786,7 @@ -- -- @since 1.2.0 addHeader :: MonadHandler m => Text -> Text -> m ()-addHeader a = addHeaderInternal . Header (encodeUtf8 a) . encodeUtf8+addHeader a = addHeaderInternal . Header (CI.mk $ encodeUtf8 a) . encodeUtf8 -- | Deprecated synonym for addHeader. setHeader :: MonadHandler m => Text -> Text -> m ()@@ -801,10 +804,10 @@ replaceOrAddHeader a b = modify $ \g -> g {ghsHeaders = replaceHeader (ghsHeaders g)} where- repHeader = Header (encodeUtf8 a) (encodeUtf8 b)+ repHeader = Header (CI.mk $ encodeUtf8 a) (encodeUtf8 b) sameHeaderName :: Header -> Header -> Bool- sameHeaderName (Header n1 _) (Header n2 _) = T.toLower (decodeUtf8 n1) == T.toLower (decodeUtf8 n2)+ sameHeaderName (Header n1 _) (Header n2 _) = n1 == n2 sameHeaderName _ _ = False replaceIndividualHeader :: [Header] -> [Header]@@ -1341,7 +1344,7 @@ -- | Stream in the raw request body without any parsing. -- -- @since 1.2.0-rawRequestBody :: MonadHandler m => Source m S.ByteString+rawRequestBody :: MonadHandler m => ConduitT i S.ByteString m () rawRequestBody = do req <- lift waiRequest let loop = do@@ -1353,7 +1356,7 @@ -- | Stream the data from the file. Since Yesod 1.2, this has been generalized -- to work in any @MonadResource@.-fileSource :: MonadResource m => FileInfo -> Source m S.ByteString+fileSource :: MonadResource m => FileInfo -> ConduitT () S.ByteString m () fileSource = transPipe liftResourceT . fileSourceRaw -- | Provide a pure value for the response body.@@ -1374,78 +1377,59 @@ -- -- @since 1.2.0 respondSource :: ContentType- -> Source (HandlerT site IO) (Flush Builder)- -> HandlerT site IO TypedContent-respondSource ctype src = HandlerT $ \hd ->+ -> ConduitT () (Flush Builder) (HandlerFor site) ()+ -> HandlerFor site TypedContent+respondSource ctype src = HandlerFor $ \hd -> -- Note that this implementation relies on the fact that the ResourceT -- environment provided by the server is the same one used in HandlerT. -- This is a safe assumption assuming the HandlerT is run correctly. return $ TypedContent ctype $ ContentSource- $ transPipe (lift . flip unHandlerT hd) src+ $ transPipe (lift . flip unHandlerFor hd) src -- | In a streaming response, send a single chunk of data. This function works -- on most datatypes, such as @ByteString@ and @Html@. -- -- @since 1.2.0-sendChunk :: Monad m => ToFlushBuilder a => a -> Producer m (Flush Builder)+sendChunk :: Monad m => ToFlushBuilder a => a -> ConduitT i (Flush Builder) m () sendChunk = yield . toFlushBuilder -- | In a streaming response, send a flush command, causing all buffered data -- to be immediately sent to the client. -- -- @since 1.2.0-sendFlush :: Monad m => Producer m (Flush Builder)+sendFlush :: Monad m => ConduitT i (Flush Builder) m () sendFlush = yield Flush -- | Type-specialized version of 'sendChunk' for strict @ByteString@s. -- -- @since 1.2.0-sendChunkBS :: Monad m => S.ByteString -> Producer m (Flush Builder)+sendChunkBS :: Monad m => S.ByteString -> ConduitT i (Flush Builder) m () sendChunkBS = sendChunk -- | Type-specialized version of 'sendChunk' for lazy @ByteString@s. -- -- @since 1.2.0-sendChunkLBS :: Monad m => L.ByteString -> Producer m (Flush Builder)+sendChunkLBS :: Monad m => L.ByteString -> ConduitT i (Flush Builder) m () sendChunkLBS = sendChunk -- | Type-specialized version of 'sendChunk' for strict @Text@s. -- -- @since 1.2.0-sendChunkText :: Monad m => T.Text -> Producer m (Flush Builder)+sendChunkText :: Monad m => T.Text -> ConduitT i (Flush Builder) m () sendChunkText = sendChunk -- | Type-specialized version of 'sendChunk' for lazy @Text@s. -- -- @since 1.2.0-sendChunkLazyText :: Monad m => TL.Text -> Producer m (Flush Builder)+sendChunkLazyText :: Monad m => TL.Text -> ConduitT i (Flush Builder) m () sendChunkLazyText = sendChunk -- | Type-specialized version of 'sendChunk' for @Html@s. -- -- @since 1.2.0-sendChunkHtml :: Monad m => Html -> Producer m (Flush Builder)+sendChunkHtml :: Monad m => Html -> ConduitT i (Flush Builder) m () sendChunkHtml = sendChunk --- | Converts a child handler to a parent handler------ Exported since 1.4.11-stripHandlerT :: HandlerT child (HandlerT parent m) a- -> (parent -> child)- -> (Route child -> Route parent)- -> Maybe (Route child)- -> HandlerT parent m a-stripHandlerT (HandlerT f) getSub toMaster newRoute = HandlerT $ \hd -> do- let env = handlerEnv hd- ($ hd) $ unHandlerT $ f hd- { handlerEnv = env- { rheSite = getSub $ rheSite env- , rheRoute = newRoute- , rheRender = \url params -> rheRender env (toMaster url) params- }- , handlerToParent = toMaster- }- -- $ajaxCSRFOverview -- When a user has authenticated with your site, all requests made from the browser to your server will include the session information that you use to verify that the user is logged in. -- Unfortunately, this allows attackers to make unwanted requests on behalf of the user by e.g. submitting an HTTP request to your site when the user visits theirs.@@ -1494,7 +1478,10 @@ -- -- @since 1.4.14 setCsrfCookie :: MonadHandler m => m ()-setCsrfCookie = setCsrfCookieWithCookie def { setCookieName = defaultCsrfCookieName, setCookiePath = Just "/" }+setCsrfCookie = setCsrfCookieWithCookie defaultSetCookie+ { setCookieName = defaultCsrfCookieName+ , setCookiePath = Just "/"+ } -- | Takes a 'SetCookie' and overrides its value with a CSRF token, then sets the cookie. --@@ -1610,3 +1597,12 @@ formatValue maybeText = case maybeText of Nothing -> "(which is not currently set)" Just t -> T.concat ["(which has the current, incorrect value: '", t, "')"]++getSubYesod :: MonadHandler m => m (SubHandlerSite m)+getSubYesod = liftSubHandler $ SubHandlerFor $ return . rheChild . handlerEnv++getRouteToParent :: MonadHandler m => m (Route (SubHandlerSite m) -> Route (HandlerSite m))+getRouteToParent = liftSubHandler $ SubHandlerFor $ return . rheRouteToMaster . handlerEnv++getSubCurrentRoute :: MonadHandler m => m (Maybe (Route (SubHandlerSite m)))+getSubCurrentRoute = liftSubHandler $ SubHandlerFor $ return . rheRoute . handlerEnv
Yesod/Core/Internal/LiteApp.hs view
@@ -46,8 +46,8 @@ mempty = LiteApp $ \_ _ -> Nothing mappend (LiteApp x) (LiteApp y) = LiteApp $ \m ps -> x m ps <|> y m ps -type LiteHandler = HandlerT LiteApp IO-type LiteWidget = WidgetT LiteApp IO+type LiteHandler = HandlerFor LiteApp+type LiteWidget = WidgetFor LiteApp liteApp :: Writer LiteApp () -> LiteApp liteApp = execWriter
Yesod/Core/Internal/Request.hs view
@@ -34,18 +34,13 @@ import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8With, decodeUtf8) import Data.Text.Encoding.Error (lenientDecode)-import Data.Conduit-import Data.Conduit.List (sourceList)-import Data.Conduit.Binary (sourceFile, sinkFile)+import Conduit import Data.Word (Word8, Word64)-import Control.Monad.Trans.Resource (runResourceT, ResourceT) import Control.Exception (throwIO) import Control.Monad ((<=<), liftM) import Yesod.Core.Types import qualified Data.Map as Map import Data.IORef-import qualified System.Random.MWC as MWC-import Control.Monad.Primitive (PrimMonad, PrimState) import qualified Data.Vector.Storable as V import Data.ByteString.Internal (ByteString (PS)) import qualified Data.Word8 as Word8@@ -83,7 +78,7 @@ -> SessionMap -> Bool -> Maybe Word64 -- ^ max body size- -> Either (IO YesodRequest) (MWC.GenIO -> IO YesodRequest)+ -> Either (IO YesodRequest) (IO Int -> IO YesodRequest) parseWaiRequest env session useToken mmaxBodySize = -- In most cases, we won't need to generate any random values. Therefore, -- we split our results: if we need a random generator, return a Right@@ -163,16 +158,21 @@ -- | Generate a random String of alphanumerical characters -- (a-z, A-Z, and 0-9) of the given length using the given -- random number generator.-randomString :: PrimMonad m => Int -> MWC.Gen (PrimState m) -> m Text+randomString :: Monad m => Int -> m Int -> m Text randomString len gen = liftM (decodeUtf8 . fromByteVector) $ V.replicateM len asciiChar where- asciiChar = liftM toAscii $ MWC.uniformR (0, 61) gen-- toAscii i- | i < 26 = i + Word8._A- | i < 52 = i + Word8._a - 26- | otherwise = i + Word8._0 - 52+ asciiChar =+ let loop = do+ x <- gen+ let y = fromIntegral $ x `mod` 64+ case () of+ ()+ | y < 26 -> return $ y + Word8._A+ | y < 52 -> return $ y + Word8._a - 26+ | y < 62 -> return $ y + Word8._0 - 52+ | otherwise -> loop+ in loop fromByteVector :: V.Vector Word8 -> ByteString fromByteVector v =@@ -183,13 +183,13 @@ mkFileInfoLBS :: Text -> Text -> L.ByteString -> FileInfo mkFileInfoLBS name ct lbs =- FileInfo name ct (sourceList $ L.toChunks lbs) (`L.writeFile` lbs)+ FileInfo name ct (sourceLazy lbs) (`L.writeFile` lbs) mkFileInfoFile :: Text -> Text -> FilePath -> FileInfo-mkFileInfoFile name ct fp = FileInfo name ct (sourceFile fp) (\dst -> runResourceT $ sourceFile fp $$ sinkFile dst)+mkFileInfoFile name ct fp = FileInfo name ct (sourceFile fp) (\dst -> runConduitRes $ sourceFile fp .| sinkFile dst) -mkFileInfoSource :: Text -> Text -> Source (ResourceT IO) ByteString -> FileInfo-mkFileInfoSource name ct src = FileInfo name ct src (\dst -> runResourceT $ src $$ sinkFile dst)+mkFileInfoSource :: Text -> Text -> ConduitT () ByteString (ResourceT IO) () -> FileInfo+mkFileInfoSource name ct src = FileInfo name ct src (\dst -> runConduitRes $ src .| sinkFile dst) tokenKey :: IsString a => a tokenKey = "_TOKEN"
Yesod/Core/Internal/Response.hs view
@@ -6,29 +6,24 @@ import Data.ByteString (ByteString) import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8+import qualified Data.ByteString.Lazy as BL import Data.CaseInsensitive (CI)-import qualified Data.CaseInsensitive as CI import Network.Wai import Control.Monad (mplus) import Control.Monad.Trans.Resource (runInternalState, InternalState) import Network.Wai.Internal-#if !MIN_VERSION_base(4, 6, 0)-import Prelude hiding (catch)-#endif import Web.Cookie (renderSetCookie) import Yesod.Core.Content import Yesod.Core.Types import qualified Network.HTTP.Types as H import qualified Data.Text as T import Control.Exception (SomeException, handle)-import Blaze.ByteString.Builder (fromLazyByteString,- toLazyByteString, toByteString)+import Data.ByteString.Builder (lazyByteString, toLazyByteString) import qualified Data.ByteString.Lazy as L import qualified Data.Map as Map import Yesod.Core.Internal.Request (tokenKey) import Data.Text.Encoding (encodeUtf8)-import Data.Conduit (Flush (..), ($$), transPipe)-import qualified Data.Conduit.List as CL+import Conduit yarToResponse :: YesodResponse -> (SessionMap -> IO [Header]) -- ^ save session@@ -56,9 +51,9 @@ sendResponse $ ResponseBuilder s hs' b go (ContentFile fp p) = sendResponse $ ResponseFile s finalHeaders fp p go (ContentSource body) = sendResponse $ responseStream s finalHeaders- $ \sendChunk flush ->+ $ \sendChunk flush -> runConduit $ transPipe (`runInternalState` is) body- $$ CL.mapM_ (\mchunk ->+ .| mapM_C (\mchunk -> case mchunk of Flush -> flush Chunk builder -> sendChunk builder)@@ -86,7 +81,7 @@ headerToPair :: Header -> (CI ByteString, ByteString) headerToPair (AddCookie sc) =- ("Set-Cookie", toByteString $ renderSetCookie sc)+ ("Set-Cookie", BL.toStrict $ toLazyByteString $ renderSetCookie sc) headerToPair (DeleteCookie key path) = ( "Set-Cookie" , S.concat@@ -96,14 +91,14 @@ , "; expires=Thu, 01-Jan-1970 00:00:00 GMT" ] )-headerToPair (Header key value) = (CI.mk key, value)+headerToPair (Header key value) = (key, value) evaluateContent :: Content -> IO (Either ErrorResponse Content) evaluateContent (ContentBuilder b mlen) = handle f $ do let lbs = toLazyByteString b len = L.length lbs mlen' = mlen `mplus` Just (fromIntegral len)- len `seq` return (Right $ ContentBuilder (fromLazyByteString lbs) mlen')+ len `seq` return (Right $ ContentBuilder (lazyByteString lbs) mlen') where f :: SomeException -> IO (Either ErrorResponse Content) f = return . Left . InternalError . T.pack . show
Yesod/Core/Internal/Run.hs view
@@ -14,9 +14,8 @@ import Control.Applicative ((<$>)) #endif import Yesod.Core.Internal.Response-import Blaze.ByteString.Builder (toByteString)-import Control.Exception (fromException, evaluate)-import qualified Control.Exception as E+import Data.ByteString.Builder (toLazyByteString)+import qualified Data.ByteString.Lazy as BL import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Logger (LogLevel (LevelError), LogSource, liftLoc)@@ -44,46 +43,29 @@ import Yesod.Core.Internal.Util (getCurrentMaxExpiresRFC1123) import Yesod.Routes.Class (Route, renderRoute) import Control.DeepSeq (($!!), NFData)---- | Catch all synchronous exceptions, ignoring asynchronous--- exceptions.------ Ideally we'd use this from a different library-catchSync :: IO a -> (E.SomeException -> IO a) -> IO a-catchSync thing after = thing `E.catch` \e ->- if isAsyncException e- then E.throwIO e- else after e---- | Determine if an exception is asynchronous------ Also worth being upstream-isAsyncException :: E.SomeException -> Bool-isAsyncException e =- case fromException e of- Just E.SomeAsyncException{} -> True- Nothing -> False+import UnliftIO.Exception --- | Convert an exception into an ErrorResponse-toErrorHandler :: E.SomeException -> IO ErrorResponse-toErrorHandler e0 = flip catchSync errFromShow $+-- | Convert a synchronous exception into an ErrorResponse+toErrorHandler :: SomeException -> IO ErrorResponse+toErrorHandler e0 = handleAny errFromShow $ case fromException e0 of Just (HCError x) -> evaluate $!! x- _- | isAsyncException e0 -> E.throwIO e0- | otherwise -> errFromShow e0+ _ -> errFromShow e0 -- | Generate an @ErrorResponse@ based on the shown version of the exception-errFromShow :: E.SomeException -> IO ErrorResponse-errFromShow x = evaluate $!! InternalError $! T.pack $! show x+errFromShow :: SomeException -> IO ErrorResponse+errFromShow x = do+ text <- evaluate (T.pack $ show x) `catchAny` \_ ->+ return (T.pack "Yesod.Core.Internal.Run.errFromShow: show of an exception threw an exception")+ return $ InternalError text -- | Do a basic run of a handler, getting some contents and the final -- @GHState@. The @GHState@ unfortunately may contain some impure -- exceptions, but all other synchronous exceptions will be caught and -- represented by the @HandlerContents@. basicRunHandler :: ToTypedContent c- => RunHandlerEnv site- -> HandlerT site IO c+ => RunHandlerEnv site site+ -> HandlerFor site c -> YesodRequest -> InternalState -> IO (GHState, HandlerContents)@@ -94,9 +76,9 @@ -- Run the handler itself, capturing any runtime exceptions and -- converting them into a @HandlerContents@- contents' <- catchSync+ contents' <- catchAny (do- res <- unHandlerT handler (hd istate)+ res <- unHandlerFor handler (hd istate) tc <- evaluate (toTypedContent res) -- Success! Wrap it up in an @HCContent@ return (HCContent defaultStatus tc))@@ -121,12 +103,11 @@ { handlerRequest = yreq , handlerEnv = rhe , handlerState = istate- , handlerToParent = const () , handlerResource = resState } -- | Convert an @ErrorResponse@ into a @YesodResponse@-handleError :: RunHandlerEnv site+handleError :: RunHandlerEnv sub site -> YesodRequest -> InternalState -> Map.Map Text S8.ByteString@@ -135,7 +116,7 @@ -> IO YesodResponse handleError rhe yreq resState finalSession headers e0 = do -- Find any evil hidden impure exceptions- e <- (evaluate $!! e0) `catchSync` errFromShow+ e <- (evaluate $!! e0) `catchAny` errFromShow -- Generate a response, leveraging the updated session and -- response headers@@ -200,15 +181,15 @@ => HandlerContents -> w -> IO (w, HandlerContents)-evalFallback contents val = catchSync+evalFallback contents val = catchAny (fmap (, contents) (evaluate $!! val)) (fmap ((mempty, ) . HCError) . toErrorHandler) -- | Function used internally by Yesod in the process of converting a -- 'HandlerT' into an 'Application'. Should not be needed by users. runHandler :: ToTypedContent c- => RunHandlerEnv site- -> HandlerT site IO c+ => RunHandlerEnv site site+ -> HandlerFor site c -> YesodApp runHandler rhe@RunHandlerEnv {..} handler yreq = withInternalState $ \resState -> do -- Get the raw state and original contents@@ -218,13 +199,14 @@ -- propagating exceptions into the contents (finalSession, contents1) <- evalFallback contents0 (ghsSession state) (headers, contents2) <- evalFallback contents1 (appEndo (ghsHeaders state) [])+ contents3 <- (evaluate contents2) `catchAny` (fmap HCError . toErrorHandler) -- Convert the HandlerContents into the final YesodResponse handleContents (handleError rhe yreq resState finalSession headers) finalSession headers- contents2+ contents3 safeEh :: (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) -> ErrorResponse@@ -263,7 +245,7 @@ SessionMap -> (site -> Logger) -> site- -> HandlerT site IO a+ -> HandlerFor site a -> m (Either ErrorResponse a) runFakeHandler fakeSessionMap logger site handler = liftIO $ do ret <- I.newIORef (Left $ InternalError "runFakeHandler: no result")@@ -273,6 +255,8 @@ RunHandlerEnv { rheRender = yesodRender site $ resolveApproot site fakeWaiRequest , rheRoute = Nothing+ , rheRouteToMaster = id+ , rheChild = site , rheSite = site , rheUpload = fileUpload site , rheLog = messageLoggerSource site $ logger site@@ -322,7 +306,7 @@ I.readIORef ret yesodRunner :: (ToTypedContent res, Yesod site)- => HandlerT site IO res+ => HandlerFor site res -> YesodRunnerEnv site -> Maybe (Route site) -> Application@@ -347,6 +331,8 @@ rheSafe = RunHandlerEnv { rheRender = yesodRender yreSite ra , rheRoute = route+ , rheRouteToMaster = id+ , rheChild = yreSite , rheSite = yreSite , rheUpload = fileUpload yreSite , rheLog = log'@@ -372,7 +358,7 @@ -> [(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')
Yesod/Core/Internal/TH.hs view
@@ -16,56 +16,63 @@ import qualified Network.Wai as W import Data.ByteString.Lazy.Char8 ()-#if MIN_VERSION_base(4,8,0)-import Data.List (foldl', uncons)-#else import Data.List (foldl')-#endif #if __GLASGOW_HASKELL__ < 710 import Control.Applicative ((<$>)) #endif import Control.Monad (replicateM, void)-import Data.Either (partitionEithers) import Text.Parsec (parse, many1, many, eof, try, option, sepBy1) import Text.ParserCombinators.Parsec.Char (alphaNum, spaces, string, char) import Yesod.Routes.TH import Yesod.Routes.Parse import Yesod.Core.Types-import Yesod.Core.Content import Yesod.Core.Class.Dispatch import Yesod.Core.Internal.Run -- | Generates URL datatype and site function for the given 'Resource's. This--- is used for creating sites, /not/ subsites. See 'mkYesodSub' for the latter.+-- is used for creating sites, /not/ subsites. See 'mkYesodSubData' and 'mkYesodSubDispatch' for the latter. -- Use 'parseRoutes' to create the 'Resource's.+--+-- Contexts and type variables in the name of the datatype are parsed. +-- For example, a datatype @App a@ with typeclass constraint @MyClass a@ can be written as @\"(MyClass a) => App a\"@. mkYesod :: String -- ^ name of the argument datatype -> [ResourceTree String] -> Q [Dec]-mkYesod name = fmap (uncurry (++)) . mkYesodGeneral name [] False return+mkYesod name = fmap (uncurry (++)) . mkYesodWithParser name False return -mkYesodWith :: String- -> [Either String [String]]+{-# DEPRECATED mkYesodWith "Contexts and type variables are now parsed from the name in `mkYesod`. <https://github.com/yesodweb/yesod/pull/1366>" #-}+-- | Similar to 'mkYesod', except contexts and type variables are not parsed. +-- Instead, they are explicitly provided. +-- You can write @(MyClass a) => App a@ with @mkYesodWith [[\"MyClass\",\"a\"]] \"App\" [\"a\"] ...@.+mkYesodWith :: [[String]] -- ^ list of contexts+ -> String -- ^ name of the argument datatype+ -> [String] -- ^ list of type variables -> [ResourceTree String] -> Q [Dec]-mkYesodWith name args = fmap (uncurry (++)) . mkYesodGeneral name args False return+mkYesodWith cxts name args = fmap (uncurry (++)) . mkYesodGeneral cxts name args False return -- | Sometimes, you will want to declare your routes in one file and define -- your handlers elsewhere. For example, this is the only way to break up a -- monolithic file into smaller parts. Use this function, paired with -- 'mkYesodDispatch', to do just that. mkYesodData :: String -> [ResourceTree String] -> Q [Dec]-mkYesodData name = mkYesodDataGeneral name False+mkYesodData name resS = fst <$> mkYesodWithParser name False return resS mkYesodSubData :: String -> [ResourceTree String] -> Q [Dec]-mkYesodSubData name = mkYesodDataGeneral name True+mkYesodSubData name resS = fst <$> mkYesodWithParser name True return resS -mkYesodDataGeneral :: String -> Bool -> [ResourceTree String] -> Q [Dec]-mkYesodDataGeneral name isSub res = do+-- | Parses contexts and type arguments out of name before generating TH.+mkYesodWithParser :: String -- ^ foundation type+ -> Bool -- ^ is this a subsite+ -> (Exp -> Q Exp) -- ^ unwrap handler+ -> [ResourceTree String]+ -> Q([Dec],[Dec])+mkYesodWithParser name isSub f resS = do let (name', rest, cxt) = case parse parseName "" name of Left err -> error $ show err Right a -> a- fst <$> mkYesodGeneral' cxt name' (fmap Left rest) isSub return res+ mkYesodGeneral cxt name' rest isSub f resS where parseName = do@@ -99,36 +106,25 @@ -- | See 'mkYesodData'. mkYesodDispatch :: String -> [ResourceTree String] -> Q [Dec]-mkYesodDispatch name = fmap snd . mkYesodGeneral name [] False return+mkYesodDispatch name = fmap snd . mkYesodWithParser name False return -- | Get the Handler and Widget type synonyms for the given site.-masterTypeSyns :: [Name] -> Type -> [Dec]+masterTypeSyns :: [Name] -> Type -> [Dec] -- FIXME remove from here, put into the scaffolding itself? masterTypeSyns vs site = [ TySynD (mkName "Handler") (fmap PlainTV vs)- $ ConT ''HandlerT `AppT` site `AppT` ConT ''IO+ $ ConT ''HandlerFor `AppT` site , TySynD (mkName "Widget") (fmap PlainTV vs)- $ ConT ''WidgetT `AppT` site `AppT` ConT ''IO `AppT` ConT ''()+ $ ConT ''WidgetFor `AppT` site `AppT` ConT ''() ] --- | 'Left' arguments indicate a monomorphic type, a 'Right' argument--- indicates a polymorphic type, and provides the list of classes--- the type must be instance of.-mkYesodGeneral :: String -- ^ foundation type- -> [Either String [String]] -- ^ arguments for the type- -> Bool -- ^ is this a subsite- -> (Exp -> Q Exp) -- ^ unwrap handler- -> [ResourceTree String]- -> Q([Dec],[Dec])-mkYesodGeneral = mkYesodGeneral' []--mkYesodGeneral' :: [[String]] -- ^ Appliction context. Used in RenderRoute, RouteAttrs, and ParseRoute instances.+mkYesodGeneral :: [[String]] -- ^ Appliction context. Used in RenderRoute, RouteAttrs, and ParseRoute instances. -> String -- ^ foundation type- -> [Either String [String]] -- ^ arguments for the type+ -> [String] -- ^ arguments for the type -> Bool -- ^ is this a subsite -> (Exp -> Q Exp) -- ^ unwrap handler -> [ResourceTree String] -> Q([Dec],[Dec])-mkYesodGeneral' appCxt' namestr args isSub f resS = do+mkYesodGeneral appCxt' namestr mtys isSub f resS = do let appCxt = fmap (\(c:rest) -> #if MIN_VERSION_template_haskell(2,10,0) foldl' (\acc v -> acc `AppT` nameToType v) (ConT $ mkName c) rest@@ -151,36 +147,21 @@ DataD _ _ vs _ _ -> length vs NewtypeD _ _ vs _ _ -> length vs #endif+ TySynD _ vs _ -> length vs _ -> 0 _ -> 0 _ -> return 0 let name = mkName namestr- (mtys,_) = partitionEithers args -- Generate as many variable names as the arity indicates vns <- replicateM (arity - length mtys) $ newName "t" -- Base type (site type with variables)- let (argtypes,cxt) = (\(ns,r,cs) -> (ns ++ fmap VarT r, cs)) $- foldr (\arg (xs,vns',cs) ->- case arg of- Left t -> - ( nameToType t:xs, vns', cs )- Right ts -> - let (n, ns) = maybe (error "mkYesodGeneral: Should be unreachable.") id $ uncons vns' in- ( VarT n : xs, ns- , fmap (\t ->-#if MIN_VERSION_template_haskell(2,10,0)- AppT (ConT $ mkName t) (VarT n)-#else- ClassP (mkName t) [VarT n]-#endif- ) ts ++ cs )- ) ([],vns,[]) args+ let argtypes = fmap nameToType mtys ++ fmap VarT vns site = foldl' AppT (ConT name) argtypes res = map (fmap (parseType . dropBracket)) resS- renderRouteDec <- mkRenderRouteInstance' appCxt site res- routeAttrsDec <- mkRouteAttrsInstance' appCxt site res- dispatchDec <- mkDispatchInstance site cxt f res- parseRoute <- mkParseRouteInstance' appCxt site res+ renderRouteDec <- mkRenderRouteInstance appCxt site res+ routeAttrsDec <- mkRouteAttrsInstance appCxt site res+ dispatchDec <- mkDispatchInstance site appCxt f res+ parseRoute <- mkParseRouteInstance appCxt site res let rname = mkName $ "resources" ++ namestr eres <- lift resS let resourcesDec =@@ -196,12 +177,6 @@ ] return (dataDec, dispatchDec) -#if !MIN_VERSION_base(4,8,0)- where- uncons (h:t) = Just (h,t)- uncons _ = Nothing-#endif- mkMDS :: (Exp -> Q Exp) -> Q Exp -> MkDispatchSettings a site b mkMDS f rh = MkDispatchSettings { mdsRunHandler = rh@@ -242,7 +217,7 @@ mkYesodSubDispatch :: [ResourceTree a] -> Q Exp mkYesodSubDispatch res = do- clause' <- mkDispatchClause (mkMDS return [|subHelper . fmap toTypedContent|]) res+ clause' <- mkDispatchClause (mkMDS return [|subHelper|]) res inner <- newName "inner" let innerFun = FunD inner [clause'] helper <- newName "helper"
Yesod/Core/Internal/Util.hs view
@@ -13,12 +13,7 @@ import qualified Data.Text as T import Data.Time (Day (ModifiedJulianDay, toModifiedJulianDay), DiffTime, UTCTime (..), formatTime,- getCurrentTime, addUTCTime)-#if MIN_VERSION_time(1,5,0)-import Data.Time (defaultTimeLocale)-#else-import System.Locale (defaultTimeLocale)-#endif+ getCurrentTime, addUTCTime, defaultTimeLocale) putTime :: UTCTime -> Put putTime (UTCTime d t) =
Yesod/Core/Json.hs view
@@ -6,9 +6,7 @@ defaultLayoutJson , jsonToRepJson , returnJson-#if MIN_VERSION_aeson(0, 11, 0) , returnJsonEncoding-#endif , provideJson -- * Convert to a JSON value@@ -29,20 +27,18 @@ -- * Convenience functions , jsonOrRedirect-#if MIN_VERSION_aeson(0, 11, 0) , jsonEncodingOrRedirect-#endif , acceptsJson ) where -import Yesod.Core.Handler (HandlerT, getRequest, invalidArgs, redirect, selectRep, provideRep, rawRequestBody, ProvidedRep, lookupHeader)+import Yesod.Core.Handler (HandlerFor, getRequest, invalidArgs, redirect, selectRep, provideRep, rawRequestBody, ProvidedRep, lookupHeader) import Control.Monad.Trans.Writer (Writer) import Data.Monoid (Endo) import Yesod.Core.Content (TypedContent) import Yesod.Core.Types (reqAccept) import Yesod.Core.Class.Yesod (defaultLayout, Yesod) import Yesod.Core.Class.Handler-import Yesod.Core.Widget (WidgetT)+import Yesod.Core.Widget (WidgetFor) import Yesod.Routes.Class import qualified Data.Aeson as J import qualified Data.Aeson.Parser as JP@@ -62,16 +58,12 @@ -- -- @since 0.3.0 defaultLayoutJson :: (Yesod site, J.ToJSON a)- => WidgetT site IO () -- ^ HTML- -> HandlerT site IO a -- ^ JSON- -> HandlerT site IO TypedContent+ => WidgetFor site () -- ^ HTML+ -> HandlerFor site a -- ^ JSON+ -> HandlerFor site TypedContent defaultLayoutJson w json = selectRep $ do provideRep $ defaultLayout w-#if MIN_VERSION_aeson(0, 11, 0) provideRep $ fmap J.toEncoding json-#else- provideRep $ fmap J.toJSON json-#endif -- | Wraps a data type in a 'RepJson'. The data type must -- support conversion to JSON via 'J.ToJSON'.@@ -87,24 +79,18 @@ returnJson :: (Monad m, J.ToJSON a) => a -> m J.Value returnJson = return . J.toJSON -#if MIN_VERSION_aeson(0, 11, 0) -- | Convert a value to a JSON representation via aeson\'s 'J.toEncoding' function. -- -- @since 1.4.21 returnJsonEncoding :: (Monad m, J.ToJSON a) => a -> m J.Encoding returnJsonEncoding = return . J.toEncoding-#endif -- | Provide a JSON representation for usage with 'selectReps', using aeson\'s -- 'J.toJSON' (aeson >= 0.11: 'J.toEncoding') function to perform the conversion. -- -- @since 1.2.1 provideJson :: (Monad m, J.ToJSON a) => a -> Writer (Endo [ProvidedRep m]) ()-#if MIN_VERSION_aeson(0, 11, 0) provideJson = provideRep . return . J.toEncoding-#else-provideJson = provideRep . return . J.toJSON-#endif -- | Parse the request body to a data type as a JSON value. The -- data type must support conversion from JSON via 'J.FromJSON'.@@ -118,7 +104,7 @@ -- @since 0.3.0 parseJsonBody :: (MonadHandler m, J.FromJSON a) => m (J.Result a) parseJsonBody = do- eValue <- rawRequestBody $$ runCatchC (sinkParser JP.value')+ eValue <- runConduit $ rawRequestBody .| runCatchC (sinkParser JP.value') return $ case eValue of Left e -> J.Error $ show e Right value -> J.fromJSON value@@ -173,7 +159,6 @@ -> m J.Value jsonOrRedirect = jsonOrRedirect' J.toJSON -#if MIN_VERSION_aeson(0, 11, 0) -- | jsonEncodingOrRedirect simplifies the scenario where a POST handler sends a different -- response based on Accept headers: --@@ -187,7 +172,6 @@ -> a -- ^ Data to send via JSON -> m J.Encoding jsonEncodingOrRedirect = jsonOrRedirect' J.toEncoding-#endif jsonOrRedirect' :: MonadHandler m => (a -> b)
Yesod/Core/Types.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TupleSections #-}@@ -9,8 +10,7 @@ {-# LANGUAGE UndecidableInstances #-} module Yesod.Core.Types where -import qualified Blaze.ByteString.Builder as BBuilder-import qualified Blaze.ByteString.Builder.Char.Utf8+import qualified Data.ByteString.Builder as BB #if __GLASGOW_HASKELL__ < 710 import Control.Applicative (Applicative (..)) import Control.Applicative ((<$>))@@ -18,18 +18,16 @@ #endif import Control.Arrow (first) import Control.Exception (Exception)-import Control.Monad (liftM, ap)-import Control.Monad.Base (MonadBase (liftBase))-import Control.Monad.Catch (MonadMask (..), MonadCatch (..))+import Control.Monad (ap) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Logger (LogLevel, LogSource, MonadLogger (..))-import Control.Monad.Trans.Control (MonadBaseControl (..))-import Control.Monad.Trans.Resource (MonadResource (..), InternalState, runInternalState, MonadThrow (..), monadThrow, ResourceT)+import Control.Monad.Trans.Resource (MonadResource (..), InternalState, runInternalState, MonadThrow (..), ResourceT) import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as L-import Data.Conduit (Flush, Source)-import Data.IORef (IORef)+import Data.CaseInsensitive (CI)+import Data.Conduit (Flush, ConduitT)+import Data.IORef (IORef, modifyIORef') import Data.Map (Map, unionWith) import qualified Data.Map as Map import Data.Monoid (Endo (..), Last (..))@@ -49,27 +47,21 @@ import qualified Network.Wai as W import qualified Network.Wai.Parse as NWP import System.Log.FastLogger (LogStr, LoggerSet, toLogStr, pushLogStr)-import qualified System.Random.MWC as MWC import Network.Wai.Logger (DateCacheGetter) import Text.Blaze.Html (Html, toHtml) import Text.Hamlet (HtmlUrl) import Text.Julius (JavascriptUrl) import Web.Cookie (SetCookie) import Yesod.Core.Internal.Util (getTime, putTime)-import Control.Monad.Trans.Class (MonadTrans (..)) import Yesod.Routes.Class (RenderRoute (..), ParseRoute (..)) import Control.Monad.Reader (MonadReader (..))-#if !MIN_VERSION_base(4, 6, 0)-import Prelude hiding (catch)-#endif+import Data.Monoid ((<>)) import Control.DeepSeq (NFData (rnf)) import Control.DeepSeq.Generics (genericRnf)-import Data.Conduit.Lazy (MonadActive, monadActive) import Yesod.Core.TypeCache (TypeMap, KeyedTypeMap)-#if MIN_VERSION_monad_logger(0, 3, 10) import Control.Monad.Logger (MonadLoggerIO (..))-#endif import Data.Semigroup (Semigroup)+import UnliftIO (MonadUnliftIO (..), UnliftIO (..)) -- Sessions type SessionMap = Map Text ByteString@@ -82,7 +74,7 @@ -> IO (SessionMap, SaveSession) -- ^ Return the session data and a function to save the session } -data SessionCookie = SessionCookie (Either UTCTime ByteString) ByteString SessionMap+data SessionCookie = SessionCookie !(Either UTCTime ByteString) !ByteString !SessionMap deriving (Show, Read) instance Serialize SessionCookie where put (SessionCookie a b c) = do@@ -140,13 +132,13 @@ data FileInfo = FileInfo { fileName :: !Text , fileContentType :: !Text- , fileSourceRaw :: !(Source (ResourceT IO) ByteString)+ , fileSourceRaw :: !(ConduitT () ByteString (ResourceT IO) ()) , fileMove :: !(FilePath -> IO ()) } data FileUpload = FileUploadMemory !(NWP.BackEnd L.ByteString) | FileUploadDisk !(InternalState -> NWP.BackEnd FilePath)- | FileUploadSource !(NWP.BackEnd (Source (ResourceT IO) ByteString))+ | FileUploadSource !(NWP.BackEnd (ConduitT () ByteString (ResourceT IO) ())) -- | How to determine the root of the application for constructing URLs. --@@ -160,13 +152,13 @@ type ResolvedApproot = Text -data AuthResult = Authorized | AuthenticationRequired | Unauthorized Text+data AuthResult = Authorized | AuthenticationRequired | Unauthorized !Text deriving (Eq, Show, Read) data ScriptLoadPosition master = BottomOfBody | BottomOfHeadBlocking- | BottomOfHeadAsync (BottomOfHeadAsync master)+ | BottomOfHeadAsync !(BottomOfHeadAsync master) type BottomOfHeadAsync master = [Text] -- ^ urls to load asynchronously@@ -179,14 +171,16 @@ newtype WaiSubsite = WaiSubsite { runWaiSubsite :: W.Application } -- | Like 'WaiSubsite', but applies parent site's middleware and isAuthorized.--- +-- -- @since 1.4.34 newtype WaiSubsiteWithAuth = WaiSubsiteWithAuth { runWaiSubsiteWithAuth :: W.Application } -data RunHandlerEnv site = RunHandlerEnv+data RunHandlerEnv child site = RunHandlerEnv { rheRender :: !(Route site -> [(Text, Text)] -> Text)- , rheRoute :: !(Maybe (Route site))+ , rheRoute :: !(Maybe (Route child))+ , rheRouteToMaster :: !(Route child -> Route site) , rheSite :: !site+ , rheChild :: !child , rheUpload :: !(RequestBodyLength -> FileUpload) , rheLog :: !(Loc -> LogSource -> LogLevel -> LogStr -> IO ()) , rheOnError :: !(ErrorResponse -> YesodApp)@@ -196,11 +190,10 @@ , rheMaxExpires :: !Text } -data HandlerData site parentRoute = HandlerData+data HandlerData child site = HandlerData { handlerRequest :: !YesodRequest- , handlerEnv :: !(RunHandlerEnv site)+ , handlerEnv :: !(RunHandlerEnv child site) , handlerState :: !(IORef GHState)- , handlerToParent :: !(Route site -> parentRoute) , handlerResource :: !InternalState } @@ -208,40 +201,38 @@ { yreLogger :: !Logger , yreSite :: !site , yreSessionBackend :: !(Maybe SessionBackend)- , yreGen :: !MWC.GenIO- , yreGetMaxExpires :: IO Text+ , yreGen :: !(IO Int)+ -- ^ Generate a random number+ , yreGetMaxExpires :: !(IO Text) } -data YesodSubRunnerEnv sub parent parentMonad = YesodSubRunnerEnv- { ysreParentRunner :: !(ParentRunner parent parentMonad)+data YesodSubRunnerEnv sub parent = YesodSubRunnerEnv+ { ysreParentRunner :: !(ParentRunner parent) , ysreGetSub :: !(parent -> sub) , ysreToParentRoute :: !(Route sub -> Route parent) , ysreParentEnv :: !(YesodRunnerEnv parent) -- FIXME maybe get rid of this and remove YesodRunnerEnv in ParentRunner? } -type ParentRunner parent m- = m TypedContent+type ParentRunner parent+ = HandlerFor parent TypedContent -> YesodRunnerEnv parent -> Maybe (Route parent) -> W.Application -- | A generic handler monad, which can have a different subsite and master -- site. We define a newtype for better error message.-newtype HandlerT site m a = HandlerT- { unHandlerT :: HandlerData site (MonadRoute m) -> m a+newtype HandlerFor site a = HandlerFor+ { unHandlerFor :: HandlerData site site -> IO a }--type family MonadRoute (m :: * -> *)-type instance MonadRoute IO = ()-type instance MonadRoute (HandlerT site m) = (Route site)+ deriving Functor data GHState = GHState- { ghsSession :: SessionMap- , ghsRBC :: Maybe RequestBodyContents- , ghsIdent :: Int- , ghsCache :: TypeMap- , ghsCacheBy :: KeyedTypeMap- , ghsHeaders :: Endo [Header]+ { ghsSession :: !SessionMap+ , ghsRBC :: !(Maybe RequestBodyContents)+ , ghsIdent :: !Int+ , ghsCache :: !TypeMap+ , ghsCacheBy :: !KeyedTypeMap+ , ghsHeaders :: !(Endo [Header]) } -- | An extension of the basic WAI 'W.Application' datatype to provide extra@@ -252,25 +243,33 @@ -- | A generic widget, allowing specification of both the subsite and master -- site datatypes. While this is simply a @WriterT@, we define a newtype for -- better error messages.-newtype WidgetT site m a = WidgetT- { unWidgetT :: HandlerData site (MonadRoute m) -> m (a, GWData (Route site))+newtype WidgetFor site a = WidgetFor+ { unWidgetFor :: WidgetData site -> IO a }+ deriving Functor -instance (a ~ (), Monad m) => Monoid (WidgetT site m a) where+data WidgetData site = WidgetData+ { wdRef :: {-# UNPACK #-} !(IORef (GWData (Route site)))+ , wdHandler :: {-# UNPACK #-} !(HandlerData site site)+ }++instance a ~ () => Monoid (WidgetFor site a) where mempty = return () mappend x y = x >> y-instance (a ~ (), Monad m) => Semigroup (WidgetT site m a)+instance a ~ () => Semigroup (WidgetFor site a) -- | A 'String' can be trivially promoted to a widget. -- -- For example, in a yesod-scaffold site you could use: -- -- @getHomeR = do defaultLayout "Widget text"@-instance (Monad m, a ~ ()) => IsString (WidgetT site m a) where+instance a ~ () => IsString (WidgetFor site a) where fromString = toWidget . toHtml . T.pack- where toWidget x = WidgetT $ const $ return ((), GWData (Body (const x))- mempty mempty mempty mempty mempty mempty)+ where toWidget x = tellWidget mempty { gwdBody = Body (const x) } +tellWidget :: GWData (Route site) -> WidgetFor site ()+tellWidget d = WidgetFor $ \wd -> modifyIORef' (wdRef wd) (<> d)+ type RY master = Route master -> [(Text, Text)] -> Text -- | Newtype wrapper allowing injection of arbitrary content into CSS.@@ -287,13 +286,13 @@ -- -- > PageContent url -> HtmlUrl url data PageContent url = PageContent- { pageTitle :: Html- , pageHead :: HtmlUrl url- , pageBody :: HtmlUrl url+ { pageTitle :: !Html+ , pageHead :: !(HtmlUrl url)+ , pageBody :: !(HtmlUrl url) } -data Content = ContentBuilder !BBuilder.Builder !(Maybe Int) -- ^ The content and optional content length.- | ContentSource !(Source (ResourceT IO) (Flush BBuilder.Builder))+data Content = ContentBuilder !BB.Builder !(Maybe Int) -- ^ The content and optional content length.+ | ContentSource !(ConduitT () (Flush BB.Builder) (ResourceT IO) ()) | ContentFile !FilePath !(Maybe FilePart) | ContentDontEvaluate !Content @@ -316,11 +315,11 @@ -- | Responses to indicate some form of an error occurred. data ErrorResponse = NotFound- | InternalError Text- | InvalidArgs [Text]+ | InternalError !Text+ | InvalidArgs ![Text] | NotAuthenticated- | PermissionDenied Text- | BadMethod H.Method+ | PermissionDenied !Text+ | BadMethod !H.Method deriving (Show, Eq, Typeable, Generic) instance NFData ErrorResponse where rnf = genericRnf@@ -328,9 +327,11 @@ ----- header stuff -- | Headers to be added to a 'Result'. data Header =- AddCookie SetCookie- | DeleteCookie ByteString ByteString- | Header ByteString ByteString+ AddCookie !SetCookie+ | DeleteCookie !ByteString !ByteString+ -- ^ name and path+ | Header !(CI ByteString) !ByteString+ -- ^ key and value deriving (Eq, Show) -- FIXME In the next major version bump, let's just add strictness annotations@@ -341,16 +342,16 @@ rnf (DeleteCookie x y) = x `seq` y `seq` () rnf (Header x y) = x `seq` y `seq` () -data Location url = Local url | Remote Text+data Location url = Local !url | Remote !Text deriving (Show, Eq) -- | A diff list that does not directly enforce uniqueness. -- When creating a widget Yesod will use nub to make it unique. newtype UniqueList x = UniqueList ([x] -> [x]) -data Script url = Script { scriptLocation :: Location url, scriptAttributes :: [(Text, Text)] }+data Script url = Script { scriptLocation :: !(Location url), scriptAttributes :: ![(Text, Text)] } deriving (Show, Eq)-data Stylesheet url = Stylesheet { styleLocation :: Location url, styleAttributes :: [(Text, Text)] }+data Stylesheet url = Stylesheet { styleLocation :: !(Location url), styleAttributes :: ![(Text, Text)] } deriving (Show, Eq) newtype Title = Title { unTitle :: Html } @@ -386,13 +387,13 @@ instance Semigroup (GWData a) data HandlerContents =- HCContent H.Status !TypedContent- | HCError ErrorResponse- | HCSendFile ContentType FilePath (Maybe FilePart)- | HCRedirect H.Status Text- | HCCreated Text- | HCWai W.Response- | HCWaiApp W.Application+ HCContent !H.Status !TypedContent+ | HCError !ErrorResponse+ | HCSendFile !ContentType !FilePath !(Maybe FilePart)+ | HCRedirect !H.Status !Text+ | HCCreated !Text+ | HCWai !W.Response+ | HCWaiApp !W.Application deriving Typeable instance Show HandlerContents where@@ -405,158 +406,78 @@ show (HCWaiApp _) = "HCWaiApp" instance Exception HandlerContents --- Instances for WidgetT-instance Monad m => Functor (WidgetT site m) where- fmap = liftM-instance Monad m => Applicative (WidgetT site m) where- pure = return+-- Instances for WidgetFor+instance Applicative (WidgetFor site) where+ pure = WidgetFor . const . pure (<*>) = ap-instance Monad m => Monad (WidgetT site m) where- return a = WidgetT $ const $ return (a, mempty)- WidgetT x >>= f = WidgetT $ \r -> do- (a, wa) <- x r- (b, wb) <- unWidgetT (f a) r- return (b, wa `mappend` wb)-instance MonadIO m => MonadIO (WidgetT site m) where- liftIO = lift . liftIO-instance MonadBase b m => MonadBase b (WidgetT site m) where- liftBase = WidgetT . const . liftBase . fmap (, mempty)-instance MonadBaseControl b m => MonadBaseControl b (WidgetT site m) where-#if MIN_VERSION_monad_control(1,0,0)- type StM (WidgetT site m) a = StM m (a, GWData (Route site))- liftBaseWith f = WidgetT $ \reader' ->- liftBaseWith $ \runInBase ->- fmap (\x -> (x, mempty))- (f $ runInBase . flip unWidgetT reader')- restoreM = WidgetT . const . restoreM-#else- data StM (WidgetT site m) a = StW (StM m (a, GWData (Route site)))- liftBaseWith f = WidgetT $ \reader' ->- liftBaseWith $ \runInBase ->- fmap (\x -> (x, mempty))- (f $ fmap StW . runInBase . flip unWidgetT reader')- restoreM (StW base) = WidgetT $ const $ restoreM base-#endif-instance Monad m => MonadReader site (WidgetT site m) where- ask = WidgetT $ \hd -> return (rheSite $ handlerEnv hd, mempty)- local f (WidgetT g) = WidgetT $ \hd -> g hd- { handlerEnv = (handlerEnv hd)- { rheSite = f $ rheSite $ handlerEnv hd- }- }--instance MonadTrans (WidgetT site) where- lift = WidgetT . const . liftM (, mempty)-instance MonadThrow m => MonadThrow (WidgetT site m) where- throwM = lift . throwM--instance MonadCatch m => MonadCatch (HandlerT site m) where- catch (HandlerT m) c = HandlerT $ \r -> m r `catch` \e -> unHandlerT (c e) r-instance MonadMask m => MonadMask (HandlerT site m) where- mask a = HandlerT $ \e -> mask $ \u -> unHandlerT (a $ q u) e- where q u (HandlerT b) = HandlerT (u . b)- uninterruptibleMask a =- HandlerT $ \e -> uninterruptibleMask $ \u -> unHandlerT (a $ q u) e- where q u (HandlerT b) = HandlerT (u . b)-instance MonadCatch m => MonadCatch (WidgetT site m) where- catch (WidgetT m) c = WidgetT $ \r -> m r `catch` \e -> unWidgetT (c e) r-instance MonadMask m => MonadMask (WidgetT site m) where- mask a = WidgetT $ \e -> mask $ \u -> unWidgetT (a $ q u) e- where q u (WidgetT b) = WidgetT (u . b)- uninterruptibleMask a =- WidgetT $ \e -> uninterruptibleMask $ \u -> unWidgetT (a $ q u) e- where q u (WidgetT b) = WidgetT (u . b)---- CPP to avoid a redundant constraints warning-#if MIN_VERSION_base(4,9,0)-instance (MonadIO m, MonadBase IO m, MonadThrow m) => MonadResource (WidgetT site m) where-#else-instance (Applicative m, MonadIO m, MonadBase IO m, MonadThrow m) => MonadResource (WidgetT site m) where-#endif- liftResourceT f = WidgetT $ \hd -> liftIO $ (, mempty) <$> runInternalState f (handlerResource hd)+instance Monad (WidgetFor site) where+ return = pure+ WidgetFor x >>= f = WidgetFor $ \wd -> do+ a <- x wd+ unWidgetFor (f a) wd+instance MonadIO (WidgetFor site) where+ liftIO = WidgetFor . const+-- | @since 1.4.38+instance MonadUnliftIO (WidgetFor site) where+ {-# INLINE askUnliftIO #-}+ askUnliftIO = WidgetFor $ \wd ->+ return (UnliftIO (flip unWidgetFor wd))+instance MonadReader (WidgetData site) (WidgetFor site) where+ ask = WidgetFor return+ local f (WidgetFor g) = WidgetFor $ g . f -instance MonadIO m => MonadLogger (WidgetT site m) where- monadLoggerLog a b c d = WidgetT $ \hd ->- liftIO $ (, mempty) <$> rheLog (handlerEnv hd) a b c (toLogStr d)+instance MonadThrow (WidgetFor site) where+ throwM = liftIO . throwM -#if MIN_VERSION_monad_logger(0, 3, 10)-instance MonadIO m => MonadLoggerIO (WidgetT site m) where- askLoggerIO = WidgetT $ \hd -> return (rheLog (handlerEnv hd), mempty)-#endif+instance MonadResource (WidgetFor site) where+ liftResourceT f = WidgetFor $ runInternalState f . handlerResource . wdHandler -instance MonadActive m => MonadActive (WidgetT site m) where- monadActive = lift monadActive-instance MonadActive m => MonadActive (HandlerT site m) where- monadActive = lift monadActive+instance MonadLogger (WidgetFor site) where+ monadLoggerLog a b c d = WidgetFor $ \wd ->+ rheLog (handlerEnv $ wdHandler wd) a b c (toLogStr d) -instance MonadTrans (HandlerT site) where- lift = HandlerT . const+instance MonadLoggerIO (WidgetFor site) where+ askLoggerIO = WidgetFor $ return . rheLog . handlerEnv . wdHandler -- Instances for HandlerT-instance Monad m => Functor (HandlerT site m) where- fmap = liftM-instance Monad m => Applicative (HandlerT site m) where- pure = return+instance Applicative (HandlerFor site) where+ pure = HandlerFor . const . return (<*>) = ap-instance Monad m => Monad (HandlerT site m) where- return = HandlerT . const . return- HandlerT x >>= f = HandlerT $ \r -> x r >>= \x' -> unHandlerT (f x') r-instance MonadIO m => MonadIO (HandlerT site m) where- liftIO = lift . liftIO-instance MonadBase b m => MonadBase b (HandlerT site m) where- liftBase = lift . liftBase-instance Monad m => MonadReader site (HandlerT site m) where- ask = HandlerT $ return . rheSite . handlerEnv- local f (HandlerT g) = HandlerT $ \hd -> g hd- { handlerEnv = (handlerEnv hd)- { rheSite = f $ rheSite $ handlerEnv hd- }- }--- | Note: although we provide a @MonadBaseControl@ instance, @lifted-base@'s--- @fork@ function is incompatible with the underlying @ResourceT@ system.--- Instead, if you must fork a separate thread, you should use--- @resourceForkIO@.------ Using fork usually leads to an exception that says--- \"Control.Monad.Trans.Resource.register\': The mutable state is being accessed--- after cleanup. Please contact the maintainers.\"-instance MonadBaseControl b m => MonadBaseControl b (HandlerT site m) where-#if MIN_VERSION_monad_control(1,0,0)- type StM (HandlerT site m) a = StM m a- liftBaseWith f = HandlerT $ \reader' ->- liftBaseWith $ \runInBase ->- f $ runInBase . (\(HandlerT r) -> r reader')- restoreM = HandlerT . const . restoreM-#else- data StM (HandlerT site m) a = StH (StM m a)- liftBaseWith f = HandlerT $ \reader' ->- liftBaseWith $ \runInBase ->- f $ fmap StH . runInBase . (\(HandlerT r) -> r reader')- restoreM (StH base) = HandlerT $ const $ restoreM base-#endif+instance Monad (HandlerFor site) where+ return = pure+ HandlerFor x >>= f = HandlerFor $ \r -> x r >>= \x' -> unHandlerFor (f x') r+instance MonadIO (HandlerFor site) where+ liftIO = HandlerFor . const+instance MonadReader (HandlerData site site) (HandlerFor site) where+ ask = HandlerFor return+ local f (HandlerFor g) = HandlerFor $ g . f -instance MonadThrow m => MonadThrow (HandlerT site m) where- throwM = lift . monadThrow+-- | @since 1.4.38+instance MonadUnliftIO (HandlerFor site) where+ {-# INLINE askUnliftIO #-}+ askUnliftIO = HandlerFor $ \r ->+ return (UnliftIO (flip unHandlerFor r)) -instance (MonadIO m, MonadBase IO m, MonadThrow m) => MonadResource (HandlerT site m) where- liftResourceT f = HandlerT $ \hd -> liftIO $ runInternalState f (handlerResource hd)+instance MonadThrow (HandlerFor site) where+ throwM = liftIO . throwM -instance MonadIO m => MonadLogger (HandlerT site m) where- monadLoggerLog a b c d = HandlerT $ \hd ->- liftIO $ rheLog (handlerEnv hd) a b c (toLogStr d)+instance MonadResource (HandlerFor site) where+ liftResourceT f = HandlerFor $ runInternalState f . handlerResource -#if MIN_VERSION_monad_logger(0, 3, 10)-instance MonadIO m => MonadLoggerIO (HandlerT site m) where- askLoggerIO = HandlerT $ \hd -> return (rheLog (handlerEnv hd))-#endif+instance MonadLogger (HandlerFor site) where+ monadLoggerLog a b c d = HandlerFor $ \hd ->+ rheLog (handlerEnv hd) a b c (toLogStr d) +instance MonadLoggerIO (HandlerFor site) where+ askLoggerIO = HandlerFor $ \hd -> return (rheLog (handlerEnv hd))+ instance Monoid (UniqueList x) where mempty = UniqueList id UniqueList x `mappend` UniqueList y = UniqueList $ x . y instance Semigroup (UniqueList x) instance IsString Content where- fromString = flip ContentBuilder Nothing . Blaze.ByteString.Builder.Char.Utf8.fromString+ fromString = flip ContentBuilder Nothing . BB.stringUtf8 instance RenderRoute WaiSubsite where data Route WaiSubsite = WaiSubsiteRoute [Text] [(Text, Text)]@@ -580,3 +501,42 @@ loggerPutStr :: Logger -> LogStr -> IO () loggerPutStr (Logger ls _) = pushLogStr ls++-- | A handler monad for subsite+--+-- @since 1.6.0+newtype SubHandlerFor sub master a = SubHandlerFor+ { unSubHandlerFor :: HandlerData sub master -> IO a+ }+ deriving Functor++instance Applicative (SubHandlerFor child master) where+ pure = SubHandlerFor . const . return+ (<*>) = ap+instance Monad (SubHandlerFor child master) where+ return = pure+ SubHandlerFor x >>= f = SubHandlerFor $ \r -> x r >>= \x' -> unSubHandlerFor (f x') r+instance MonadIO (SubHandlerFor child master) where+ liftIO = SubHandlerFor . const+instance MonadReader (HandlerData child master) (SubHandlerFor child master) where+ ask = SubHandlerFor return+ local f (SubHandlerFor g) = SubHandlerFor $ g . f++-- | @since 1.4.38+instance MonadUnliftIO (SubHandlerFor child master) where+ {-# INLINE askUnliftIO #-}+ askUnliftIO = SubHandlerFor $ \r ->+ return (UnliftIO (flip unSubHandlerFor r))++instance MonadThrow (SubHandlerFor child master) where+ throwM = liftIO . throwM++instance MonadResource (SubHandlerFor child master) where+ liftResourceT f = SubHandlerFor $ runInternalState f . handlerResource++instance MonadLogger (SubHandlerFor child master) where+ monadLoggerLog a b c d = SubHandlerFor $ \sd ->+ rheLog (handlerEnv sd) a b c (toLogStr d)++instance MonadLoggerIO (SubHandlerFor child master) where+ askLoggerIO = SubHandlerFor $ return . rheLog . handlerEnv
Yesod/Core/Unsafe.hs view
@@ -19,7 +19,10 @@ -- -- > unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger fakeHandlerGetLogger :: (Yesod site, MonadIO m)- => (site -> Logger) -> site -> HandlerT site IO a -> m a+ => (site -> Logger)+ -> site+ -> HandlerFor site a+ -> m a fakeHandlerGetLogger getLogger app f = runFakeHandler mempty getLogger app f >>= either (error . ("runFakeHandler issue: " `mappend`) . show)
Yesod/Core/Widget.hs view
@@ -14,6 +14,7 @@ module Yesod.Core.Widget ( -- * Datatype WidgetT+ , WidgetFor , PageContent (..) -- * Special Hamlet quasiquoter/TH for Widgets , whamlet@@ -43,7 +44,6 @@ , addScriptRemoteAttrs , addScriptEither -- * Subsites- , widgetToParentWidget , handlerToWidget -- * Internal , whamletFileWithSettings@@ -60,8 +60,6 @@ #if __GLASGOW_HASKELL__ < 710 import Control.Applicative ((<$>)) #endif-import Control.Monad (liftM)-import Control.Monad.IO.Class (MonadIO, liftIO) import Text.Shakespeare.I18N (RenderMessage) import Data.Text (Text) import qualified Data.Map as Map@@ -77,6 +75,9 @@ import Yesod.Core.Types import Yesod.Core.Class.Handler +type WidgetT site (m :: * -> *) = WidgetFor site+{-# DEPRECATED WidgetT "Use WidgetFor directly" #-}+ preEscapedLazyText :: TL.Text -> Html preEscapedLazyText = preEscapedToMarkup @@ -97,8 +98,8 @@ toWidget x = tell $ GWData mempty mempty mempty mempty mempty (Just x) mempty instance ToWidget site Javascript where toWidget x = tell $ GWData mempty mempty mempty mempty mempty (Just $ const x) mempty-instance (site' ~ site, IO ~ m, a ~ ()) => ToWidget site' (WidgetT site m a) where- toWidget = liftWidgetT+instance (site' ~ site, a ~ ()) => ToWidget site' (WidgetFor site a) where+ toWidget = liftWidget instance ToWidget site Html where toWidget = toWidget . const -- | @since 1.4.28@@ -268,45 +269,10 @@ return $ ih (toHtml . mrender) urender tell :: MonadWidget m => GWData (Route (HandlerSite m)) -> m ()-tell w = liftWidgetT $ WidgetT $ const $ return ((), w)+tell = liftWidget . tellWidget toUnique :: x -> UniqueList x toUnique = UniqueList . (:) -handlerToWidget :: Monad m => HandlerT site m a -> WidgetT site m a-handlerToWidget (HandlerT f) = WidgetT $ liftM (, mempty) . f--widgetToParentWidget :: MonadIO m- => WidgetT child IO a- -> HandlerT child (HandlerT parent m) (WidgetT parent m a)-widgetToParentWidget (WidgetT f) = HandlerT $ \hd -> do- (a, gwd) <- liftIO $ f hd { handlerToParent = const () }- return $ WidgetT $ const $ return (a, liftGWD (handlerToParent hd) gwd)--liftGWD :: (child -> parent) -> GWData child -> GWData parent-liftGWD tp gwd = GWData- { gwdBody = fixBody $ gwdBody gwd- , gwdTitle = gwdTitle gwd- , gwdScripts = fixUnique fixScript $ gwdScripts gwd- , gwdStylesheets = fixUnique fixStyle $ gwdStylesheets gwd- , gwdCss = fixCss <$> gwdCss gwd- , gwdJavascript = fixJS <$> gwdJavascript gwd- , gwdHead = fixHead $ gwdHead gwd- }- where- fixRender f route = f (tp route)-- fixBody (Body h) = Body $ h . fixRender- fixHead (Head h) = Head $ h . fixRender-- fixUnique go (UniqueList f) = UniqueList (map go (f []) ++)-- fixScript (Script loc attrs) = Script (fixLoc loc) attrs- fixStyle (Stylesheet loc attrs) = Stylesheet (fixLoc loc) attrs-- fixLoc (Local url) = Local $ tp url- fixLoc (Remote t) = Remote t-- fixCss f = f . fixRender-- fixJS f = f . fixRender+handlerToWidget :: HandlerFor site a -> WidgetFor site a+handlerToWidget (HandlerFor f) = WidgetFor $ f . wdHandler
Yesod/Routes/TH/ParseRoute.hs view
@@ -3,7 +3,6 @@ module Yesod.Routes.TH.ParseRoute ( -- ** ParseRoute mkParseRouteInstance- , mkParseRouteInstance' ) where import Yesod.Routes.TH.Types@@ -12,11 +11,8 @@ import Yesod.Routes.Class import Yesod.Routes.TH.Dispatch -mkParseRouteInstance :: Type -> [ResourceTree a] -> Q Dec-mkParseRouteInstance = mkParseRouteInstance' []--mkParseRouteInstance' :: Cxt -> Type -> [ResourceTree a] -> Q Dec-mkParseRouteInstance' cxt typ ress = do+mkParseRouteInstance :: Cxt -> Type -> [ResourceTree a] -> Q Dec+mkParseRouteInstance cxt typ ress = do cls <- mkDispatchClause MkDispatchSettings { mdsRunHandler = [|\_ _ x _ -> x|]
Yesod/Routes/TH/RenderRoute.hs view
@@ -2,7 +2,6 @@ module Yesod.Routes.TH.RenderRoute ( -- ** RenderRoute mkRenderRouteInstance- , mkRenderRouteInstance' , mkRouteCons , mkRenderRouteClauses ) where@@ -148,14 +147,8 @@ -- This includes both the 'Route' associated type and the -- 'renderRoute' method. This function uses both 'mkRouteCons' and -- 'mkRenderRouteClasses'.-mkRenderRouteInstance :: Type -> [ResourceTree Type] -> Q [Dec]-mkRenderRouteInstance = mkRenderRouteInstance' []---- | A more general version of 'mkRenderRouteInstance' which takes an--- additional context.--mkRenderRouteInstance' :: Cxt -> Type -> [ResourceTree Type] -> Q [Dec]-mkRenderRouteInstance' cxt typ ress = do+mkRenderRouteInstance :: Cxt -> Type -> [ResourceTree Type] -> Q [Dec]+mkRenderRouteInstance cxt typ ress = do cls <- mkRenderRouteClauses ress (cons, decs) <- mkRouteCons ress #if MIN_VERSION_template_haskell(2,12,0)
Yesod/Routes/TH/RouteAttrs.hs view
@@ -3,7 +3,6 @@ {-# LANGUAGE RecordWildCards #-} module Yesod.Routes.TH.RouteAttrs ( mkRouteAttrsInstance- , mkRouteAttrsInstance' ) where import Yesod.Routes.TH.Types@@ -15,11 +14,8 @@ import Control.Applicative ((<$>)) #endif -mkRouteAttrsInstance :: Type -> [ResourceTree a] -> Q Dec-mkRouteAttrsInstance = mkRouteAttrsInstance' []--mkRouteAttrsInstance' :: Cxt -> Type -> [ResourceTree a] -> Q Dec-mkRouteAttrsInstance' cxt typ ress = do+mkRouteAttrsInstance :: Cxt -> Type -> [ResourceTree a] -> Q Dec+mkRouteAttrsInstance cxt typ ress = do clauses <- mapM (goTree id) ress return $ instanceD cxt (ConT ''RouteAttrs `AppT` typ) [ FunD 'routeAttrs $ concat clauses
bench/widget.hs view
@@ -5,22 +5,20 @@ {-# LANGUAGE QuasiQuotes #-} module Main where -import Criterion.Main+import Gauge.Main import Text.Hamlet import qualified Data.ByteString.Lazy as L import qualified Text.Blaze.Html.Renderer.Utf8 as Utf8 import Data.Monoid (mconcat) import Text.Blaze.Html5 (table, tr, td) import Text.Blaze.Html (toHtml)-import Yesod.Core.Widget-import Yesod.Core.Types import Data.Int main :: IO () main = defaultMain [ bench "bigTable html" $ nf bigTableHtml bigTableData , bench "bigTable hamlet" $ nf bigTableHamlet bigTableData- , bench "bigTable widget" $ nfIO (bigTableWidget bigTableData)+ --, bench "bigTable widget" $ nfIO (bigTableWidget bigTableData) , bench "bigTable blaze" $ nf bigTableBlaze bigTableData ] where@@ -49,6 +47,7 @@ <td>#{show cell} |] + {- bigTableWidget :: Show a => [[a]] -> IO Int64 bigTableWidget rows = fmap (L.length . Utf8.renderHtml . ($ render)) (run [whamlet| <table>@@ -62,6 +61,7 @@ run (WidgetT w) = do (_, GWData { gwdBody = Body x }) <- w undefined return x+ -} bigTableBlaze :: Show a => [[a]] -> Int64 bigTableBlaze t = L.length $ Utf8.renderHtml $ table $ Data.Monoid.mconcat $ map row t
test/Hierarchy.hs view
@@ -113,9 +113,9 @@ -- /#Int TrailingIntR GET |] - rrinst <- mkRenderRouteInstance (ConT ''Hierarchy) $ map (fmap parseType) resources- rainst <- mkRouteAttrsInstance (ConT ''Hierarchy) $ map (fmap parseType) resources- prinst <- mkParseRouteInstance (ConT ''Hierarchy) $ map (fmap parseType) resources+ rrinst <- mkRenderRouteInstance [] (ConT ''Hierarchy) $ map (fmap parseType) resources+ rainst <- mkRouteAttrsInstance [] (ConT ''Hierarchy) $ map (fmap parseType) resources+ prinst <- mkParseRouteInstance [] (ConT ''Hierarchy) $ map (fmap parseType) resources dispatch <- mkDispatchClause MkDispatchSettings { mdsRunHandler = [|runHandler|] , mdsSubDispatcher = [|subDispatch|]
test/RouteSpec.hs view
@@ -30,11 +30,7 @@ data MySub = MySub instance RenderRoute MySub where data-#if MIN_VERSION_base(4,5,0) Route-#else- YRC.Route-#endif MySub = MySubRoute ([Text], [(Text, Text)]) deriving (Show, Eq, Read) renderRoute (MySubRoute x) = x@@ -47,11 +43,7 @@ data MySubParam = MySubParam Int instance RenderRoute MySubParam where data-#if MIN_VERSION_base(4,5,0) Route-#else- YRC.Route-#endif MySubParam = ParamRoute Char deriving (Show, Eq, Read) renderRoute (ParamRoute x) = ([singleton x], [])@@ -80,9 +72,9 @@ [ ResourceLeaf $ Resource "ChildR" [] (Methods Nothing ["GET"]) ["child"] True ] ress = resParent : resLeaves- rrinst <- mkRenderRouteInstance (ConT ''MyApp) ress- rainst <- mkRouteAttrsInstance (ConT ''MyApp) ress- prinst <- mkParseRouteInstance (ConT ''MyApp) ress+ rrinst <- mkRenderRouteInstance [] (ConT ''MyApp) ress+ rainst <- mkRouteAttrsInstance [] (ConT ''MyApp) ress+ prinst <- mkParseRouteInstance [] (ConT ''MyApp) ress dispatch <- mkDispatchClause MkDispatchSettings { mdsRunHandler = [|runHandler|] , mdsSubDispatcher = [|subDispatch dispatcher|]
test/YesodCoreTest/Cache.hs view
@@ -15,7 +15,7 @@ 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
test/YesodCoreTest/CleanPath.hs view
@@ -22,7 +22,7 @@ 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 @@ 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'
test/YesodCoreTest/ErrorHandling.hs view
@@ -14,11 +14,13 @@ 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 = 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 @@ 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)
test/YesodCoreTest/InternalRequest.hs view
@@ -10,10 +10,12 @@ import Yesod.Core import Data.Word (Word64) import System.IO.Unsafe (unsafePerformIO)-import qualified System.Random.MWC as MWC-import Control.Monad.ST import Control.Monad (replicateM)+import System.Random +gen :: IO Int+gen = getStdRandom next+ randomStringSpecs :: Spec randomStringSpecs = describe "Yesod.Internal.Request.randomString" $ do --it "looks reasonably random" looksRandom@@ -21,21 +23,19 @@ -- NOTE: this testcase may break on other systems/architectures if -- mkStdGen is not identical everywhere (is it?).-_looksRandom :: Bool-_looksRandom = runST $ do- gen <- MWC.create+_looksRandom :: IO ()+_looksRandom = do s <- randomString 20 gen- return $ s == "VH9SkhtptqPs6GqtofVg"+ s `shouldBe` "VH9SkhtptqPs6GqtofVg" -noRepeat :: Int -> Int -> Bool-noRepeat len n = runST $ do- gen <- MWC.create+noRepeat :: Int -> Int -> IO ()+noRepeat len n = do ss <- replicateM n $ randomString len gen- return $ length (nub ss) == n+ length (nub ss) `shouldBe` n -- For convenience instead of "(undefined :: StdGen)".-g :: MWC.GenIO+g :: IO Int g = error "test/YesodCoreTest/InternalRequest.g" parseWaiRequest' :: Request
test/YesodCoreTest/Links.hs view
@@ -13,7 +13,7 @@ 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 @@ 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"
test/YesodCoreTest/NoOverloadedStrings.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances, ViewPatterns #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -- the module name is a lie!!! module YesodCoreTest.NoOverloadedStrings ( noOverloadedTest@@ -20,19 +21,19 @@ getSubsite :: a -> Subsite getSubsite _ = Subsite $(mkYesodSubDispatch resourcesSubsite) -getBarR :: Monad m => m T.Text+getBarR :: MonadHandler m => m T.Text getBarR = return $ T.pack "BarR" -getBazR :: Yesod master => HandlerT Subsite (HandlerT master IO) Html-getBazR = lift $ defaultLayout [whamlet|Used Default Layout|]+getBazR :: (MonadHandler m, Yesod (HandlerSite m)) => m Html+getBazR = liftHandler $ defaultLayout [whamlet|Used Default Layout|] -getBinR :: Yesod master => HandlerT Subsite (HandlerT master IO) Html+getBinR :: (MonadHandler m, Yesod (HandlerSite m), SubHandlerSite m ~ Subsite) => m Html getBinR = do- widget <- widgetToParentWidget [whamlet|+ routeToParent <- getRouteToParent+ liftHandler $ defaultLayout [whamlet| <p>Used defaultLayoutT- <a href=@{BazR}>Baz+ <a href=@{routeToParent BazR}>Baz |]- lift $ defaultLayout widget getOnePiecesR :: Monad m => Int -> m () getOnePiecesR _ = return ()
test/YesodCoreTest/NoOverloadedStringsSub.hs view
@@ -10,7 +10,7 @@ import Yesod.Core import Yesod.Core.Types -data Subsite = Subsite (forall master. Yesod master => YesodSubRunnerEnv Subsite master (HandlerT master IO) -> Application)+data Subsite = Subsite (forall master. Yesod master => YesodSubRunnerEnv Subsite master -> Application) mkYesodSubData "Subsite" [parseRoutes| /bar BarR GET@@ -21,7 +21,7 @@ /has-three-pieces/#Int/#Int/#Int ThreePiecesR GET |] -instance Yesod master => YesodSubDispatch Subsite (HandlerT master IO) where+instance Yesod master => YesodSubDispatch Subsite master where yesodSubDispatch ysre = f ysre where
test/YesodCoreTest/RawResponse.hs view
@@ -22,7 +22,6 @@ import Data.IORef import Data.Streaming.Network (bindPortTCP) import Network.HTTP.Types (status200)-import Blaze.ByteString.Builder (fromByteString) mkYesod "App" [parseRoutes| / HomeR GET@@ -40,22 +39,22 @@ _ <- register $ writeIORef ref 1 sendRawResponse $ \src sink -> liftIO $ do val <- readIORef ref- yield (S8.pack $ show val) $$ sink- src $$ CL.map (S8.map toUpper) =$ sink+ runConduit $ yield (S8.pack $ show val) .| sink+ runConduit $ src .| CL.map (S8.map toUpper) .| sink getWaiStreamR :: Handler () getWaiStreamR = sendWaiResponse $ responseStream status200 [] $ \send flush -> do flush- send $ fromByteString "hello"+ send "hello" flush- send $ fromByteString " world"+ send " world" getWaiAppStreamR :: Handler () getWaiAppStreamR = sendWaiApplication $ \_ f -> f $ responseStream status200 [] $ \send flush -> do flush- send $ fromByteString "hello"+ send "hello" flush- send $ fromByteString " world"+ send " world" getFreePort :: IO Int getFreePort = do@@ -77,18 +76,18 @@ withAsync (warp port App) $ \_ -> do threadDelay 100000 runTCPClient (clientSettings port "127.0.0.1") $ \ad -> do- yield "GET / HTTP/1.1\r\n\r\nhello" $$ appSink ad- (appSource ad $$ CB.take 6) >>= (`shouldBe` "0HELLO")- yield "WORLd" $$ appSink ad- (appSource ad $$ await) >>= (`shouldBe` Just "WORLD")+ runConduit $ yield "GET / HTTP/1.1\r\n\r\nhello" .| appSink ad+ runConduit (appSource ad .| CB.take 6) >>= (`shouldBe` "0HELLO")+ runConduit $ yield "WORLd" .| appSink ad+ runConduit (appSource ad .| await) >>= (`shouldBe` Just "WORLD") let body req = do port <- getFreePort withAsync (warp port App) $ \_ -> do threadDelay 100000 runTCPClient (clientSettings port "127.0.0.1") $ \ad -> do- yield req $$ appSink ad- appSource ad $$ CB.lines =$ do+ runConduit $ yield req .| appSink ad+ runConduit $ appSource ad .| CB.lines .| do let loop = do x <- await case x of
test/YesodCoreTest/RequestBodySize.hs view
@@ -42,11 +42,11 @@ return $ RepPlain $ toContent $ T.concat val postConsumeR = do- body <- rawRequestBody $$ consume+ body <- runConduit $ rawRequestBody .| consume return $ RepPlain $ toContent $ S.concat body postPartialConsumeR = do- body <- rawRequestBody $$ isolate 5 =$ consume+ body <- runConduit $ rawRequestBody .| isolate 5 .| consume return $ RepPlain $ toContent $ S.concat body postUnusedR = return $ RepPlain ""
yesod-core.cabal view
@@ -1,5 +1,5 @@ name: yesod-core-version: 1.4.37.3+version: 1.6.0 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -21,17 +21,16 @@ README.md library- build-depends: base >= 4.7 && < 5- , time >= 1.1.4+ build-depends: base >= 4.9 && < 5+ , time >= 1.5 , wai >= 3.0 , wai-extra >= 3.0.7- , bytestring >= 0.10+ , bytestring >= 0.10.2 , text >= 0.7 , template-haskell , path-pieces >= 0.1.2 && < 0.3 , shakespeare >= 2.0- , blaze-builder >= 0.2.1.4 && < 0.5- , transformers >= 0.2.2+ , transformers >= 0.4 , mtl , clientsession >= 0.9.1 && < 0.10 , random >= 1.0.0.2 && < 1.2@@ -39,37 +38,32 @@ , old-locale >= 1.0.0.2 && < 1.1 , containers >= 0.2 , unordered-containers >= 0.2- , monad-control >= 0.3 && < 1.1- , transformers-base >= 0.4- , cookie >= 0.4.2 && < 0.5+ , cookie >= 0.4.3 && < 0.5 , http-types >= 0.7 , case-insensitive >= 0.2 , parsec >= 2 && < 3.2 , directory >= 1 , vector >= 0.9 && < 0.13- , aeson >= 0.5+ , aeson >= 1.0 , fast-logger >= 2.2 , wai-logger >= 0.2- , monad-logger >= 0.3.1 && < 0.4- , conduit >= 1.2- , resourcet >= 0.4.9 && < 1.2- , lifted-base >= 0.1.2+ , monad-logger >= 0.3.10 && < 0.4+ , conduit >= 1.3+ , resourcet >= 1.2 , blaze-html >= 0.5 , blaze-markup >= 0.7.1- , data-default , safe , warp >= 3.0.2 , unix-compat , conduit-extra- , exceptions >= 0.6 , deepseq >= 1.3 , deepseq-generics- , mwc-random , primitive , word8 , auto-update , semigroups , byteable+ , unliftio exposed-modules: Yesod.Core Yesod.Core.Content@@ -189,13 +183,11 @@ ,text ,http-types , random- , blaze-builder ,HUnit ,QuickCheck >= 2 && < 3 ,transformers , conduit , containers- , lifted-base , resourcet , network , async@@ -203,8 +195,8 @@ , shakespeare , streaming-commons , wai-extra- , mwc-random , cookie >= 0.4.1 && < 0.5+ , unliftio ghc-options: -Wall extensions: TemplateHaskell @@ -212,7 +204,7 @@ type: exitcode-stdio-1.0 hs-source-dirs: bench build-depends: base- , criterion+ , gauge , bytestring , text , transformers