diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -119,7 +119,6 @@ import Data.Time (UTCTime) import Control.Exception hiding (Handler, catch, finally) -import qualified Control.Exception as E import Control.Applicative import Control.Monad (liftM, join, MonadPlus) @@ -164,6 +163,7 @@ import Yesod.Message (RenderMessage (..)) import Text.Blaze (toHtml, preEscapedText) +import Yesod.Internal.TestApi (catchIter) -- | The type-safe URLs associated with a site argument. type family Route a @@ -419,12 +419,6 @@ emptyContent finalSession HCWai r -> return $ YARWai r - -catchIter :: Exception e - => Iteratee ByteString IO a - -> (e -> Iteratee ByteString IO a) - -> Iteratee ByteString IO a -catchIter (Iteratee mstep) f = Iteratee $ mstep `E.catch` (runIteratee . f) safeEh :: ErrorResponse -> YesodApp safeEh er = YesodApp $ \_ _ _ session -> do diff --git a/Yesod/Internal/TestApi.hs b/Yesod/Internal/TestApi.hs --- a/Yesod/Internal/TestApi.hs +++ b/Yesod/Internal/TestApi.hs @@ -6,6 +6,22 @@ -- module Yesod.Internal.TestApi ( randomString, parseWaiRequest' + , catchIter ) where import Yesod.Internal.Request (randomString, parseWaiRequest') +import Control.Exception (Exception, catch) +import Data.Enumerator (Iteratee (..), Step (..)) +import Data.ByteString (ByteString) +import Prelude hiding (catch) + +catchIter :: Exception e + => Iteratee ByteString IO a + -> (e -> Iteratee ByteString IO a) + -> Iteratee ByteString IO a +catchIter (Iteratee mstep) f = Iteratee $ do + step <- mstep `catch` (runIteratee . f) + return $ case step of + Continue k -> Continue $ \s -> catchIter (k s) f + Yield b s -> Yield b s + Error e -> Error e diff --git a/test/Test/ErrorHandling.hs b/test/Test/ErrorHandling.hs new file mode 100644 --- /dev/null +++ b/test/Test/ErrorHandling.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-} +module Test.ErrorHandling + ( errorHandlingTest + , Widget + ) where +import Yesod.Core +import Test.Hspec +import Test.Hspec.HUnit() +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 Yesod.Internal.TestApi +import qualified Data.Enumerator as E +import qualified Data.Enumerator.List as EL +import Control.Exception (SomeException) + +data App = App + +mkYesod "App" [parseRoutes| +/ HomeR GET +/not_found NotFoundR POST +/first_thing FirstThingR POST +/after_runRequestBody AfterRunRequestBodyR POST +|] + +instance Yesod App where approot _ = "" + +getHomeR :: Handler RepHtml +getHomeR = defaultLayout $ toWidget [hamlet| +!!! + + + +
+ + + + + +|] + +postNotFoundR, postFirstThingR, postAfterRunRequestBodyR :: Handler RepHtml +postNotFoundR = do + (_, _files) <- runRequestBody + _ <- notFound + getHomeR + +postFirstThingR = do + _ <- error "There was an error 3.14159" + getHomeR + +postAfterRunRequestBodyR = do + x <- runRequestBody + _ <- error $ show x + getHomeR + +errorHandlingTest :: [Spec] +errorHandlingTest = describe "Test.ErrorHandling" + [ it "says not found" caseNotFound + , it "says 'There was an error' before runRequestBody" caseBefore + , it "says 'There was an error' after runRequestBody" caseAfter + , it "catchIter handles internal exceptions" caseCatchIter + ] + +runner :: Session () -> IO () +runner f = toWaiApp App >>= runSession f + +caseNotFound :: IO () +caseNotFound = runner $ do + res <- request defaultRequest + { pathInfo = ["not_found"] + , requestMethod = "POST" + } + assertStatus 404 res + assertBodyContains "Not Found" res + +caseBefore :: IO () +caseBefore = runner $ do + res <- request defaultRequest + { pathInfo = ["first_thing"] + , requestMethod = "POST" + } + assertStatus 500 res + assertBodyContains "There was an error 3.14159" res + +caseAfter :: IO () +caseAfter = runner $ do + let content = "foo=bar&baz=bin12345" + res <- srequest SRequest + { simpleRequest = defaultRequest + { pathInfo = ["after_runRequestBody"] + , requestMethod = "POST" + , requestHeaders = + [ ("content-type", "application/x-www-form-urlencoded") + , ("content-length", S8.pack $ show $ L.length content) + ] + } + , simpleRequestBody = content + } + assertStatus 500 res + assertBodyContains "bin12345" res + +caseCatchIter :: IO () +caseCatchIter = E.run_ $ E.enumList 8 (replicate 1000 "foo") E.$$ flip catchIter ignorer $ do + _ <- EL.consume + error "foo" + where + ignorer :: SomeException -> E.Iteratee a IO () + ignorer _ = return () diff --git a/test/main.hs b/test/main.hs --- a/test/main.hs +++ b/test/main.hs @@ -7,6 +7,7 @@ import Test.Links import Test.NoOverloadedStrings import Test.InternalRequest +import Test.ErrorHandling main :: IO () main = hspecX $ descriptions $ @@ -17,4 +18,5 @@ , linksTest , noOverloadedTest , internalRequestTest + , errorHandlingTest ] diff --git a/yesod-core.cabal b/yesod-core.cabal --- a/yesod-core.cabal +++ b/yesod-core.cabal @@ -1,5 +1,5 @@ name: yesod-core -version: 0.9.3.1 +version: 0.9.3.2 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -23,6 +23,7 @@ test/Test/CleanPath.hs test/Test/Links.hs test/Test/InternalRequest.hs + test/Test/ErrorHandling.hs test/main.hs flag test @@ -107,8 +108,8 @@ build-depends: base >= 4 && < 4.3 main-is: main.hs cpp-options: -DTEST - build-depends: hspec >= 0.8 && < 0.9 - ,wai-test + build-depends: hspec >= 0.8 && < 0.10 + ,wai-test >= 0.1.2 && < 0.2 ,wai ,yesod-core ,bytestring @@ -120,6 +121,7 @@ , random ,HUnit ,QuickCheck >= 2 && < 3 + , enumerator ghc-options: -Wall source-repository head