yesod-core 1.2.12 → 1.2.13
raw patch · 4 files changed
+65/−10 lines, 4 filesdep +deepseqdep ~cookie
Dependencies added: deepseq
Dependency ranges changed: cookie
Files
- Yesod/Core/Internal/Run.hs +22/−8
- Yesod/Core/Types.hs +16/−0
- test/YesodCoreTest/ErrorHandling.hs +24/−0
- yesod-core.cabal +3/−2
Yesod/Core/Internal/Run.hs view
@@ -13,6 +13,7 @@ import Control.Exception (fromException, bracketOnError, 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.Logger (LogLevel (LevelError), LogSource,@@ -48,6 +49,7 @@ import Yesod.Core.Internal.Request (parseWaiRequest, tooLargeResponse) import Yesod.Routes.Class (Route, renderRoute)+import Control.DeepSeq (($!!)) -- | Function used internally by Yesod in the process of converting a -- 'HandlerT' into an 'Application'. Should not be needed by users.@@ -78,23 +80,35 @@ (\e -> return $ Left $ maybe (HCError $ toErrorHandler e) id $ fromException e) state <- liftIO $ I.readIORef istate- let finalSession = ghsSession state- let headers = ghsHeaders state- let contents = either id (HCContent defaultStatus . toTypedContent) contents'++ (finalSession, mcontents1) <- (do+ finalSession <- return $!! 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' = appEndo headers hs+ let hs' = headers ++ hs status | status' == defaultStatus = getStatus e | otherwise = status' in return $ YRPlain status hs' ct c sess YRWai _ -> return yar let sendFile' ct fp p =- return $ YRPlain H.status200 (appEndo headers []) ct (ContentFile fp p) finalSession+ 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@@ -102,7 +116,7 @@ ec' <- liftIO $ evaluateContent c case ec' of Left e -> handleError e- Right c' -> return $ YRPlain status (appEndo headers []) ct c' finalSession+ Right c' -> return $ YRPlain status headers ct c' finalSession HCError e -> handleError e HCRedirect status loc -> do let disable_caching x =@@ -110,7 +124,7 @@ : Header "Expires" "Thu, 01 Jan 1970 05:05:05 GMT" : x hs = (if status /= H.movedPermanently301 then disable_caching else id)- $ Header "Location" (encodeUtf8 loc) : appEndo headers []+ $ Header "Location" (encodeUtf8 loc) : headers return $ YRPlain status hs typePlain emptyContent finalSession@@ -118,7 +132,7 @@ (sendFile' ct fp p) (handleError . toErrorHandler) HCCreated loc -> do- let hs = Header "Location" (encodeUtf8 loc) : appEndo headers []+ let hs = Header "Location" (encodeUtf8 loc) : headers return $ YRPlain H.status201 hs
Yesod/Core/Types.hs view
@@ -64,6 +64,7 @@ import Yesod.Routes.Class (RenderRoute (..), ParseRoute (..)) import Control.Monad.Reader (MonadReader (..)) import Prelude hiding (catch)+import Control.DeepSeq (NFData (rnf)) -- Sessions type SessionMap = Map Text ByteString@@ -312,6 +313,14 @@ | Header ByteString ByteString deriving (Eq, Show) +-- FIXME In the next major version bump, let's just add strictness annotations+-- to Header (and probably everywhere else). We can also add strictness+-- annotations to SetCookie in the cookie package.+instance NFData Header where+ rnf (AddCookie x) = rnf x+ rnf (DeleteCookie x y) = rnf x `seq` rnf y+ rnf (Header x y) = rnf x `seq` rnf y+ data Location url = Local url | Remote Text deriving (Show, Eq) @@ -415,6 +424,13 @@ uninterruptibleMask a = HandlerT $ \e -> uninterruptibleMask $ \u -> unHandlerT (a $ q u) e where q u (HandlerT b) = HandlerT (u . b)+instance MonadCatch m => MonadCatch (WidgetT site m) where+ catch (WidgetT m) c = WidgetT $ \r -> m r `catch` \e -> unWidgetT (c e) r+ mask a = WidgetT $ \e -> mask $ \u -> unWidgetT (a $ q u) e+ where q u (WidgetT b) = WidgetT (u . b)+ uninterruptibleMask a =+ WidgetT $ \e -> uninterruptibleMask $ \u -> unWidgetT (a $ q u) e+ where q u (WidgetT b) = WidgetT (u . b) #else monadThrow = lift . monadThrow #endif
test/YesodCoreTest/ErrorHandling.hs view
@@ -15,6 +15,9 @@ import Network.HTTP.Types (mkStatus) import Blaze.ByteString.Builder (Builder, fromByteString, toLazyByteString) import Data.Monoid (mconcat)+import Data.Text (Text, pack)+import Control.Monad (forM_)+import qualified Control.Exception.Lifted as E data App = App @@ -26,6 +29,7 @@ /error-in-body ErrorInBodyR GET /error-in-body-noeval ErrorInBodyNoEvalR GET /override-status OverrideStatusR GET+/error/#Int ErrorR GET -- https://github.com/yesodweb/yesod/issues/658 /builder BuilderR GET@@ -98,6 +102,18 @@ getGoodBuilderR :: Handler TypedContent getGoodBuilderR = return $ TypedContent "text/plain" $ toContent goodBuilderContent +getErrorR :: Int -> Handler ()+getErrorR 1 = setSession undefined "foo"+getErrorR 2 = setSession "foo" undefined+getErrorR 3 = deleteSession undefined+getErrorR 4 = addHeader undefined "foo"+getErrorR 5 = addHeader "foo" undefined+getErrorR 6 = expiresAt undefined+getErrorR 7 = setLanguage undefined+getErrorR 8 = cacheSeconds undefined+getErrorR 9 = setUltDest (undefined :: Text)+getErrorR 10 = setMessage undefined+ errorHandlingTest :: Spec errorHandlingTest = describe "Test.ErrorHandling" $ do it "says not found" caseNotFound@@ -110,6 +126,7 @@ it "file with bad len" caseFileBadLen it "file with bad name" caseFileBadName it "builder includes content-length" caseGoodBuilder+ forM_ [1..10] $ \i -> it ("error case " ++ show i) (caseError i) runner :: Session () -> IO () runner f = toWaiApp App >>= runSession f@@ -194,3 +211,10 @@ let lbs = toLazyByteString goodBuilderContent assertBody lbs res assertHeader "content-length" (S8.pack $ show $ L.length lbs) res++caseError :: Int -> IO ()+caseError i = runner $ do+ res <- request defaultRequest { pathInfo = ["error", pack $ show i] }+ assertStatus 500 res `E.catch` \e -> do+ liftIO $ print res+ E.throwIO (e :: E.SomeException)
yesod-core.cabal view
@@ -1,5 +1,5 @@ name: yesod-core-version: 1.2.12+version: 1.2.13 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -47,7 +47,7 @@ , containers >= 0.2 , monad-control >= 0.3 && < 0.4 , transformers-base >= 0.4- , cookie >= 0.4 && < 0.5+ , cookie >= 0.4.1 && < 0.5 , http-types >= 0.7 , case-insensitive >= 0.2 , parsec >= 2 && < 3.2@@ -69,6 +69,7 @@ , unix-compat , conduit-extra , exceptions+ , deepseq exposed-modules: Yesod.Core Yesod.Core.Content