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 - psimons@suse.com
+
+- 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