bf7e638 · typeable/wai

git.iko.soy/typeable/wai

on master help sign in

using http-client for testing.

bf7e638Kazu Yamamoto9 years ago

warp/test/ExceptionSpec.hs+11−11

compare with master

unifiedsplit

@@ -7,7 +7,7 @@ import Control.Applicative

7#endif

8import Control.Monad

9import Network.HTTP.Types hiding (Header)

10−import Network.Wai hiding (Response)

10+import Network.Wai hiding (Response, responseStatus)

11import Network.Wai.Internal (Request(..))

12import Network.Wai.Handler.Warp

13import Test.Hspec

@@ -49,18 +49,18 @@ spec :: 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 <- rspCode <$> sendGET "http://127.0.0.1:2345/statusError"

52+ sc <- responseStatus <$> sendGET "http://127.0.0.1:2345/statusError"

53− sc `shouldBe` (5,0,0)

53+ sc `shouldBe` internalServerError500

54 it "headersError" $ do

55− sc <- rspCode <$> sendGET "http://127.0.0.1:2345/headersError"

55+ sc <- responseStatus <$> sendGET "http://127.0.0.1:2345/headersError"

56− sc `shouldBe` (5,0,0)

56+ sc `shouldBe` internalServerError500

57 it "headerError" $ do

58− sc <- rspCode <$> sendGET "http://127.0.0.1:2345/headerError"

58+ sc <- responseStatus <$> sendGET "http://127.0.0.1:2345/headerError"

59− sc `shouldBe` (5,0,0)

59+ sc `shouldBe` internalServerError500

60 it "bodyError" $ do

61− sc <- rspCode <$> sendGET "http://127.0.0.1:2345/bodyError"

61+ sc <- responseStatus <$> sendGET "http://127.0.0.1:2345/bodyError"

62− sc `shouldBe` (5,0,0)

62+ sc `shouldBe` internalServerError500

63 -}

64 it "ioException" $ withTestServer $ \prt -> do

65− sc <- rspCode <$> sendGET ("http://127.0.0.1:" ++ show prt ++ "/ioException")

65+ sc <- responseStatus <$> sendGET ("http://127.0.0.1:" ++ show prt ++ "/ioException")

66− sc `shouldBe` (5,0,0)

66+ sc `shouldBe` internalServerError500

warp/test/HTTP.hs+26−28

@@ -1,43 +1,41 @@

1−{-# LANGUAGE StandaloneDeriving #-}

2−{-# OPTIONS_GHC -fno-warn-orphans #-}

3module HTTP (

1module HTTP (

4 sendGET

2 sendGET

5 , sendGETwH

3 , sendGETwH

6 , sendHEAD

4 , sendHEAD

7 , sendHEADwH

5 , sendHEADwH

8− , rspBody

6+ , responseBody

9− , rspCode

7+ , responseStatus

10− , rspHeaders

8+ , responseHeaders

11 , getHeaderValue

9 , getHeaderValue

12− , HeaderName(..)

10+ , HeaderName

13− , mkHeader

14 ) where

11 ) where

16−import Network.HTTP

13+import Network.HTTP.Client

17−import Network.Stream

14+import Network.HTTP.Types

15+import Data.ByteString

16+import qualified Data.ByteString.Lazy as BL

19−sendGET :: String -> IO (Response String)

18+sendGET :: String -> IO (Response BL.ByteString)

20sendGET url = sendGETwH url []

19sendGET url = sendGETwH url []

22−sendGETwH :: String -> [Header] -> IO (Response String)

21+sendGETwH :: String -> [Header] -> IO (Response BL.ByteString)

23−sendGETwH url hdr = unResult $ simpleHTTP $ (getRequest url) { rqHeaders = hdr }

22+sendGETwH url hdr = do

23+ manager <- newManager defaultManagerSettings

24+ request <- parseRequest url

25+ let request' = request { requestHeaders = hdr }

26+ response <- httpLbs request' manager

27+ return response

25−sendHEAD :: String -> IO (Response String)

29+sendHEAD :: String -> IO (Response BL.ByteString)

26sendHEAD url = sendHEADwH url []

30sendHEAD url = sendHEADwH url []

28−sendHEADwH :: String -> [Header] -> IO (Response String)

32+sendHEADwH :: String -> [Header] -> IO (Response BL.ByteString)

29−sendHEADwH url hdr = unResult $ simpleHTTP $ (headRequest url) { rqHeaders = hdr }

33+sendHEADwH url hdr = do

34+ manager <- newManager defaultManagerSettings

35+ request <- parseRequest url

36+ let request' = request { requestHeaders = hdr, method = methodHead }

37+ response <- httpLbs request' manager

38+ return response

31−unResult :: IO (Result (Response String)) -> IO (Response String)

32−unResult action = do

33− res <- action

34− case res of

35− Right rsp -> return rsp

36− Left _ -> error "Connection error"

37−

38−getHeaderValue :: HasHeaders a => HeaderName -> a -> Maybe String

40+getHeaderValue :: HeaderName -> [Header] -> Maybe ByteString

39−getHeaderValue key r = case retrieveHeaders key r of

41+getHeaderValue = lookup

40− [] -> Nothing

41− x:_ -> Just $ hdrValue x

42−

43−deriving instance Eq Header

warp/test/ResponseSpec.hs+2−2

@@ -7,7 +7,7 @@ import qualified Data.ByteString as S

7import qualified Data.ByteString.Char8 as S8

8import Data.Maybe (mapMaybe)

9import Network.HTTP.Types

10−import Network.Wai

10+import Network.Wai hiding (responseHeaders)

11import Network.Wai.Handler.Warp

12import Network.Wai.Handler.Warp.Response

13import RunSpec (withApp)

@@ -78,7 +78,7 @@ spec = do

78 let app _ respond = respond $ responseLBS status200 [("foo", "foo\r\nbar")] "Hello"

79 withApp defaultSettings app $ \port -> do

80 res <- sendGET $ "http://127.0.0.1:" ++ show port

81− getHeaderValue (HdrCustom "foo") res `shouldBe`

81+ getHeaderValue "foo" (responseHeaders res) `shouldBe`

82 Just "foo bar" -- HTTP inserts two spaces for \r\n.

84 describe "sanitizeHeaderValue" $ do

warp/test/RunSpec.hs+9−9

@@ -20,7 +20,7 @@ import Data.Streaming.Network (bindPortTCP, getSocketTCP, safeRecv)

20import Network.HTTP.Types

21import Network.Socket

22import Network.Socket.ByteString (sendAll)

23−import Network.Wai

23+import Network.Wai hiding (responseHeaders)

24import Network.Wai.Handler.Warp

25import System.IO (hFlush, hClose, Handle, IOMode(..))

26import System.IO.Unsafe (unsafePerformIO)

@@ -358,8 +358,8 @@ spec = do

358 ] ""

359 withApp defaultSettings app $ \port -> do

360 res <- sendGET $ "http://127.0.0.1:" ++ show port

361− getHeaderValue HdrServer res `shouldBe` Just "server"

361+ getHeaderValue hServer (responseHeaders res) `shouldBe` Just "server"

362− getHeaderValue HdrDate res `shouldBe` Just "date"

362+ getHeaderValue hDate (responseHeaders res) `shouldBe` Just "date"

363

364 it "streaming echo #249" $ do

365 let app req f = f $ responseStream status200 [] $ \write _ -> do

@@ -382,7 +382,7 @@ spec = do

382 replicateM_ 4 $ write $ byteString "Hello"

383 withApp defaultSettings app $ \port -> do

384 res <- sendGET $ "http://127.0.0.1:" ++ show port

385− rspBody res `shouldBe` "HelloHelloHelloHello"

385+ responseBody res `shouldBe` "HelloHelloHelloHello"

386

387 describe "head requests" $ do

388 let fp = "test/head-response"

@@ -395,19 +395,19 @@ spec = do

395 _ -> error "invalid path"

396 it "builder" $ withApp defaultSettings app $ \port -> do

397 res <- sendHEAD $ concat ["http://127.0.0.1:", show port, "/builder"]

398− rspBody res `shouldBe` ""

398+ responseBody res `shouldBe` ""

399 it "streaming" $ withApp defaultSettings app $ \port -> do

400 res <- sendHEAD $ concat ["http://127.0.0.1:", show port, "/streaming"]

401− rspBody res `shouldBe` ""

401+ responseBody res `shouldBe` ""

402 it "file, no range" $ withApp defaultSettings app $ \port -> do

403 bs <- S.readFile fp

404 res <- sendHEAD $ concat ["http://127.0.0.1:", show port, "/file"]

405− getHeaderValue HdrContentLength res `shouldBe` Just (show $ S.length bs)

405+ getHeaderValue hContentLength (responseHeaders res) `shouldBe` Just (S8.pack $ show $ S.length bs)

406 it "file, with range" $ withApp defaultSettings app $ \port -> do

407 res <- sendHEADwH

408 (concat ["http://127.0.0.1:", show port, "/file"])

409− [mkHeader HdrRange "bytes=0-1"]

409+ [(hRange, "bytes=0-1")]

410− getHeaderValue HdrContentLength res `shouldBe` Just "2"

410+ getHeaderValue hContentLength (responseHeaders res) `shouldBe` Just "2"

411

412consumeBody :: IO ByteString -> IO [ByteString]

413consumeBody body =

warp/warp.cabal+1−1

@@ -185,7 +185,7 @@ Test-Suite spec

185 , bytestring >= 0.9.1.4

186 , case-insensitive >= 0.2

187 , ghc-prim

188− , HTTP

188+ , http-client

189 , http-types >= 0.8.5

190 , iproute >= 1.3.1

191 , lifted-base >= 0.1