git.iko.soy/typeable/wai
on wai-app-static/2.0.0.1 help sign in
typeable/wai/warp/test/ExceptionSpec.hs
72 lines 2.4 kB history raw
1{-# LANGUAGE OverloadedStrings #-}
3module ExceptionSpec (main, spec) where
5import Control.Applicative
6import Control.Monad
7import Control.Concurrent (forkIO, threadDelay)
8import Network.HTTP
9import Network.Stream
10import Network.HTTP.Types hiding (Header)
11import Network.Wai hiding (Response)
12import Network.Wai.Internal (Request(..))
13import Network.Wai.Handler.Warp
14import System.IO.Unsafe (unsafePerformIO)
15import Test.Hspec
17main :: IO ()
18main = hspec spec
20testServer :: IO ()
21testServer =
22 run 2345 testApp
24testApp :: Application
25testApp (Network.Wai.Internal.Request {pathInfo = [x]})
26 | x == "statusError" =
27 return $ responseLBS undefined [] "foo"
28 | x == "headersError" =
29 return $ responseLBS ok200 undefined "foo"
30 | x == "headerError" =
31 return $ responseLBS ok200 [undefined] "foo"
32 | x == "bodyError" =
33 return $ responseLBS ok200 [] undefined
34 | x == "ioException" = do
35 void $ fail "ioException"
36 return $ responseLBS ok200 [] "foo"
37testApp _ =
38 return $ responseLBS ok200 [] "foo"
40spec :: Spec
41spec = unsafePerformIO $ (forkIO testServer >> threadDelay 100000 >>) $ return $
42 describe "responds even if there is an exception" $ do
43 it "statusError" $ do
44 sc <- rspCode <$> sendGET "http://localhost:2345/statusError"
45 sc `shouldBe` (5,0,0)
46 it "headersError" $ do
47 sc <- rspCode <$> sendGET "http://localhost:2345/headersError"
48 sc `shouldBe` (5,0,0)
49 it "headerError" $ do
50 sc <- rspCode <$> sendGET "http://localhost:2345/headerError"
51 sc `shouldBe` (5,0,0)
52 it "bodyError" $ do
53 sc <- rspCode <$> sendGET "http://localhost:2345/bodyError"
54 sc `shouldBe` (5,0,0)
55 it "ioException" $ do
56 sc <- rspCode <$> sendGET "http://localhost:2345/ioException"
57 sc `shouldBe` (5,0,0)
59----------------------------------------------------------------
61sendGET :: String -> IO (Response String)
62sendGET url = sendGETwH url []
64sendGETwH :: String -> [Header] -> IO (Response String)
65sendGETwH url hdr = unResult $ simpleHTTP $ (getRequest url) { rqHeaders = hdr }
67unResult :: IO (Result (Response String)) -> IO (Response String)
68unResult action = do
69 res <- action
70 case res of
71 Right rsp -> return rsp
72 Left _ -> error "Connection error"