Hello community, here is the log from the commit of package ghc-yesod-core for openSUSE:Factory checked in at 2016-08-26 23:17:27 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-yesod-core (Old) and /work/SRC/openSUSE:Factory/.ghc-yesod-core.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-yesod-core" Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-yesod-core/ghc-yesod-core.changes 2016-07-20 09:23:03.000000000 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-yesod-core.new/ghc-yesod-core.changes 2016-08-26 23:17:29.000000000 +0200 @@ -1,0 +2,5 @@ +Wed Aug 17 18:34:36 UTC 2016 - [email protected] + +- Update to version 1.4.23 revision 0 with cabal2obs. + +------------------------------------------------------------------- Old: ---- yesod-core-1.4.22.tar.gz New: ---- yesod-core-1.4.23.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-yesod-core.spec ++++++ --- /var/tmp/diff_new_pack.RGVvqs/_old 2016-08-26 23:17:31.000000000 +0200 +++ /var/tmp/diff_new_pack.RGVvqs/_new 2016-08-26 23:17:31.000000000 +0200 @@ -19,15 +19,14 @@ %global pkg_name yesod-core %bcond_with tests Name: ghc-%{pkg_name} -Version: 1.4.22 +Version: 1.4.23 Release: 0 Summary: Creation of type-safe, RESTful web applications License: MIT -Group: System/Libraries +Group: Development/Languages/Other Url: https://hackage.haskell.org/package/%{pkg_name} Source0: https://hackage.haskell.org/package/%{pkg_name}-%{version}/%{pkg_name}-%{version}.tar.gz BuildRequires: ghc-Cabal-devel -# Begin cabal-rpm deps: BuildRequires: ghc-aeson-devel BuildRequires: ghc-auto-update-devel BuildRequires: ghc-blaze-builder-devel @@ -87,7 +86,6 @@ BuildRequires: ghc-network-devel BuildRequires: ghc-streaming-commons-devel %endif -# End cabal-rpm deps %description API docs and the README are available at @@ -107,20 +105,14 @@ %prep %setup -q -n %{pkg_name}-%{version} - %build %ghc_lib_build - %install %ghc_lib_install - %check -%if %{with tests} -%{cabal} test -%endif - +%cabal_test %post devel %ghc_pkg_recache ++++++ yesod-core-1.4.22.tar.gz -> yesod-core-1.4.23.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/yesod-core-1.4.22/ChangeLog.md new/yesod-core-1.4.23/ChangeLog.md --- old/yesod-core-1.4.22/ChangeLog.md 2016-06-27 09:45:17.000000000 +0200 +++ new/yesod-core-1.4.23/ChangeLog.md 2016-08-10 14:21:43.000000000 +0200 @@ -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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/yesod-core-1.4.22/Yesod/Core/Class/Dispatch.hs new/yesod-core-1.4.23/Yesod/Core/Class/Dispatch.hs --- old/yesod-core-1.4.22/Yesod/Core/Class/Dispatch.hs 2016-06-27 09:45:17.000000000 +0200 +++ new/yesod-core-1.4.23/Yesod/Core/Class/Dispatch.hs 2016-08-10 14:21:43.000000000 +0200 @@ -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. diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/yesod-core-1.4.22/Yesod/Core/Class/Yesod.hs new/yesod-core-1.4.23/Yesod/Core/Class/Yesod.hs --- old/yesod-core-1.4.22/Yesod/Core/Class/Yesod.hs 2016-06-27 09:45:17.000000000 +0200 +++ new/yesod-core-1.4.23/Yesod/Core/Class/Yesod.hs 2016-08-10 14:21:43.000000000 +0200 @@ -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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/yesod-core-1.4.22/Yesod/Core/Content.hs new/yesod-core-1.4.23/Yesod/Core/Content.hs --- old/yesod-core-1.4.22/Yesod/Core/Content.hs 2016-06-27 09:45:17.000000000 +0200 +++ new/yesod-core-1.4.23/Yesod/Core/Content.hs 2016-08-10 14:21:43.000000000 +0200 @@ -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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/yesod-core-1.4.22/Yesod/Core/Dispatch.hs new/yesod-core-1.4.23/Yesod/Core/Dispatch.hs --- old/yesod-core-1.4.22/Yesod/Core/Dispatch.hs 2016-06-27 09:45:17.000000000 +0200 +++ new/yesod-core-1.4.23/Yesod/Core/Dispatch.hs 2016-08-10 14:21:43.000000000 +0200 @@ -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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/yesod-core-1.4.22/Yesod/Core/Handler.hs new/yesod-core-1.4.23/Yesod/Core/Handler.hs --- old/yesod-core-1.4.22/Yesod/Core/Handler.hs 2016-06-27 09:45:17.000000000 +0200 +++ new/yesod-core-1.4.23/Yesod/Core/Handler.hs 2016-08-10 14:21:43.000000000 +0200 @@ -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. -- diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/yesod-core-1.4.22/Yesod/Core/Internal/Request.hs new/yesod-core-1.4.23/Yesod/Core/Internal/Request.hs --- old/yesod-core-1.4.22/Yesod/Core/Internal/Request.hs 2016-06-27 09:45:17.000000000 +0200 +++ new/yesod-core-1.4.23/Yesod/Core/Internal/Request.hs 2016-08-10 14:21:43.000000000 +0200 @@ -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) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/yesod-core-1.4.22/Yesod/Core/Internal/Response.hs new/yesod-core-1.4.23/Yesod/Core/Internal/Response.hs --- old/yesod-core-1.4.22/Yesod/Core/Internal/Response.hs 2016-06-27 09:45:17.000000000 +0200 +++ new/yesod-core-1.4.23/Yesod/Core/Internal/Response.hs 2016-08-10 14:21:43.000000000 +0200 @@ -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) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/yesod-core-1.4.22/Yesod/Core/Internal/Run.hs new/yesod-core-1.4.23/Yesod/Core/Internal/Run.hs --- old/yesod-core-1.4.22/Yesod/Core/Internal/Run.hs 2016-06-27 09:45:17.000000000 +0200 +++ new/yesod-core-1.4.23/Yesod/Core/Internal/Run.hs 2016-08-10 14:21:43.000000000 +0200 @@ -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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/yesod-core-1.4.22/Yesod/Core/Internal/Session.hs new/yesod-core-1.4.23/Yesod/Core/Internal/Session.hs --- old/yesod-core-1.4.22/Yesod/Core/Internal/Session.hs 2016-06-27 09:45:17.000000000 +0200 +++ new/yesod-core-1.4.23/Yesod/Core/Internal/Session.hs 2016-08-10 14:21:43.000000000 +0200 @@ -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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/yesod-core-1.4.22/Yesod/Core/Internal/TH.hs new/yesod-core-1.4.23/Yesod/Core/Internal/TH.hs --- old/yesod-core-1.4.22/Yesod/Core/Internal/TH.hs 2016-06-27 09:45:17.000000000 +0200 +++ new/yesod-core-1.4.23/Yesod/Core/Internal/TH.hs 2016-08-10 14:21:43.000000000 +0200 @@ -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 } diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/yesod-core-1.4.22/Yesod/Core/Internal/Util.hs new/yesod-core-1.4.23/Yesod/Core/Internal/Util.hs --- old/yesod-core-1.4.22/Yesod/Core/Internal/Util.hs 2016-06-27 09:45:17.000000000 +0200 +++ new/yesod-core-1.4.23/Yesod/Core/Internal/Util.hs 2016-08-10 14:21:43.000000000 +0200 @@ -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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/yesod-core-1.4.22/Yesod/Core/Types.hs new/yesod-core-1.4.23/Yesod/Core/Types.hs --- old/yesod-core-1.4.22/Yesod/Core/Types.hs 2016-06-27 09:45:17.000000000 +0200 +++ new/yesod-core-1.4.23/Yesod/Core/Types.hs 2016-08-10 14:21:43.000000000 +0200 @@ -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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/yesod-core-1.4.22/Yesod/Core/Widget.hs new/yesod-core-1.4.23/Yesod/Core/Widget.hs --- old/yesod-core-1.4.22/Yesod/Core/Widget.hs 2016-06-27 09:45:17.000000000 +0200 +++ new/yesod-core-1.4.23/Yesod/Core/Widget.hs 2016-08-10 14:21:43.000000000 +0200 @@ -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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/yesod-core-1.4.22/Yesod/Core.hs new/yesod-core-1.4.23/Yesod/Core.hs --- old/yesod-core-1.4.22/Yesod/Core.hs 2016-06-27 09:45:17.000000000 +0200 +++ new/yesod-core-1.4.23/Yesod/Core.hs 2016-08-10 14:21:43.000000000 +0200 @@ -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) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/yesod-core-1.4.22/Yesod/Routes/TH/RenderRoute.hs new/yesod-core-1.4.23/Yesod/Routes/TH/RenderRoute.hs --- old/yesod-core-1.4.22/Yesod/Routes/TH/RenderRoute.hs 2016-06-27 09:45:17.000000000 +0200 +++ new/yesod-core-1.4.23/Yesod/Routes/TH/RenderRoute.hs 2016-08-10 14:21:43.000000000 +0200 @@ -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. -- diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/yesod-core-1.4.22/Yesod/Routes/TH/RouteAttrs.hs new/yesod-core-1.4.23/Yesod/Routes/TH/RouteAttrs.hs --- old/yesod-core-1.4.22/Yesod/Routes/TH/RouteAttrs.hs 2016-06-27 09:45:17.000000000 +0200 +++ new/yesod-core-1.4.23/Yesod/Routes/TH/RouteAttrs.hs 2016-08-10 14:21:43.000000000 +0200 @@ -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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/yesod-core-1.4.22/Yesod/Routes/TH/Types.hs new/yesod-core-1.4.23/Yesod/Routes/TH/Types.hs --- old/yesod-core-1.4.22/Yesod/Routes/TH/Types.hs 2016-06-27 09:45:17.000000000 +0200 +++ new/yesod-core-1.4.23/Yesod/Routes/TH/Types.hs 2016-08-10 14:21:43.000000000 +0200 @@ -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 = diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/yesod-core-1.4.22/Yesod/Routes/TH.hs new/yesod-core-1.4.23/Yesod/Routes/TH.hs --- old/yesod-core-1.4.22/Yesod/Routes/TH.hs 2016-06-27 09:45:17.000000000 +0200 +++ new/yesod-core-1.4.23/Yesod/Routes/TH.hs 2016-08-10 14:21:43.000000000 +0200 @@ -1,4 +1,3 @@ -{-# LANGUAGE TemplateHaskell #-} module Yesod.Routes.TH ( module Yesod.Routes.TH.Types -- * Functions diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/yesod-core-1.4.22/test/YesodCoreTest/Cache.hs new/yesod-core-1.4.23/test/YesodCoreTest/Cache.hs --- old/yesod-core-1.4.22/test/YesodCoreTest/Cache.hs 2016-06-27 09:45:17.000000000 +0200 +++ new/yesod-core-1.4.23/test/YesodCoreTest/Cache.hs 2016-08-10 14:21:43.000000000 +0200 @@ -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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/yesod-core-1.4.22/test/YesodCoreTest/ErrorHandling.hs new/yesod-core-1.4.23/test/YesodCoreTest/ErrorHandling.hs --- old/yesod-core-1.4.22/test/YesodCoreTest/ErrorHandling.hs 2016-06-27 09:45:17.000000000 +0200 +++ new/yesod-core-1.4.23/test/YesodCoreTest/ErrorHandling.hs 2016-08-10 14:21:43.000000000 +0200 @@ -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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/yesod-core-1.4.22/test/YesodCoreTest/InternalRequest.hs new/yesod-core-1.4.23/test/YesodCoreTest/InternalRequest.hs --- old/yesod-core-1.4.22/test/YesodCoreTest/InternalRequest.hs 2016-06-27 09:45:17.000000000 +0200 +++ new/yesod-core-1.4.23/test/YesodCoreTest/InternalRequest.hs 2016-08-10 14:21:43.000000000 +0200 @@ -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) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/yesod-core-1.4.22/test/YesodCoreTest/Links.hs new/yesod-core-1.4.23/test/YesodCoreTest/Links.hs --- old/yesod-core-1.4.22/test/YesodCoreTest/Links.hs 2016-06-27 09:45:17.000000000 +0200 +++ new/yesod-core-1.4.23/test/YesodCoreTest/Links.hs 2016-08-10 14:21:43.000000000 +0200 @@ -6,7 +6,6 @@ import Test.Hspec import Yesod.Core -import Text.Hamlet import Network.Wai import Network.Wai.Test import Data.Text (Text) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/yesod-core-1.4.22/test/YesodCoreTest/Media.hs new/yesod-core-1.4.23/test/YesodCoreTest/Media.hs --- old/yesod-core-1.4.22/test/YesodCoreTest/Media.hs 2016-06-27 09:45:17.000000000 +0200 +++ new/yesod-core-1.4.23/test/YesodCoreTest/Media.hs 2016-08-10 14:21:43.000000000 +0200 @@ -8,7 +8,6 @@ import Yesod.Core import Network.Wai import Network.Wai.Test -import Text.Lucius import YesodCoreTest.MediaData mkYesodDispatch "Y" resourcesY diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/yesod-core-1.4.22/test/YesodCoreTest/NoOverloadedStringsSub.hs new/yesod-core-1.4.23/test/YesodCoreTest/NoOverloadedStringsSub.hs --- old/yesod-core-1.4.22/test/YesodCoreTest/NoOverloadedStringsSub.hs 2016-06-27 09:45:17.000000000 +0200 +++ new/yesod-core-1.4.23/test/YesodCoreTest/NoOverloadedStringsSub.hs 2016-08-10 14:21:43.000000000 +0200 @@ -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) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/yesod-core-1.4.22/test/YesodCoreTest/Ssl.hs new/yesod-core-1.4.23/test/YesodCoreTest/Ssl.hs --- old/yesod-core-1.4.22/test/YesodCoreTest/Ssl.hs 2016-06-27 09:45:17.000000000 +0200 +++ new/yesod-core-1.4.23/test/YesodCoreTest/Ssl.hs 2016-08-10 14:21:43.000000000 +0200 @@ -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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/yesod-core-1.4.22/test/YesodCoreTest/StubLaxSameSite.hs new/yesod-core-1.4.23/test/YesodCoreTest/StubLaxSameSite.hs --- old/yesod-core-1.4.22/test/YesodCoreTest/StubLaxSameSite.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/yesod-core-1.4.23/test/YesodCoreTest/StubLaxSameSite.hs 2016-08-10 14:21:43.000000000 +0200 @@ -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. + |] diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/yesod-core-1.4.22/test/YesodCoreTest/StubStrictSameSite.hs new/yesod-core-1.4.23/test/YesodCoreTest/StubStrictSameSite.hs --- old/yesod-core-1.4.22/test/YesodCoreTest/StubStrictSameSite.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/yesod-core-1.4.23/test/YesodCoreTest/StubStrictSameSite.hs 2016-08-10 14:21:43.000000000 +0200 @@ -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. + |] diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/yesod-core-1.4.22/test/YesodCoreTest/Widget.hs new/yesod-core-1.4.23/test/YesodCoreTest/Widget.hs --- old/yesod-core-1.4.22/test/YesodCoreTest/Widget.hs 2016-06-27 09:45:17.000000000 +0200 +++ new/yesod-core-1.4.23/test/YesodCoreTest/Widget.hs 2016-08-10 14:21:43.000000000 +0200 @@ -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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/yesod-core-1.4.22/test/YesodCoreTest.hs new/yesod-core-1.4.23/test/YesodCoreTest.hs --- old/yesod-core-1.4.22/test/YesodCoreTest.hs 2016-06-27 09:45:17.000000000 +0200 +++ new/yesod-core-1.4.23/test/YesodCoreTest.hs 2016-08-10 14:21:43.000000000 +0200 @@ -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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/yesod-core-1.4.22/yesod-core.cabal new/yesod-core-1.4.23/yesod-core.cabal --- old/yesod-core-1.4.22/yesod-core.cabal 2016-06-27 09:45:17.000000000 +0200 +++ new/yesod-core-1.4.23/yesod-core.cabal 2016-08-10 14:21:43.000000000 +0200 @@ -1,5 +1,5 @@ name: yesod-core -version: 1.4.22 +version: 1.4.23 license: MIT license-file: LICENSE author: Michael Snoyman <[email protected]> @@ -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
