1{-# LANGUAGE OverloadedStrings, CPP #-} 2 3module ExceptionSpec (main, spec) where 4 5#if __GLASGOW_HASKELL__ < 709 6import Control.Applicative 7#endif 8import Control.Monad 9import Network.HTTP.Types hiding (Header) 10import Network.Wai hiding (Response, responseStatus) 11import Network.Wai.Internal (Request(..)) 12import Network.Wai.Handler.Warp 13import Test.Hspec 14import Control.Exception 15import qualified Data.Streaming.Network as N 16import Control.Concurrent.Async (withAsync) 17import Network.Socket (close) 18 19import HTTP 20 21main :: IO () 22main = hspec spec 23 24withTestServer :: (Int -> IO a) -> IO a 25withTestServer inner = bracket 26 (N.bindRandomPortTCP "127.0.0.1") 27 (close . snd) 28 $ \(prt, lsocket) -> do 29 withAsync (runSettingsSocket defaultSettings lsocket testApp) 30 $ \_ -> inner prt 31 32testApp :: Application 33testApp (Network.Wai.Internal.Request {pathInfo = [x]}) f 34 | x == "statusError" = 35 f $ responseLBS undefined [] "foo" 36 | x == "headersError" = 37 f $ responseLBS ok200 undefined "foo" 38 | x == "headerError" = 39 f $ responseLBS ok200 [undefined] "foo" 40 | x == "bodyError" = 41 f $ responseLBS ok200 [] undefined 42 | x == "ioException" = do 43 void $ fail "ioException" 44 f $ responseLBS ok200 [] "foo" 45testApp _ f = 46 f $ responseLBS ok200 [] "foo" 47 48spec :: Spec 49spec = describe "responds even if there is an exception" $ do 50 {- Disabling these tests. We can consider forcing evaluation in Warp. 51 it "statusError" $ do 52 sc <- responseStatus <$> sendGET "http://127.0.0.1:2345/statusError" 53 sc `shouldBe` internalServerError500 54 it "headersError" $ do 55 sc <- responseStatus <$> sendGET "http://127.0.0.1:2345/headersError" 56 sc `shouldBe` internalServerError500 57 it "headerError" $ do 58 sc <- responseStatus <$> sendGET "http://127.0.0.1:2345/headerError" 59 sc `shouldBe` internalServerError500 60 it "bodyError" $ do 61 sc <- responseStatus <$> sendGET "http://127.0.0.1:2345/bodyError" 62 sc `shouldBe` internalServerError500 63 -} 64 it "ioException" $ withTestServer $ \prt -> do 65 sc <- responseStatus <$> sendGET ("http://127.0.0.1:" ++ show prt ++ "/ioException") 66 sc `shouldBe` internalServerError500 67