Hello community,
here is the log from the commit of package ghc-yesod-core for openSUSE:Factory
checked in at 2016-07-07 15:10:29
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
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-01 09:58:53.000000000 +0200
+++ /work/SRC/openSUSE:Factory/.ghc-yesod-core.new/ghc-yesod-core.changes
2016-07-07 15:10:29.000000000 +0200
@@ -1,0 +2,6 @@
+Thu Jun 30 13:28:15 UTC 2016 - mimi...@gmail.com
+
+- update to 1.4.22
+* Proper handling of impure exceptions within HandlerError values
+
+-------------------------------------------------------------------
Old:
----
yesod-core-1.4.21.tar.gz
New:
----
yesod-core-1.4.22.tar.gz
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Other differences:
------------------
++++++ ghc-yesod-core.spec ++++++
--- /var/tmp/diff_new_pack.GNQHCg/_old 2016-07-07 15:10:31.000000000 +0200
+++ /var/tmp/diff_new_pack.GNQHCg/_new 2016-07-07 15:10:31.000000000 +0200
@@ -19,7 +19,7 @@
%global pkg_name yesod-core
%bcond_with tests
Name: ghc-%{pkg_name}
-Version: 1.4.21
+Version: 1.4.22
Release: 0
Summary: Creation of type-safe, RESTful web applications
License: MIT
@@ -44,6 +44,7 @@
BuildRequires: ghc-cookie-devel
BuildRequires: ghc-data-default-devel
BuildRequires: ghc-deepseq-devel
+BuildRequires: ghc-deepseq-generics-devel
BuildRequires: ghc-directory-devel
BuildRequires: ghc-exceptions-devel
BuildRequires: ghc-fast-logger-devel
++++++ yesod-core-1.4.21.tar.gz -> yesod-core-1.4.22.tar.gz ++++++
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/yesod-core-1.4.21/ChangeLog.md
new/yesod-core-1.4.22/ChangeLog.md
--- old/yesod-core-1.4.21/ChangeLog.md 2016-06-20 16:31:06.000000000 +0200
+++ new/yesod-core-1.4.22/ChangeLog.md 2016-06-27 09:45:17.000000000 +0200
@@ -1,3 +1,7 @@
+## 1.4.22
+
+* Proper handling of impure exceptions within `HandlerError` values
+
## 1.4.21
* Add support for `Encoding` from `aeson-0.11`
[#1241](https://github.com/yesodweb/yesod/pull/1241)
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/yesod-core-1.4.21/Yesod/Core/Internal/Run.hs
new/yesod-core-1.4.22/Yesod/Core/Internal/Run.hs
--- old/yesod-core-1.4.21/Yesod/Core/Internal/Run.hs 2016-06-20
16:31:06.000000000 +0200
+++ new/yesod-core-1.4.22/Yesod/Core/Internal/Run.hs 2016-06-27
09:45:17.000000000 +0200
@@ -4,43 +4,36 @@
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TupleSections #-}
{-# LANGUAGE FlexibleContexts #-}
module Yesod.Core.Internal.Run where
#if __GLASGOW_HASKELL__ < 710
-import Data.Monoid (mempty)
+import Data.Monoid (Monoid, mempty)
#endif
import Yesod.Core.Internal.Response
import Blaze.ByteString.Builder (toByteString)
import Control.Exception (fromException, evaluate)
import qualified Control.Exception as E
-import Control.Exception.Lifted (catch)
-import Control.Monad (mplus)
-import Control.Monad.IO.Class (MonadIO)
-import Control.Monad.IO.Class (liftIO)
+import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Logger (LogLevel (LevelError),
LogSource,
liftLoc)
-import Control.Monad.Trans.Resource (runResourceT,
withInternalState, runInternalState)
+import Control.Monad.Trans.Resource (runResourceT,
withInternalState, runInternalState, InternalState)
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
import qualified Data.IORef as I
import qualified Data.Map as Map
-import Data.Maybe (isJust)
-import Data.Maybe (fromMaybe)
+import Data.Maybe (isJust, fromMaybe)
import Data.Monoid (appEndo)
import Data.Text (Text)
import qualified Data.Text as T
-import Data.Text.Encoding (encodeUtf8)
-import Data.Text.Encoding (decodeUtf8With)
+import Data.Text.Encoding (encodeUtf8, decodeUtf8With)
import Data.Text.Encoding.Error (lenientDecode)
import Language.Haskell.TH.Syntax (Loc, qLocation)
import qualified Network.HTTP.Types as H
import Network.Wai
import Network.Wai.Internal
-#if !MIN_VERSION_base(4, 6, 0)
-import Prelude hiding (catch)
-#endif
import System.Log.FastLogger (LogStr, toLogStr)
import Yesod.Core.Content
import Yesod.Core.Class.Yesod
@@ -49,31 +42,73 @@
tooLargeResponse)
import Yesod.Core.Internal.Util (getCurrentMaxExpiresRFC1123)
import Yesod.Routes.Class (Route, renderRoute)
-import Control.DeepSeq (($!!))
+import Control.DeepSeq (($!!), NFData)
-returnDeepSessionMap :: Monad m => SessionMap -> m SessionMap
-#if MIN_VERSION_bytestring(0, 10, 0)
-returnDeepSessionMap sm = return $!! sm
-#else
-returnDeepSessionMap sm = fmap unWrappedBS `liftM` (return $!! fmap WrappedBS
sm)
-
--- | Work around missing NFData instance for bytestring 0.9.
-newtype WrappedBS = WrappedBS { unWrappedBS :: S8.ByteString }
-instance NFData WrappedBS
-#endif
+-- | Catch all synchronous exceptions, ignoring asynchronous
+-- exceptions.
+--
+-- Ideally we'd use this from a different library
+catchSync :: IO a -> (E.SomeException -> IO a) -> IO a
+catchSync thing after = thing `E.catch` \e ->
+ if isAsyncException e
+ then E.throwIO e
+ else after e
--- | Function used internally by Yesod in the process of converting a
--- 'HandlerT' into an 'Application'. Should not be needed by users.
-runHandler :: ToTypedContent c
- => RunHandlerEnv site
- -> HandlerT site IO c
- -> YesodApp
-runHandler rhe@RunHandlerEnv {..} handler yreq = withInternalState $ \resState
-> do
- let toErrorHandler e =
+-- | Determine if an exception is asynchronous
+--
+-- Also worth being upstream
+isAsyncException :: E.SomeException -> Bool
+isAsyncException e =
+ case fromException e of
+ Just E.SomeAsyncException{} -> True
+ Nothing -> False
+
+-- | Convert an exception into an ErrorResponse
+toErrorHandler :: E.SomeException -> IO ErrorResponse
+toErrorHandler e0 = flip catchSync errFromShow $
+ case fromException e0 of
+ Just (HCError x) -> evaluate $!! x
+ _
+ | isAsyncException e0 -> E.throwIO e0
+ | otherwise -> errFromShow e0
+
+-- | Generate an @ErrorResponse@ based on the shown version of the exception
+errFromShow :: E.SomeException -> IO ErrorResponse
+errFromShow x = evaluate $!! InternalError $! T.pack $! show x
+
+-- | Do a basic run of a handler, getting some contents and the final
+-- @GHState@. The @GHState@ unfortunately may contain some impure
+-- exceptions, but all other synchronous exceptions will be caught and
+-- represented by the @HandlerContents@.
+basicRunHandler :: ToTypedContent c
+ => RunHandlerEnv site
+ -> HandlerT site IO c
+ -> YesodRequest
+ -> InternalState
+ -> IO (GHState, HandlerContents)
+basicRunHandler rhe handler yreq resState = do
+ -- Create a mutable ref to hold the state. We use mutable refs so
+ -- that the updates will survive runtime exceptions.
+ istate <- I.newIORef defState
+
+ -- Run the handler itself, capturing any runtime exceptions and
+ -- converting them into a @HandlerContents@
+ contents' <- catchSync
+ (do
+ res <- unHandlerT handler (hd istate)
+ tc <- evaluate (toTypedContent res)
+ -- Success! Wrap it up in an @HCContent@
+ return (HCContent defaultStatus tc))
+ (\e ->
case fromException e of
- Just (HCError x) -> x
- _ -> InternalError $ T.pack $ show e
- istate <- liftIO $ I.newIORef GHState
+ Just e' -> return e'
+ Nothing -> fmap HCError $ toErrorHandler e)
+
+ -- Get the raw state and return
+ state <- I.readIORef istate
+ return (state, contents')
+ where
+ defState = GHState
{ ghsSession = reqSession yreq
, ghsRBC = Nothing
, ghsIdent = 1
@@ -81,56 +116,57 @@
, ghsCacheBy = mempty
, ghsHeaders = mempty
}
- let hd = HandlerData
- { handlerRequest = yreq
- , handlerEnv = rhe
- , handlerState = istate
- , handlerToParent = const ()
- , handlerResource = resState
+ hd istate = HandlerData
+ { handlerRequest = yreq
+ , handlerEnv = rhe
+ , handlerState = istate
+ , handlerToParent = const ()
+ , handlerResource = resState
+ }
+
+-- | Convert an @ErrorResponse@ into a @YesodResponse@
+handleError :: RunHandlerEnv site
+ -> YesodRequest
+ -> InternalState
+ -> Map.Map Text S8.ByteString
+ -> [Header]
+ -> ErrorResponse
+ -> IO YesodResponse
+handleError rhe yreq resState finalSession headers e0 = do
+ -- Find any evil hidden impure exceptions
+ e <- (evaluate $!! e0) `catchSync` errFromShow
+
+ -- Generate a response, leveraging the updated session and
+ -- response headers
+ flip runInternalState resState $ do
+ yar <- rheOnError rhe e yreq
+ { reqSession = finalSession
}
- contents' <- catch (fmap Right $ unHandlerT handler hd)
- (\e -> return $ Left $ maybe (HCError $ toErrorHandler e) id
- $ fromException e)
- state <- liftIO $ I.readIORef istate
-
- (finalSession, mcontents1) <- (do
- finalSession <- returnDeepSessionMap (ghsSession state)
- return (finalSession, Nothing)) `E.catch` \e -> return
- (Map.empty, Just $! HCError $! InternalError $! T.pack $! show (e
:: E.SomeException))
-
- (headers, mcontents2) <- (do
- headers <- return $!! appEndo (ghsHeaders state) []
- return (headers, Nothing)) `E.catch` \e -> return
- ([], Just $! HCError $! InternalError $! T.pack $! show (e ::
E.SomeException))
-
- let contents =
- case mcontents1 `mplus` mcontents2 of
- Just x -> x
- Nothing -> either id (HCContent defaultStatus .
toTypedContent) contents'
- let handleError e = flip runInternalState resState $ do
- yar <- rheOnError e yreq
- { reqSession = finalSession
- }
- case yar of
- YRPlain status' hs ct c sess ->
- let hs' = headers ++ hs
- status
- | status' == defaultStatus = getStatus e
- | otherwise = status'
- in return $ YRPlain status hs' ct c sess
- YRWai _ -> return yar
- YRWaiApp _ -> return yar
- let sendFile' ct fp p =
- return $ YRPlain H.status200 headers ct (ContentFile fp p)
finalSession
- contents1 <- evaluate contents `E.catch` \e -> return
- (HCError $! InternalError $! T.pack $! show (e :: E.SomeException))
- case contents1 of
+ case yar of
+ YRPlain status' hs ct c sess ->
+ let hs' = headers ++ hs
+ status
+ | status' == defaultStatus = getStatus e
+ | otherwise = status'
+ in return $ YRPlain status hs' ct c sess
+ YRWai _ -> return yar
+ YRWaiApp _ -> return yar
+
+-- | Convert a @HandlerContents@ into a @YesodResponse@
+handleContents :: (ErrorResponse -> IO YesodResponse)
+ -> Map.Map Text S8.ByteString
+ -> [Header]
+ -> HandlerContents
+ -> IO YesodResponse
+handleContents handleError' finalSession headers contents =
+ case contents of
HCContent status (TypedContent ct c) -> do
- ec' <- liftIO $ evaluateContent c
+ -- Check for impure exceptions hiding in the contents
+ ec' <- evaluateContent c
case ec' of
- Left e -> handleError e
+ Left e -> handleError' e
Right c' -> return $ YRPlain status headers ct c' finalSession
- HCError e -> handleError e
+ HCError e -> handleError' e
HCRedirect status loc -> do
let disable_caching x =
Header "Cache-Control" "no-cache, must-revalidate"
@@ -141,20 +177,54 @@
return $ YRPlain
status hs typePlain emptyContent
finalSession
- HCSendFile ct fp p -> catch
- (sendFile' ct fp p)
- (handleError . toErrorHandler)
- HCCreated loc -> do
- let hs = Header "Location" (encodeUtf8 loc) : headers
- return $ YRPlain
- H.status201
- hs
- typePlain
- emptyContent
- finalSession
+ HCSendFile ct fp p -> return $ YRPlain
+ H.status200
+ headers
+ ct
+ (ContentFile fp p)
+ finalSession
+ HCCreated loc -> return $ YRPlain
+ H.status201
+ (Header "Location" (encodeUtf8 loc) : headers)
+ typePlain
+ emptyContent
+ finalSession
HCWai r -> return $ YRWai r
HCWaiApp a -> return $ YRWaiApp a
+-- | Evaluate the given value. If an exception is thrown, use it to
+-- replace the provided contents and then return @mempty@ in place of the
+-- evaluated value.
+evalFallback :: (Monoid w, NFData w)
+ => HandlerContents
+ -> w
+ -> IO (w, HandlerContents)
+evalFallback contents val = catchSync
+ (fmap (, contents) (evaluate $!! val))
+ (fmap ((mempty, ) . HCError) . toErrorHandler)
+
+-- | Function used internally by Yesod in the process of converting a
+-- 'HandlerT' into an 'Application'. Should not be needed by users.
+runHandler :: ToTypedContent c
+ => RunHandlerEnv site
+ -> HandlerT site IO c
+ -> YesodApp
+runHandler rhe@RunHandlerEnv {..} handler yreq = withInternalState $ \resState
-> do
+ -- Get the raw state and original contents
+ (state, contents0) <- basicRunHandler rhe handler yreq resState
+
+ -- Evaluate the unfortunately-lazy session and headers,
+ -- propagating exceptions into the contents
+ (finalSession, contents1) <- evalFallback contents0 (ghsSession state)
+ (headers, contents2) <- evalFallback contents1 (appEndo (ghsHeaders state)
[])
+
+ -- Convert the HandlerContents into the final YesodResponse
+ handleContents
+ (handleError rhe yreq resState finalSession headers)
+ finalSession
+ headers
+ contents2
+
safeEh :: (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
-> ErrorResponse
-> YesodApp
@@ -197,8 +267,7 @@
runFakeHandler fakeSessionMap logger site handler = liftIO $ do
ret <- I.newIORef (Left $ InternalError "runFakeHandler: no result")
maxExpires <- getCurrentMaxExpiresRFC1123
- let handler' = do liftIO . I.writeIORef ret . Right =<< handler
- return ()
+ let handler' = liftIO . I.writeIORef ret . Right =<< handler
let yapp = runHandler
RunHandlerEnv
{ rheRender = yesodRender site $ resolveApproot site fakeWaiRequest
@@ -233,6 +302,10 @@
, vault = mempty
, requestBodyLength = KnownLength 0
, requestHeaderRange = Nothing
+#if MIN_VERSION_wai(3,2,0)
+ , requestHeaderReferer = Nothing
+ , requestHeaderUserAgent = Nothing
+#endif
}
fakeRequest =
YesodRequest
@@ -256,7 +329,7 @@
| Just maxLen <- mmaxLen, KnownLength len <- requestBodyLength req, maxLen <
len = sendResponse tooLargeResponse
| otherwise = do
let dontSaveSession _ = return []
- (session, saveSession) <- liftIO $ do
+ (session, saveSession) <- liftIO $
maybe (return (Map.empty, dontSaveSession)) (\sb -> sbLoadSession sb
req) yreSessionBackend
maxExpires <- yreGetMaxExpires
let mkYesodReq = parseWaiRequest req session (isJust yreSessionBackend)
mmaxLen
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/yesod-core-1.4.21/Yesod/Core/Types.hs
new/yesod-core-1.4.22/Yesod/Core/Types.hs
--- old/yesod-core-1.4.21/Yesod/Core/Types.hs 2016-06-20 16:31:06.000000000
+0200
+++ new/yesod-core-1.4.22/Yesod/Core/Types.hs 2016-06-27 09:45:17.000000000
+0200
@@ -1,5 +1,6 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
@@ -41,6 +42,7 @@
import qualified Data.Text.Lazy.Builder as TBuilder
import Data.Time (UTCTime)
import Data.Typeable (Typeable)
+import GHC.Generics (Generic)
import Language.Haskell.TH.Syntax (Loc)
import qualified Network.HTTP.Types as H
import Network.Wai (FilePart,
@@ -62,6 +64,7 @@
import Prelude hiding (catch)
#endif
import Control.DeepSeq (NFData (rnf))
+import Control.DeepSeq.Generics (genericRnf)
import Data.Conduit.Lazy (MonadActive, monadActive)
import Yesod.Core.TypeCache (TypeMap, KeyedTypeMap)
#if MIN_VERSION_monad_logger(0, 3, 10)
@@ -314,7 +317,9 @@
| NotAuthenticated
| PermissionDenied Text
| BadMethod H.Method
- deriving (Show, Eq, Typeable)
+ deriving (Show, Eq, Typeable, Generic)
+instance NFData ErrorResponse where
+ rnf = genericRnf
----- header stuff
-- | Headers to be added to a 'Result'.
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/yesod-core-1.4.21/test/YesodCoreTest/Exceptions.hs
new/yesod-core-1.4.22/test/YesodCoreTest/Exceptions.hs
--- old/yesod-core-1.4.21/test/YesodCoreTest/Exceptions.hs 2016-06-20
16:31:06.000000000 +0200
+++ new/yesod-core-1.4.22/test/YesodCoreTest/Exceptions.hs 2016-06-27
09:45:17.000000000 +0200
@@ -6,6 +6,8 @@
import Test.Hspec
import Yesod.Core
+import Yesod.Core.Types (HandlerContents (HCError))
+import Control.Exception (throwIO)
import Network.Wai
import Network.Wai.Test
import Network.HTTP.Types (status301)
@@ -14,11 +16,15 @@
mkYesod "Y" [parseRoutes|
/ RootR GET
/redirect RedirR GET
+/impure ImpureR GET
|]
instance Yesod Y where
approot = ApprootStatic "http://test";
- errorHandler (InternalError e) = return $ toTypedContent e
+ errorHandler (InternalError e) = do
+ _ <- return $! e
+ addHeader "ERROR" "HANDLER"
+ return $ toTypedContent e
errorHandler x = defaultErrorHandler x
getRootR :: Handler ()
@@ -29,10 +35,14 @@
addHeader "foo" "bar"
redirectWith status301 RootR
+getImpureR :: Handler ()
+getImpureR = liftIO $ throwIO $ HCError $ InternalError $ error "impure!"
+
exceptionsTest :: Spec
exceptionsTest = describe "Test.Exceptions" $ do
it "500" case500
it "redirect keeps headers" caseRedirect
+ it "deals with impure InternalError values" caseImpure
runner :: Session () -> IO ()
runner f = toWaiApp Y >>= runSession f
@@ -48,3 +58,10 @@
res <- request defaultRequest { pathInfo = ["redirect"] }
assertStatus 301 res
assertHeader "foo" "bar" res
+
+caseImpure :: IO ()
+caseImpure = runner $ do
+ res <- request defaultRequest { pathInfo = ["impure"] }
+ assertStatus 500 res
+ assertBodyContains "impure!" res
+ assertHeader "ERROR" "HANDLER" res
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/yesod-core-1.4.21/yesod-core.cabal
new/yesod-core-1.4.22/yesod-core.cabal
--- old/yesod-core-1.4.21/yesod-core.cabal 2016-06-20 16:31:06.000000000
+0200
+++ new/yesod-core-1.4.22/yesod-core.cabal 2016-06-27 09:45:17.000000000
+0200
@@ -1,5 +1,5 @@
name: yesod-core
-version: 1.4.21
+version: 1.4.22
license: MIT
license-file: LICENSE
author: Michael Snoyman <mich...@snoyman.com>
@@ -22,7 +22,7 @@
README.md
library
- build-depends: base >= 4.3 && < 5
+ build-depends: base >= 4.6 && < 5
, time >= 1.1.4
, wai >= 3.0
, wai-extra >= 3.0.7
@@ -63,7 +63,8 @@
, unix-compat
, conduit-extra
, exceptions >= 0.6
- , deepseq
+ , deepseq >= 1.3
+ , deepseq-generics
, mwc-random
, primitive
, word8
