yesod-core 1.4.22 → 1.4.23

raw patch · 31 files changed

+284/−177 lines, 31 filesdep ~cookiePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: cookie

API changes (from Hackage documentation)

Files

• ChangeLog.md +5/−0
• Yesod/Core.hs +3/−3
• Yesod/Core/Class/Dispatch.hs +2/−4
• Yesod/Core/Class/Yesod.hs +101/−35
• Yesod/Core/Content.hs +1/−2
• Yesod/Core/Dispatch.hs +5/−5
• Yesod/Core/Handler.hs +38/−46
• Yesod/Core/Internal/Request.hs +6/−7
• Yesod/Core/Internal/Response.hs +8/−13
• Yesod/Core/Internal/Run.hs +4/−3
• Yesod/Core/Internal/Session.hs +2/−4
• Yesod/Core/Internal/TH.hs +9/−6
• Yesod/Core/Internal/Util.hs +1/−3
• Yesod/Core/Types.hs +9/−10
• Yesod/Core/Widget.hs +12/−9
• Yesod/Routes/TH.hs +0/−1
• Yesod/Routes/TH/RenderRoute.hs +3/−3
• Yesod/Routes/TH/RouteAttrs.hs +6/−3
• Yesod/Routes/TH/Types.hs +2/−2
• test/YesodCoreTest.hs +2/−1
• test/YesodCoreTest/Cache.hs +0/−2
• test/YesodCoreTest/ErrorHandling.hs +2/−2
• test/YesodCoreTest/InternalRequest.hs +0/−3
• test/YesodCoreTest/Links.hs +0/−1
• test/YesodCoreTest/Media.hs +0/−1
• test/YesodCoreTest/NoOverloadedStringsSub.hs +0/−1
• test/YesodCoreTest/Ssl.hs +15/−1
• test/YesodCoreTest/StubLaxSameSite.hs +23/−0
• test/YesodCoreTest/StubStrictSameSite.hs +23/−0
• test/YesodCoreTest/Widget.hs +0/−4
• yesod-core.cabal +2/−2

@@ -1,3 +1,8 @@+## 1.4.23++* urlParamRenderOverride method for Yesod class [#1257](https://github.com/yesodweb/yesod/pull/1257)+* Add laxSameSiteSessions and strictSameSiteSessions [#1226](https://github.com/yesodweb/yesod/pull/1226)+ ## 1.4.22  * Proper handling of impure exceptions within `HandlerError` values

@@ -1,4 +1,3 @@-{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-}@@ -53,6 +52,8 @@     , envClientSessionBackend     , clientSessionBackend     , sslOnlySessions+    , laxSameSiteSessions+    , strictSameSiteSessions     , sslOnlyMiddleware     , clientSessionDateCacher     , loadClientSession@@ -134,11 +135,10 @@ import Control.Monad.Logger import Control.Monad.Trans.Class (MonadTrans (..)) import Yesod.Core.Internal.Session-import Yesod.Core.Internal.Run (yesodRunner)+import Yesod.Core.Internal.Run (yesodRunner, yesodRender) import Yesod.Core.Class.Yesod import Yesod.Core.Class.Dispatch import Yesod.Core.Class.Breadcrumbs-import Yesod.Core.Internal.Run (yesodRender) import qualified Yesod.Core.Internal.Run import qualified Paths_yesod_core import Data.Version (showVersion)

@@ -1,7 +1,6 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts  #-}@@ -25,10 +24,9 @@                      -> W.Application  instance YesodSubDispatch WaiSubsite master where-    yesodSubDispatch YesodSubRunnerEnv {..} req =-        app req+    yesodSubDispatch YesodSubRunnerEnv {..} = app       where-        WaiSubsite app = ysreGetSub $ yreSite $ ysreParentEnv+        WaiSubsite app = ysreGetSub $ yreSite ysreParentEnv  -- | A helper function for creating YesodSubDispatch instances, used by the -- internal generated code. This function has been exported since 1.4.11.

@@ -5,26 +5,28 @@ {-# LANGUAGE CPP               #-} module Yesod.Core.Class.Yesod where -import           Control.Monad.Logger               (logErrorS) import           Yesod.Core.Content import           Yesod.Core.Handler  import           Yesod.Routes.Class -import           Blaze.ByteString.Builder           (Builder)-import           Blaze.ByteString.Builder.Char.Utf8 (fromText)+import           Blaze.ByteString.Builder           (Builder, toByteString)+import           Blaze.ByteString.Builder.ByteString (copyByteString)+import           Blaze.ByteString.Builder.Char.Utf8 (fromText, fromChar) import           Control.Arrow                      ((***), second) import           Control.Exception                  (bracket)+#if __GLASGOW_HASKELL__ < 710+import           Control.Applicative                ((<$>))+#endif import           Control.Monad                      (forM, when, void) import           Control.Monad.IO.Class             (MonadIO (liftIO)) import           Control.Monad.Logger               (LogLevel (LevelInfo, LevelOther),-                                                     LogSource)+                                                     LogSource, logErrorS) import           Control.Monad.Trans.Resource       (InternalState, createInternalState, closeInternalState) import qualified Data.ByteString.Char8              as S8 import qualified Data.ByteString.Lazy               as L import Data.Aeson (object, (.=))-import           Data.List                          (foldl')-import           Data.List                          (nub)+import           Data.List                          (foldl', nub) import qualified Data.Map                           as Map import           Data.Monoid import           Data.Text                          (Text)@@ -35,7 +37,7 @@ import           Data.Text.Lazy.Encoding            (encodeUtf8) import           Data.Word                          (Word64) import           Language.Haskell.TH.Syntax         (Loc (..))-import           Network.HTTP.Types                 (encodePath)+import           Network.HTTP.Types                 (encodePath, renderQueryText) import qualified Network.Wai                        as W import           Data.Default                       (def) import           Network.Wai.Parse                  (lbsBackEnd,@@ -43,14 +45,14 @@ import           Network.Wai.Logger                 (ZonedDate, clockDateCacher) import           System.Log.FastLogger import           Text.Blaze                         (customAttribute, textTag,-                                                     toValue, (!))-import           Text.Blaze                         (preEscapedToMarkup)+                                                     toValue, (!),+                                                     preEscapedToMarkup) import qualified Text.Blaze.Html5                   as TBH import           Text.Hamlet import           Text.Julius import qualified Web.ClientSession                  as CS-import           Web.Cookie                         (parseCookies)-import           Web.Cookie                         (SetCookie (..))+import           Web.Cookie                         (SetCookie (..), parseCookies, sameSiteLax,+                                                     sameSiteStrict, SameSiteOption) import           Yesod.Core.Types import           Yesod.Core.Internal.Session import           Yesod.Core.Widget@@ -107,6 +109,28 @@     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+     -- | Determine if a request is authorized or not.     --     -- Return 'Authorized' if the request is authorized,@@ -237,7 +261,7 @@     --     -- Default: Uses clientsession with a 2 hour timeout.     makeSessionBackend :: site -> IO (Maybe SessionBackend)-    makeSessionBackend _ = fmap Just $ defaultClientSessionBackend 120 CS.defaultKeyFile+    makeSessionBackend _ = Just <$> defaultClientSessionBackend 120 CS.defaultKeyFile      -- | How to store uploaded files.     --@@ -290,6 +314,7 @@     yesodWithInternalState :: site -> Maybe (Route site) -> (InternalState -> IO a) -> IO a     yesodWithInternalState _ _ = bracket createInternalState closeInternalState     {-# INLINE yesodWithInternalState #-}+{-# DEPRECATED urlRenderOverride "Use urlParamRenderOverride instead" #-}  -- | Default implementation of 'makeLogger'. Sends to stdout and -- automatically flushes on each write.@@ -362,6 +387,34 @@     setSecureBit cookie = cookie { setCookieSecure = True }     secureSessionCookies = customizeSessionCookies setSecureBit +-- | Helps defend against CSRF attacks by setting the SameSite attribute on+-- session cookies to Lax. With the Lax setting, the cookie will be sent with same-site+-- requests, and with cross-site top-level navigations.+--+-- This option is liable to change in future versions of Yesod as the spec evolves.+-- View more information <https://datatracker.ietf.org/doc/draft-west-first-party-cookies/ here>.+--+-- @since 1.4.23+laxSameSiteSessions :: IO (Maybe SessionBackend) -> IO (Maybe SessionBackend)+laxSameSiteSessions = sameSiteSession sameSiteLax++-- | Helps defend against CSRF attacks by setting the SameSite attribute on+-- session cookies to Strict. With the Strict setting, the cookie will only be+-- sent with same-site requests.+--+-- This option is liable to change in future versions of Yesod as the spec evolves.+-- View more information <https://datatracker.ietf.org/doc/draft-west-first-party-cookies/ here>.+--+-- @since 1.4.23+strictSameSiteSessions :: IO (Maybe SessionBackend) -> IO (Maybe SessionBackend)+strictSameSiteSessions = sameSiteSession sameSiteStrict++sameSiteSession :: SameSiteOption -> IO (Maybe SessionBackend) -> IO (Maybe SessionBackend)+sameSiteSession s = (fmap . fmap) secureSessionCookies+  where+    sameSite cookie = cookie { setCookieSameSite = Just s }+    secureSessionCookies = customizeSessionCookies sameSite+ -- | Apply a Strict-Transport-Security header with the specified timeout to -- all responses so that browsers will rewrite all http links to https -- until the timeout expires. For security, the max-age of the STS header@@ -388,8 +441,7 @@ -- -- Since 1.2.0 authorizationCheck :: Yesod site => HandlerT site IO ()-authorizationCheck = do-    getCurrentRoute >>= maybe (return ()) checkUrl+authorizationCheck = getCurrentRoute >>= maybe (return ()) checkUrl   where     checkUrl url = do         isWrite <- isWriteRequest url@@ -399,21 +451,21 @@             AuthenticationRequired -> do                 master <- getYesod                 case authRoute master of-                    Nothing -> void $ notAuthenticated-                    Just url' -> do+                    Nothing -> void notAuthenticated+                    Just url' ->                       void $ selectRep $ do                           provideRepType typeHtml $ do                               setUltDestCurrent                               void $ redirect url'                           provideRepType typeJson $-                              void $ notAuthenticated+                              void notAuthenticated             Unauthorized s' -> permissionDenied s'  -- | 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 handler = do+defaultCsrfCheckMiddleware handler =     csrfCheckMiddleware         handler         (getCurrentRoute >>= maybe (return False) isWriteRequest)@@ -455,6 +507,18 @@ -- -- For details, see the "AJAX CSRF protection" section of "Yesod.Core.Handler". --+-- You can add this chain this middleware together with other middleware like so:+--+-- @+-- 'yesodMiddleware' = 'defaultYesodMiddleware' . 'defaultCsrfMiddleware'+-- @+--+-- or:+--+-- @+-- 'yesodMiddleware' app = 'defaultYesodMiddleware' $ 'defaultCsrfMiddleware' $ app+-- @+-- -- Since 1.4.14 defaultCsrfMiddleware :: Yesod site => HandlerT site IO res -> HandlerT site IO res defaultCsrfMiddleware = defaultCsrfSetCookieMiddleware . defaultCsrfCheckMiddleware@@ -592,12 +656,9 @@         -- The client will just use the authentication_url in the JSON         site <- getYesod         rend <- getUrlRender-        return $ object $ [-          "message" .= ("Not logged in"::Text)-          ] ++-          case authRoute site of-              Nothing -> []-              Just url -> ["authentication_url" .= rend url]+        let apair u = ["authentication_url" .= rend u]+            content = maybe [] apair (authRoute site)+        return $ object $ ("message" .= ("Not logged in"::Text)):content  defaultErrorHandler (PermissionDenied msg) = selectRep $ do     provideRep $ defaultLayout $ do@@ -607,9 +668,7 @@             <p>#{msg}         |]     provideRep $-        return $ object $ [-          "message" .= ("Permission Denied. " <> msg)-          ]+        return $ object ["message" .= ("Permission Denied. " <> msg)]  defaultErrorHandler (InvalidArgs ia) = selectRep $ do     provideRep $ defaultLayout $ do@@ -641,8 +700,8 @@     provideRep $ return $ object ["message" .= ("Bad method" :: Text), "method" .= TE.decodeUtf8With TEE.lenientDecode m]  asyncHelper :: (url -> [x] -> Text)-         -> [Script (url)]-         -> Maybe (JavascriptUrl (url))+         -> [Script url]+         -> Maybe (JavascriptUrl url)          -> Maybe Text          -> (Maybe (HtmlUrl url), [Text]) asyncHelper render scripts jscript jsLoc =@@ -732,8 +791,7 @@                             -> IO SessionBackend defaultClientSessionBackend minutes fp = do   key <- CS.getKey fp-  let timeout = fromIntegral (minutes * 60)-  (getCachedDate, _closeDateCacher) <- clientSessionDateCacher timeout+  (getCachedDate, _closeDateCacher) <- clientSessionDateCacher (minToSec minutes)   return $ clientSessionBackend key getCachedDate  -- | Create a @SessionBackend@ which reads the session key from the named@@ -759,10 +817,12 @@                         -> IO SessionBackend envClientSessionBackend minutes name = do     key <- CS.getKeyEnv name-    let timeout = fromIntegral (minutes * 60)-    (getCachedDate, _closeDateCacher) <- clientSessionDateCacher timeout+    (getCachedDate, _closeDateCacher) <- clientSessionDateCacher $ minToSec minutes     return $ clientSessionBackend key getCachedDate +minToSec :: (Integral a, Num b) => a -> b+minToSec minutes = fromIntegral (minutes * 60)+ jsToHtml :: Javascript -> Html jsToHtml (Javascript b) = preEscapedToMarkup $ toLazyText b @@ -818,8 +878,14 @@ -- turn the TH Loc loaction information into a human readable string -- leaving out the loc_end parameter fileLocationToString :: Loc -> String-fileLocationToString loc = (loc_package loc) ++ ':' : (loc_module loc) ++-  ' ' : (loc_filename loc) ++ ':' : (line loc) ++ ':' : (char loc)+fileLocationToString loc =+    concat+      [ loc_package loc+      , ':' : loc_module loc+      , ' ' : loc_filename loc+      , ':' : line loc+      , ':' : char loc+      ]   where     line = show . fst . loc_start     char = show . snd . loc_start

@@ -53,8 +53,6 @@ import qualified Data.ByteString.Lazy as L import Data.Text.Lazy (Text, pack) import qualified Data.Text as T-import Control.Monad (liftM)- import Blaze.ByteString.Builder (Builder, fromByteString, fromLazyByteString) #if __GLASGOW_HASKELL__ < 710 import Data.Monoid (mempty)@@ -62,6 +60,7 @@ import Text.Hamlet (Html) import Text.Blaze.Html.Renderer.Utf8 (renderHtmlBuilder) import Data.Conduit (Source, Flush (Chunk), ResumableSource, mapOutput)+import Control.Monad (liftM) import Control.Monad.Trans.Resource (ResourceT) import Data.Conduit.Internal (ResumableSource (ResumableSource)) import qualified Data.Conduit.Internal as CI

@@ -85,7 +85,7 @@     sb <- makeSessionBackend site     gen <- MWC.createSystemRandom     getMaxExpires <- getGetMaxExpires-    return $ toWaiAppYre $ YesodRunnerEnv+    return $ toWaiAppYre YesodRunnerEnv             { yreLogger = logger             , yreSite = site             , yreSessionBackend = sb@@ -119,8 +119,8 @@         dest' =             if S.null (W.rawQueryString env)                 then dest-                else (dest `mappend`-                     Blaze.ByteString.Builder.fromByteString (W.rawQueryString env))+                else dest `mappend`+                     Blaze.ByteString.Builder.fromByteString (W.rawQueryString env)  -- | Same as 'toWaiAppPlain', but provides a default set of middlewares. This -- set may change with future releases, but currently covers:@@ -184,7 +184,7 @@                     $(qLocation >>= liftLoc)                     "yesod-core"                     LevelError-                    (toLogStr $ "Exception from Warp: " ++ show e)) $+                    (toLogStr $ "Exception from Warp: " ++ show e))         Network.Wai.Handler.Warp.defaultSettings)   where     shouldLog' = Network.Wai.Handler.Warp.defaultShouldDisplayException@@ -231,7 +231,7 @@ warpEnv site = do     env <- getEnvironment     case lookup "PORT" env of-        Nothing -> error $ "warpEnv: no PORT environment variable found"+        Nothing -> error "warpEnv: no PORT environment variable found"         Just portS ->             case readMay portS of                 Nothing -> error $ "warpEnv: invalid PORT environment variable: " ++ show portS

@@ -189,10 +189,10 @@ import           Data.Monoid                   (mempty, mappend) #endif import           Control.Applicative           ((<|>))-import           Control.Exception             (evaluate, SomeException)+import           Control.Exception             (evaluate, SomeException, throwIO) import           Control.Exception.Lifted      (handle) -import           Control.Monad                 (liftM, void)+import           Control.Monad                 (void, liftM, unless) import qualified Control.Monad.Trans.Writer    as Writer  import           Control.Monad.IO.Class        (MonadIO, liftIO)@@ -235,24 +235,19 @@ import           Yesod.Core.Class.Handler import           Yesod.Core.Types import           Yesod.Routes.Class            (Route)-import Control.Exception (throwIO)-import Blaze.ByteString.Builder (Builder)-import Safe (headMay)-import Data.CaseInsensitive (CI)+import           Blaze.ByteString.Builder (Builder)+import           Safe (headMay)+import           Data.CaseInsensitive (CI) import qualified Data.Conduit.List as CL-import Control.Monad (unless)-import           Control.Monad.Trans.Resource  (MonadResource, InternalState, runResourceT, withInternalState, getInternalState, liftResourceT, resourceForkIO-              )+import           Control.Monad.Trans.Resource  (MonadResource, InternalState, runResourceT, withInternalState, getInternalState, liftResourceT, resourceForkIO) import qualified System.PosixCompat.Files as PC-import Control.Monad.Trans.Control (control, MonadBaseControl)-import Data.Conduit (Source, transPipe, Flush (Flush), yield, Producer-                    , Sink-                   )+import           Control.Monad.Trans.Control (control, MonadBaseControl)+import           Data.Conduit (Source, transPipe, Flush (Flush), yield, Producer, Sink) 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)+import           Data.Default+import           Control.Monad.Logger (MonadLogger, logWarnS)  get :: MonadHandler m => m GHState get = liftHandlerT $ HandlerT $ I.readIORef . handlerState@@ -305,7 +300,7 @@           -> W.Request           -> IO ([(Text, Text)], [(Text, FileInfo)]) rbHelper' backend mkFI req =-    (map fix1 *** mapMaybe fix2) <$> (NWP.parseRequestBody backend req)+    (map fix1 *** mapMaybe fix2) <$> NWP.parseRequestBody backend req   where     fix1 = go *** go     fix2 (x, NWP.FileInfo a' b c)@@ -324,29 +319,29 @@  -- | Get the master site application argument. getYesod :: MonadHandler m => m (HandlerSite m)-getYesod = rheSite `liftM` askHandlerEnv+getYesod = rheSite <$> askHandlerEnv  -- | Get a specific component of the master site application argument. --   Analogous to the 'gets' function for operating on 'StateT'. getsYesod :: MonadHandler m => (HandlerSite m -> a) -> m a-getsYesod f = (f . rheSite) `liftM` askHandlerEnv+getsYesod f = (f . rheSite) <$> askHandlerEnv  -- | Get the URL rendering function. getUrlRender :: MonadHandler m => m (Route (HandlerSite m) -> Text) getUrlRender = do-    x <- rheRender `liftM` askHandlerEnv+    x <- rheRender <$> askHandlerEnv     return $ flip x []  -- | The URL rendering function with query-string parameters. getUrlRenderParams     :: MonadHandler m     => m (Route (HandlerSite m) -> [(Text, Text)] -> Text)-getUrlRenderParams = rheRender `liftM` askHandlerEnv+getUrlRenderParams = rheRender <$> askHandlerEnv  -- | Get the route requested by the user. If this is a 404 response- where the -- user requested an invalid route- this function will return 'Nothing'. getCurrentRoute :: MonadHandler m => m (Maybe (Route (HandlerSite m)))-getCurrentRoute = rheRoute `liftM` askHandlerEnv+getCurrentRoute = rheRoute <$> askHandlerEnv  -- | Returns a function that runs 'HandlerT' actions inside @IO@. --@@ -487,7 +482,7 @@     case route of         Nothing -> return ()         Just r -> do-            gets' <- reqGetParams `liftM` getRequest+            gets' <- reqGetParams <$> getRequest             setUltDest (r, gets')  -- | Sets the ultimate destination to the referer request header, if present.@@ -541,7 +536,7 @@     addMsg = maybe msg' (S.append msg' . S.cons W8._nul)     msg' = S.append         (encodeUtf8 status)-        (W8._nul `S.cons` (L.toStrict $ renderHtml msg))+        (W8._nul `S.cons` L.toStrict (renderHtml msg))  -- | Adds a message in the user's session but uses RenderMessage to allow for i18n --@@ -568,7 +563,7 @@   where     enlist = pairup . S.split W8._nul     pairup [] = []-    pairup [x] = []+    pairup [_] = []     pairup (s:v:xs) = (decode s, preEscapedToHtml (decode v)) : pairup xs     decode = decodeUtf8With lenientDecode @@ -584,7 +579,7 @@ -- | Gets just the last message in the user's session, -- discards the rest and the status getMessage :: MonadHandler m => m (Maybe Html)-getMessage = (return . fmap snd . headMay) =<< getMessages+getMessage = fmap (fmap snd . headMay) getMessages  -- | Bypass remaining handler code and output the given file. --@@ -657,7 +652,7 @@     -> m a sendRawResponseNoConduit raw = control $ \runInIO ->     liftIO $ throwIO $ HCWai $ flip W.responseRaw fallback-    $ \src sink -> runInIO (raw src sink) >> return ()+    $ \src sink -> void $ runInIO (raw src sink)   where     fallback = W.responseLBS H.status500 [("Content-Type", "text/plain")]         "sendRawResponse: backend does not support raw responses"@@ -672,7 +667,7 @@                 -> m a sendRawResponse raw = control $ \runInIO ->     liftIO $ throwIO $ HCWai $ flip W.responseRaw fallback-    $ \src sink -> runInIO (raw (src' src) (CL.mapM_ sink)) >> return ()+    $ \src sink -> void $ runInIO $ raw (src' src) (CL.mapM_ sink)   where     fallback = W.responseLBS H.status500 [("Content-Type", "text/plain")]         "sendRawResponse: backend does not support raw responses"@@ -901,17 +896,17 @@  -- | Lookup for session data. lookupSession :: MonadHandler m => Text -> m (Maybe Text)-lookupSession = (liftM . fmap) (decodeUtf8With lenientDecode) . lookupSessionBS+lookupSession = (fmap . fmap) (decodeUtf8With lenientDecode) . lookupSessionBS  -- | Lookup for session data in binary format. lookupSessionBS :: MonadHandler m => Text -> m (Maybe S.ByteString) lookupSessionBS n = do-    m <- liftM ghsSession get+    m <- fmap ghsSession get     return $ Map.lookup n m  -- | Get all session variables. getSession :: MonadHandler m => m SessionMap-getSession = liftM ghsSession get+getSession = fmap ghsSession get  -- | Get a unique identifier. newIdent :: MonadHandler m => m Text@@ -976,13 +971,13 @@  -- | Get the request\'s 'W.Request' value. waiRequest :: MonadHandler m => m W.Request-waiRequest = reqWaiRequest `liftM` getRequest+waiRequest = reqWaiRequest <$> getRequest  getMessageRender :: (MonadHandler m, RenderMessage (HandlerSite m) message)                  => m (message -> Text) getMessageRender = do     env <- askHandlerEnv-    l <- reqLangs `liftM` getRequest+    l <- reqLangs <$> getRequest     return $ renderMessage (rheSite env) l  -- | Use a per-request cache to avoid performing the same action multiple times.@@ -1045,7 +1040,7 @@ -- -- This is handled by parseWaiRequest (not exposed). languages :: MonadHandler m => m [Text]-languages = reqLangs `liftM` getRequest+languages = reqLangs <$> getRequest  lookup' :: Eq a => a -> [(a, b)] -> [b] lookup' a = map snd . filter (\x -> a == fst x)@@ -1054,7 +1049,7 @@ -- -- Since 1.2.2 lookupHeader :: MonadHandler m => CI S8.ByteString -> m (Maybe S8.ByteString)-lookupHeader = liftM listToMaybe . lookupHeaders+lookupHeader = fmap listToMaybe . lookupHeaders  -- | Lookup a request header. --@@ -1069,11 +1064,9 @@ -- -- Since 1.4.9 lookupBasicAuth :: (MonadHandler m) => m (Maybe (Text, Text))-lookupBasicAuth = fmap (>>= getBA)-                  (lookupHeader "Authorization")+lookupBasicAuth = fmap (>>= getBA) (lookupHeader "Authorization")   where-    getBA bs = (\(x, y) -> ( decodeUtf8With lenientDecode x-                          , decodeUtf8With lenientDecode y))+    getBA bs = (decodeUtf8With lenientDecode *** decodeUtf8With lenientDecode)                <$> extractBasicAuth bs  -- | Lookup bearer authentication datafrom __Authorization__ header of@@ -1096,7 +1089,7 @@  -- | Lookup for GET parameters. lookupGetParam :: MonadHandler m => Text -> m (Maybe Text)-lookupGetParam = liftM listToMaybe . lookupGetParams+lookupGetParam = fmap listToMaybe . lookupGetParams  -- | Lookup for POST parameters. lookupPostParams :: (MonadResource m, MonadHandler m) => Text -> m [Text]@@ -1107,13 +1100,13 @@ lookupPostParam :: (MonadResource m, MonadHandler m)                 => Text                 -> m (Maybe Text)-lookupPostParam = liftM listToMaybe . lookupPostParams+lookupPostParam = fmap listToMaybe . lookupPostParams  -- | Lookup for POSTed files. lookupFile :: (MonadHandler m, MonadResource m)            => Text            -> m (Maybe FileInfo)-lookupFile = liftM listToMaybe . lookupFiles+lookupFile = fmap listToMaybe . lookupFiles  -- | Lookup for POSTed files. lookupFiles :: (MonadHandler m, MonadResource m)@@ -1125,7 +1118,7 @@  -- | Lookup for cookie data. lookupCookie :: MonadHandler m => Text -> m (Maybe Text)-lookupCookie = liftM listToMaybe . lookupCookies+lookupCookie = fmap listToMaybe . lookupCookies  -- | Lookup for cookie data. lookupCookies :: MonadHandler m => Text -> m [Text]@@ -1160,7 +1153,7 @@ selectRep w = do     -- the content types are already sorted by q values     -- which have been stripped-    cts <- liftM reqAccept getRequest+    cts <- fmap reqAccept getRequest      case mapMaybe tryAccept cts of         [] ->@@ -1175,8 +1168,7 @@     explainUnaccepted :: Text     explainUnaccepted = "no match found for accept header" -    returnRep (ProvidedRep ct mcontent) =-        mcontent >>= return . TypedContent ct+    returnRep (ProvidedRep ct mcontent) = fmap (TypedContent ct) mcontent      reps = appEndo (Writer.execWriter w) [] @@ -1235,7 +1227,7 @@                -> m a                -> Writer.Writer (Endo [ProvidedRep m]) () provideRepType ct handler =-    Writer.tell $ Endo $ (ProvidedRep ct (liftM toContent handler):)+    Writer.tell $ Endo (ProvidedRep ct (liftM toContent handler):)  -- | Stream in the raw request body without any parsing. --

@@ -1,5 +1,4 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings, CPP #-} module Yesod.Core.Internal.Request     ( parseWaiRequest     , RequestBodyContents@@ -37,7 +36,7 @@ import Data.Conduit import Data.Conduit.List (sourceList) import Data.Conduit.Binary (sourceFile, sinkFile)-import Data.Word (Word64)+import Data.Word (Word8, Word64) import Control.Monad.Trans.Resource (runResourceT, ResourceT) import Control.Exception (throwIO) import Control.Monad ((<=<), liftM)@@ -47,7 +46,6 @@ import qualified System.Random.MWC as MWC import Control.Monad.Primitive (PrimMonad, PrimState) import qualified Data.Vector.Storable as V-import Data.Word (Word8) import Data.ByteString.Internal (ByteString (PS)) import qualified Data.Word8 as Word8 @@ -78,7 +76,7 @@                 -> SessionMap                 -> Bool                 -> Maybe Word64 -- ^ max body size-                -> (Either (IO YesodRequest) (MWC.GenIO -> IO YesodRequest))+                -> Either (IO YesodRequest) (MWC.GenIO -> 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@@ -147,7 +145,7 @@  addTwoLetters :: ([Text] -> [Text], Set.Set Text) -> [Text] -> [Text] addTwoLetters (toAdd, exist) [] =-    filter (flip Set.notMember exist) $ toAdd []+    filter (`Set.notMember` exist) $ toAdd [] addTwoLetters (toAdd, exist) (l:ls) =     l : addTwoLetters (toAdd', exist') ls   where@@ -177,7 +175,8 @@ {-# INLINE fromByteVector #-}  mkFileInfoLBS :: Text -> Text -> L.ByteString -> FileInfo-mkFileInfoLBS name ct lbs = FileInfo name ct (sourceList $ L.toChunks lbs) (\fp -> L.writeFile fp lbs)+mkFileInfoLBS name ct lbs =+    FileInfo name ct (sourceList $ L.toChunks lbs) (`L.writeFile` lbs)  mkFileInfoFile :: Text -> Text -> FilePath -> FileInfo mkFileInfoFile name ct fp = FileInfo name ct (sourceFile fp) (\dst -> runResourceT $ sourceFile fp $$ sinkFile dst)

@@ -1,19 +1,15 @@ {-# LANGUAGE CPP               #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PatternGuards     #-} {-# LANGUAGE RankNTypes        #-}-{-# LANGUAGE RecordWildCards   #-}-{-# LANGUAGE TemplateHaskell   #-} module Yesod.Core.Internal.Response where -import           Blaze.ByteString.Builder     (toByteString) import           Data.ByteString              (ByteString) import qualified Data.ByteString              as S import qualified Data.ByteString.Char8        as S8 import           Data.CaseInsensitive         (CI) import qualified Data.CaseInsensitive         as CI import           Network.Wai-import           Data.Conduit                 (transPipe)+import           Control.Monad                (mplus) import           Control.Monad.Trans.Resource (runInternalState, InternalState) import           Network.Wai.Internal #if !MIN_VERSION_base(4, 6, 0)@@ -26,12 +22,12 @@ import qualified Data.Text                    as T import           Control.Exception            (SomeException, handle) import           Blaze.ByteString.Builder     (fromLazyByteString,-                                               toLazyByteString)+                                               toLazyByteString, toByteString) 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 (..), ($$))+import           Data.Conduit                 (Flush (..), ($$), transPipe) import qualified Data.Conduit.List            as CL  yarToResponse :: YesodResponse@@ -58,11 +54,10 @@     let go (ContentBuilder b mlen) = do             let hs' = maybe finalHeaders finalHeaders' mlen             sendResponse $ ResponseBuilder s hs' b-        go (ContentFile fp p) = do-            sendResponse $ ResponseFile s finalHeaders fp p+        go (ContentFile fp p) = sendResponse $ ResponseFile s finalHeaders fp p         go (ContentSource body) = sendResponse $ responseStream s finalHeaders-            $ \sendChunk flush -> do-                transPipe (flip runInternalState is) body+            $ \sendChunk flush ->+                transPipe (`runInternalState` is) body                 $$ CL.mapM_ (\mchunk ->                     case mchunk of                         Flush -> flush@@ -91,7 +86,7 @@ headerToPair :: Header              -> (CI ByteString, ByteString) headerToPair (AddCookie sc) =-    ("Set-Cookie", toByteString $ renderSetCookie $ sc)+    ("Set-Cookie", toByteString $ renderSetCookie sc) headerToPair (DeleteCookie key path) =     ( "Set-Cookie"     , S.concat@@ -107,7 +102,7 @@ evaluateContent (ContentBuilder b mlen) = handle f $ do     let lbs = toLazyByteString b         len = L.length lbs-        mlen' = maybe (Just $ fromIntegral len) Just mlen+        mlen' = mlen `mplus` Just (fromIntegral len)     len `seq` return (Right $ ContentBuilder (fromLazyByteString lbs) mlen')   where     f :: SomeException -> IO (Either ErrorResponse Content)

@@ -11,6 +11,7 @@  #if __GLASGOW_HASKELL__ < 710 import           Data.Monoid                  (Monoid, mempty)+import           Control.Applicative          ((<$>)) #endif import Yesod.Core.Internal.Response import           Blaze.ByteString.Builder     (toByteString)@@ -102,7 +103,7 @@         (\e ->             case fromException e of                 Just e' -> return e'-                Nothing -> fmap HCError $ toErrorHandler e)+                Nothing -> HCError <$> toErrorHandler e)      -- Get the raw state and return     state <- I.readIORef istate@@ -330,7 +331,7 @@   | otherwise = do     let dontSaveSession _ = return []     (session, saveSession) <- liftIO $-        maybe (return (Map.empty, dontSaveSession)) (\sb -> sbLoadSession sb req) yreSessionBackend+        maybe (return (Map.empty, dontSaveSession)) (`sbLoadSession` req) yreSessionBackend     maxExpires <- yreGetMaxExpires     let mkYesodReq = parseWaiRequest req session (isJust yreSessionBackend) mmaxLen     let yreq =@@ -375,7 +376,7 @@     fromMaybe         (joinPath y ar ps           $ params ++ params')-        (urlRenderOverride y url)+        (urlParamRenderOverride y url params)   where     (ps, params') = renderRoute url 

@@ -11,11 +11,9 @@ import Data.Serialize import Data.Time import Data.ByteString (ByteString)-import Control.Concurrent (forkIO, killThread, threadDelay)-import Control.Monad (forever, guard)+import Control.Monad (guard) import Yesod.Core.Types import Yesod.Core.Internal.Util-import qualified Data.IORef as I import Control.AutoUpdate  encodeClientSession :: CS.Key@@ -63,7 +61,7 @@       , updateFreq   = 10000000 -- 10s       } -    return $! (getClientSessionDateCache, return ())+    return (getClientSessionDateCache, return ())   where     getUpdated = do       now <- getCurrentTime

@@ -16,7 +16,10 @@  import Data.ByteString.Lazy.Char8 () import Data.List (foldl')-import Control.Monad (replicateM)+#if __GLASGOW_HASKELL__ < 710+import Control.Applicative ((<$>))+#endif+import Control.Monad (replicateM, void) import Data.Either (partitionEithers)  import Yesod.Routes.TH@@ -45,15 +48,15 @@ -- monolithic file into smaller parts. Use this function, paired with -- 'mkYesodDispatch', to do just that. mkYesodData :: String -> [ResourceTree String] -> Q [Dec]-mkYesodData name res = mkYesodDataGeneral name False res+mkYesodData name = mkYesodDataGeneral name False  mkYesodSubData :: String -> [ResourceTree String] -> Q [Dec]-mkYesodSubData name res = mkYesodDataGeneral name True res+mkYesodSubData name = mkYesodDataGeneral name True  mkYesodDataGeneral :: String -> Bool -> [ResourceTree String] -> Q [Dec] mkYesodDataGeneral name isSub res = do     let (name':rest) = words name-    fmap fst $ mkYesodGeneral name' (fmap Left rest) isSub return res+    fst <$> mkYesodGeneral name' (fmap Left rest) isSub return res  -- | See 'mkYesodData'. mkYesodDispatch :: String -> [ResourceTree String] -> Q [Dec]@@ -150,8 +153,8 @@     , mdsGetPathInfo = [|W.pathInfo|]     , mdsSetPathInfo = [|\p r -> r { W.pathInfo = p }|]     , mdsMethod = [|W.requestMethod|]-    , mds404 = [|notFound >> return ()|]-    , mds405 = [|badMethod >> return ()|]+    , mds404 = [|void notFound|]+    , mds405 = [|void badMethod|]     , mdsGetHandler = defaultGetHandler     , mdsUnwrapper = f     }

@@ -14,8 +14,6 @@ import           Data.Time      (Day (ModifiedJulianDay, toModifiedJulianDay),                                  DiffTime, UTCTime (..), formatTime,                                  getCurrentTime, addUTCTime)-import           Control.Monad  (liftM)- #if MIN_VERSION_time(1,5,0) import           Data.Time      (defaultTimeLocale) #else@@ -58,4 +56,4 @@ date on a resource that never expires. See RFC 2616 section 14.21 for details. -} getCurrentMaxExpiresRFC1123 :: IO T.Text-getCurrentMaxExpiresRFC1123 = liftM (formatRFC1123 . addUTCTime (60*60*24*365)) getCurrentTime+getCurrentMaxExpiresRFC1123 = fmap (formatRFC1123 . addUTCTime (60*60*24*365)) getCurrentTime

@@ -20,8 +20,7 @@ import           Control.Exception                  (Exception) import           Control.Monad                      (liftM, ap) import           Control.Monad.Base                 (MonadBase (liftBase))-import           Control.Monad.Catch                (MonadCatch (..))-import           Control.Monad.Catch                (MonadMask (..))+import           Control.Monad.Catch                (MonadMask (..), MonadCatch (..)) import           Control.Monad.IO.Class             (MonadIO (liftIO)) import           Control.Monad.Logger               (LogLevel, LogSource,                                                      MonadLogger (..))@@ -172,7 +171,7 @@ type BottomOfHeadAsync master        = [Text] -- ^ urls to load asynchronously       -> Maybe (HtmlUrl (Route master)) -- ^ widget of js to run on async completion-      -> (HtmlUrl (Route master)) -- ^ widget to insert at the bottom of <head>+      -> HtmlUrl (Route master) -- ^ widget to insert at the bottom of <head>  type Texts = [Text] @@ -264,7 +263,7 @@ -- @getHomeR = do defaultLayout "Widget text"@ instance (Monad m, a ~ ()) => IsString (WidgetT site m a) where     fromString = toWidget . toHtml . T.pack-      where toWidget x = WidgetT $ const $ return $ ((), GWData (Body (const x))+      where toWidget x = WidgetT $ const $ return ((), GWData (Body (const x))                          mempty mempty mempty mempty mempty mempty)  type RY master = Route master -> [(Text, Text)] -> Text@@ -422,15 +421,15 @@     type StM (WidgetT site m) a = StM m (a, GWData (Route site))     liftBaseWith f = WidgetT $ \reader' ->         liftBaseWith $ \runInBase ->-            liftM (\x -> (x, mempty))+            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 ->-            liftM (\x -> (x, mempty))-            (f $ liftM StW . runInBase . flip unWidgetT reader')+            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@@ -464,11 +463,11 @@       where q u (WidgetT b) = WidgetT (u . b)  instance (Applicative m, MonadIO m, MonadBase IO m, MonadThrow m) => MonadResource (WidgetT site m) where-    liftResourceT f = WidgetT $ \hd -> liftIO $ fmap (, mempty) $ runInternalState f (handlerResource hd)+    liftResourceT f = WidgetT $ \hd -> liftIO $ (, mempty) <$> runInternalState f (handlerResource hd)  instance MonadIO m => MonadLogger (WidgetT site m) where     monadLoggerLog a b c d = WidgetT $ \hd ->-        liftIO $ fmap (, mempty) $ rheLog (handlerEnv hd) a b c (toLogStr d)+        liftIO $ (, mempty) <$> rheLog (handlerEnv hd) a b c (toLogStr d)  #if MIN_VERSION_monad_logger(0, 3, 10) instance MonadIO m => MonadLoggerIO (WidgetT site m) where@@ -522,7 +521,7 @@     data StM (HandlerT site m) a = StH (StM m a)     liftBaseWith f = HandlerT $ \reader' ->         liftBaseWith $ \runInBase ->-            f $ liftM StH . runInBase . (\(HandlerT r) -> r reader')+            f $ fmap StH . runInBase . (\(HandlerT r) -> r reader')     restoreM (StH base) = HandlerT $ const $ restoreM base #endif 

@@ -57,9 +57,12 @@ import Text.Julius import Yesod.Routes.Class import Yesod.Core.Handler (getMessageRender, getUrlRenderParams)+#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 Control.Monad (liftM) import Data.Text (Text) import qualified Data.Map as Map import Language.Haskell.TH.Quote (QuasiQuoter)@@ -232,7 +235,7 @@     let ur f = do             let env = NP.Env                     (Just $ helper [|getUrlRenderParams|])-                    (Just $ helper [|liftM (toHtml .) getMessageRender|])+                    (Just $ helper [|fmap (toHtml .) getMessageRender|])             f env     return $ NP.HamletRules ah ur $ \_ b -> return $ ah `AppE` b @@ -272,16 +275,16 @@  liftGWD :: (child -> parent) -> GWData child -> GWData parent liftGWD tp gwd = GWData-    { gwdBody = fixBody $ gwdBody gwd-    , gwdTitle = gwdTitle gwd-    , gwdScripts = fixUnique fixScript $ gwdScripts gwd+    { gwdBody        = fixBody $ gwdBody gwd+    , gwdTitle       = gwdTitle gwd+    , gwdScripts     = fixUnique fixScript $ gwdScripts gwd     , gwdStylesheets = fixUnique fixStyle $ gwdStylesheets gwd-    , gwdCss = fmap fixCss $ gwdCss gwd-    , gwdJavascript = fmap fixJS $ gwdJavascript gwd-    , gwdHead = fixHead $ gwdHead gwd+    , gwdCss         = fixCss <$> gwdCss gwd+    , gwdJavascript  = fixJS <$> gwdJavascript gwd+    , gwdHead        = fixHead $ gwdHead gwd     }   where-    fixRender f route params = f (tp route) params+    fixRender f route = f (tp route)      fixBody (Body h) = Body $ h . fixRender     fixHead (Head h) = Head $ h . fixRender

@@ -1,4 +1,3 @@-{-# LANGUAGE TemplateHaskell #-} module Yesod.Routes.TH     ( module Yesod.Routes.TH.Types       -- * Functions

@@ -55,7 +55,7 @@       where         con = NormalC (mkName name)             $ map (\x -> (notStrict, x))-            $ concat [singles, [ConT $ mkName name]]+            $ singles ++ [ConT $ mkName name]          singles = concatMap toSingle pieces         toSingle Static{} = []@@ -99,7 +99,7 @@         dyns <- replicateM cnt $ newName "dyn"         sub <-             case resourceDispatch res of-                Subsite{} -> fmap return $ newName "sub"+                Subsite{} -> return <$> newName "sub"                 _ -> return []         let pat = ConP (mkName $ resourceName res) $ map VarP $ dyns ++ sub @@ -136,7 +136,7 @@     mkPieces _ _ [] _ = []     mkPieces toText tsp (Static s:ps) dyns = toText s : mkPieces toText tsp ps dyns     mkPieces toText tsp (Dynamic{}:ps) (d:dyns) = tsp `AppE` VarE d : mkPieces toText tsp ps dyns-    mkPieces _ _ ((Dynamic _) : _) [] = error "mkPieces 120"+    mkPieces _ _ (Dynamic _ : _) [] = error "mkPieces 120"  -- | Generate the 'RenderRoute' instance. --

@@ -10,6 +10,9 @@ import Language.Haskell.TH.Syntax import Data.Set (fromList) import Data.Text (pack)+#if __GLASGOW_HASKELL__ < 710+import Control.Applicative ((<$>))+#endif  mkRouteAttrsInstance :: Type -> [ResourceTree a] -> Q Dec mkRouteAttrsInstance typ ress = do@@ -19,11 +22,11 @@         ]  goTree :: (Pat -> Pat) -> ResourceTree a -> Q [Clause]-goTree front (ResourceLeaf res) = fmap return $ goRes front res+goTree front (ResourceLeaf res) = return <$> goRes front res goTree front (ResourceParent name _check pieces trees) =-    fmap concat $ mapM (goTree front') trees+    concat <$> mapM (goTree front') trees   where-    ignored = ((replicate toIgnore WildP ++) . return)+    ignored = (replicate toIgnore WildP ++) . return     toIgnore = length $ filter isDynamic pieces     isDynamic Dynamic{} = True     isDynamic Static{} = False

@@ -53,11 +53,11 @@     deriving Show  instance Functor Piece where-    fmap _ (Static s) = (Static s)+    fmap _ (Static s)  = Static s     fmap f (Dynamic t) = Dynamic (f t)  instance Lift t => Lift (Piece t) where-    lift (Static s) = [|Static $(lift s)|]+    lift (Static s)  = [|Static  $(lift s)|]     lift (Dynamic t) = [|Dynamic $(lift t)|]  data Dispatch typ =

@@ -1,5 +1,5 @@ {-# LANGUAGE CPP                        #-}-module YesodCoreTest (specs) where +module YesodCoreTest (specs) where  import YesodCoreTest.CleanPath import YesodCoreTest.Exceptions@@ -48,4 +48,5 @@       LiteApp.specs       Ssl.unsecSpec       Ssl.sslOnlySpec+      Ssl.sameSiteSpec       Csrf.csrfSpec

@@ -13,8 +13,6 @@ import Data.IORef.Lifted import Data.Typeable (Typeable) import qualified Data.ByteString.Lazy.Char8 as L8-import Data.Text (Text)-import Data.Text.Encoding (encodeUtf8)  data C = C 

@@ -9,11 +9,10 @@ import Test.Hspec import Network.Wai import Network.Wai.Test-import Text.Hamlet (hamlet) import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Char8 as S8 import Control.Exception (SomeException, try)-import Network.HTTP.Types (mkStatus)+import Network.HTTP.Types (Status, mkStatus) import Blaze.ByteString.Builder (Builder, fromByteString, toLazyByteString) import Data.Monoid (mconcat) import Data.Text (Text, pack)@@ -40,6 +39,7 @@ /good-builder GoodBuilderR GET |] +overrideStatus :: Status overrideStatus = mkStatus 15 "OVERRIDE"  instance Yesod App where

@@ -2,10 +2,7 @@ module YesodCoreTest.InternalRequest (internalRequestTest) where  import Data.List (nub)-import System.Random (StdGen, mkStdGen)- import Network.Wai as W-import Network.Wai.Test import Yesod.Core.Internal (randomString, parseWaiRequest) import Test.Hspec import Data.Monoid (mempty)

@@ -6,7 +6,6 @@ import Test.Hspec  import Yesod.Core-import Text.Hamlet import Network.Wai import Network.Wai.Test import Data.Text (Text)

@@ -8,7 +8,6 @@ import Yesod.Core import Network.Wai import Network.Wai.Test-import Text.Lucius import YesodCoreTest.MediaData  mkYesodDispatch "Y" resourcesY

@@ -8,7 +8,6 @@ module YesodCoreTest.NoOverloadedStringsSub where  import Yesod.Core-import Network.Wai import Yesod.Core.Types  data Subsite = Subsite (forall master. Yesod master => YesodSubRunnerEnv Subsite master (HandlerT master IO) -> Application)

@@ -1,6 +1,8 @@ {-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-}-module YesodCoreTest.Ssl ( sslOnlySpec, unsecSpec ) where+module YesodCoreTest.Ssl ( sslOnlySpec, unsecSpec, sameSiteSpec ) where import qualified YesodCoreTest.StubSslOnly as Ssl+import qualified YesodCoreTest.StubLaxSameSite as LaxSameSite+import qualified YesodCoreTest.StubStrictSameSite as StrictSameSite import qualified YesodCoreTest.StubUnsecured as Unsecured import Yesod.Core import Test.Hspec@@ -62,3 +64,15 @@   where     atHome = homeFixtureFor Unsecured.App     isNotSecure c = not $ Cookie.setCookieSecure c++sameSiteSpec :: Spec+sameSiteSpec = describe "A Yesod application" $ do+    it "can set a Lax SameSite option" $+        laxHome $ "_SESSION" `cookieShouldSatisfy` isLax+    it "can set a Strict SameSite option" $+        strictHome $ "_SESSION" `cookieShouldSatisfy` isStrict+  where+    laxHome = homeFixtureFor LaxSameSite.App+    strictHome = homeFixtureFor StrictSameSite.App+    isLax = (== Just Cookie.sameSiteLax) . Cookie.setCookieSameSite+    isStrict = (== Just Cookie.sameSiteStrict) . Cookie.setCookieSameSite

@@ -0,0 +1,23 @@+{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-}+module YesodCoreTest.StubLaxSameSite ( App ( App ) ) where++import Yesod.Core+import qualified Web.ClientSession                  as CS++data App = App++mkYesod "App" [parseRoutes|+/ HomeR GET+|]++instance Yesod App where+    yesodMiddleware = defaultYesodMiddleware . (sslOnlyMiddleware 120)+    makeSessionBackend _ = laxSameSiteSessions $+        fmap Just $ defaultClientSessionBackend 120 CS.defaultKeyFile++getHomeR :: Handler Html+getHomeR = defaultLayout+    [whamlet|+        <p>+            Welcome to my test application.+    |]

@@ -0,0 +1,23 @@+{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-}+module YesodCoreTest.StubStrictSameSite ( App ( App ) ) where++import Yesod.Core+import qualified Web.ClientSession                  as CS++data App = App++mkYesod "App" [parseRoutes|+/ HomeR GET+|]++instance Yesod App where+    yesodMiddleware = defaultYesodMiddleware . (sslOnlyMiddleware 120)+    makeSessionBackend _ = strictSameSiteSessions $+        fmap Just $ defaultClientSessionBackend 120 CS.defaultKeyFile++getHomeR :: Handler Html+getHomeR = defaultLayout+    [whamlet|+        <p>+            Welcome to my test application.+    |]

@@ -6,10 +6,6 @@ import Test.Hspec  import Yesod.Core-import Text.Julius-import Text.Lucius-import Text.Hamlet- import Network.Wai import Network.Wai.Test 

@@ -1,5 +1,5 @@ name:            yesod-core-version:         1.4.22+version:         1.4.23 license:         MIT license-file:    LICENSE author:          Michael Snoyman <michael@snoyman.com>@@ -42,7 +42,7 @@                    , unordered-containers  >= 0.2                    , monad-control         >= 0.3      && < 1.1                    , transformers-base     >= 0.4-                   , cookie                >= 0.4.1    && < 0.5+                   , cookie                >= 0.4.2    && < 0.5                    , http-types            >= 0.7                    , case-insensitive      >= 0.2                    , parsec                >= 2        && < 3.2