wai/warp/test/ExceptionSpec.hs

{-# LANGUAGE OverloadedStrings #-}

module ExceptionSpec (main, spec) where

import Control.Applicative
import Control.Monad
import Control.Concurrent (forkIO, threadDelay)
import Network.HTTP
import Network.Stream
import Network.HTTP.Types hiding (Header)
import Network.Wai hiding (Response)
import Network.Wai.Internal (Request(..))
import Network.Wai.Handler.Warp
import System.IO.Unsafe (unsafePerformIO)
import Test.Hspec
import Control.Exception
import qualified Data.Streaming.Network as N
import Control.Concurrent.Async (withAsync)
import Network.Socket (sClose)

main :: IO ()
main = hspec spec

withTestServer :: (Int -> IO a) -> IO a
withTestServer inner = bracket
    (N.bindRandomPortTCP "*4")
    (sClose . snd)
    $ \(port, lsocket) -> do
        withAsync (runSettingsSocket defaultSettings lsocket testApp)
            $ \_ -> inner port

testApp :: Application
testApp (Network.Wai.Internal.Request {pathInfo = [x]}) f
    | x == "statusError" =
        f $ responseLBS undefined [] "foo"
    | x == "headersError" =
        f $ responseLBS ok200 undefined "foo"
    | x == "headerError" =
        f $ responseLBS ok200 [undefined] "foo"
    | x == "bodyError" =
        f $ responseLBS ok200 [] undefined
    | x == "ioException" = do
        void $ fail "ioException"
        f $ responseLBS ok200 [] "foo"
testApp _ f =
        f $ responseLBS ok200 [] "foo"

spec :: Spec
spec = describe "responds even if there is an exception" $ do
        {- Disabling these tests. We can consider forcing evaluation in Warp.
        it "statusError" $ do
            sc <- rspCode <$> sendGET "http://localhost:2345/statusError"
            sc `shouldBe` (5,0,0)
        it "headersError" $ do
            sc <- rspCode <$> sendGET "http://localhost:2345/headersError"
            sc `shouldBe` (5,0,0)
        it "headerError" $ do
            sc <- rspCode <$> sendGET "http://localhost:2345/headerError"
            sc `shouldBe` (5,0,0)
        it "bodyError" $ do
            sc <- rspCode <$> sendGET "http://localhost:2345/bodyError"
            sc `shouldBe` (5,0,0)
        -}
        it "ioException" $ withTestServer $ \port -> do
            sc <- rspCode <$> sendGET (concat $ ["http://localhost:", show port, "/ioException"])
            sc `shouldBe` (5,0,0)

----------------------------------------------------------------

sendGET :: String -> IO (Response String)
sendGET url = sendGETwH url []

sendGETwH :: String -> [Header] -> IO (Response String)
sendGETwH url hdr = unResult $ simpleHTTP $ (getRequest url) { rqHeaders = hdr }

unResult :: IO (Result (Response String)) -> IO (Response String)
unResult action = do
    res <- action
    case res of
        Right rsp -> return rsp
        Left _ -> error "Connection error"