bf7e638 · typeable/wai

git.iko.soy/typeable/wai

using http-client for testing.

commitbf7e638af70f8cf9d44c60a95687f02a51c3733b authorKazu Yamamoto <kazu@iij.ad.jp> dateFri 19 Jan 2018, 16:39 (9 years ago) parentb294f85

5 files changed+49−51

compare with master

unifiedsplit

warp/test/ExceptionSpec.hs+11−11 warp/test/HTTP.hs+26−28 warp/test/ResponseSpec.hs+2−2 warp/test/RunSpec.hs+9−9 warp/warp.cabal+1−1

warp/test/ExceptionSpec.hs+11−11

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

77#endif

88import Control.Monad

99import Network.HTTP.Types hiding (Header)

10−import Network.Wai hiding (Response)

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

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

1212import Network.Wai.Handler.Warp

1313import Test.Hspec

@@ -49,18 +49,18 @@ spec :: Spec

4949spec = describe "responds even if there is an exception" $ do

5050 {- Disabling these tests. We can consider forcing evaluation in Warp.

5151 it "statusError" $ do

52− sc <- rspCode <$> sendGET "http://127.0.0.1:2345/statusError"

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

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

53+ sc `shouldBe` internalServerError500

5454 it "headersError" $ do

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

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

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

56+ sc `shouldBe` internalServerError500

5757 it "headerError" $ do

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

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

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

59+ sc `shouldBe` internalServerError500

6060 it "bodyError" $ do

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

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

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

62+ sc `shouldBe` internalServerError500

6363 -}

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

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

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

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

66+ sc `shouldBe` internalServerError500

warp/test/HTTP.hs+26−28

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

1−{-# LANGUAGE StandaloneDeriving #-}

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

31module HTTP (

42 sendGET

53 , sendGETwH

64 , sendHEAD

75 , sendHEADwH

8− , rspBody

9− , rspCode

10− , rspHeaders

6+ , responseBody

7+ , responseStatus

8+ , responseHeaders

119 , getHeaderValue

12− , HeaderName(..)

13− , mkHeader

10+ , HeaderName

1411 ) where

1512

16−import Network.HTTP

17−import Network.Stream

13+import Network.HTTP.Client

14+import Network.HTTP.Types

15+import Data.ByteString

16+import qualified Data.ByteString.Lazy as BL

1817

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

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

2019sendGET url = sendGETwH url []

2120

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

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

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

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

2428

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

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

2630sendHEAD url = sendHEADwH url []

2731

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

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

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

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

3039

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

39−getHeaderValue key r = case retrieveHeaders key r of

40− [] -> Nothing

41− x:_ -> Just $ hdrValue x

42−

43−deriving instance Eq Header

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

41+getHeaderValue = lookup

warp/test/ResponseSpec.hs+2−2

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

77import qualified Data.ByteString.Char8 as S8

88import Data.Maybe (mapMaybe)

99import Network.HTTP.Types

10−import Network.Wai

10+import Network.Wai hiding (responseHeaders)

1111import Network.Wai.Handler.Warp

1212import Network.Wai.Handler.Warp.Response

1313import RunSpec (withApp)

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

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

7979 withApp defaultSettings app $ \port -> do

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

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

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

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

8383

8484 describe "sanitizeHeaderValue" $ do

warp/test/RunSpec.hs+9−9

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

2020import Network.HTTP.Types

2121import Network.Socket

2222import Network.Socket.ByteString (sendAll)

23−import Network.Wai

23+import Network.Wai hiding (responseHeaders)

2424import Network.Wai.Handler.Warp

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

2626import System.IO.Unsafe (unsafePerformIO)

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

358358 ] ""

359359 withApp defaultSettings app $ \port -> do

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

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

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

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

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

363363

364364 it "streaming echo #249" $ do

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

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

382382 replicateM_ 4 $ write $ byteString "Hello"

383383 withApp defaultSettings app $ \port -> do

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

385− rspBody res `shouldBe` "HelloHelloHelloHello"

385+ responseBody res `shouldBe` "HelloHelloHelloHello"

386386

387387 describe "head requests" $ do

388388 let fp = "test/head-response"

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

395395 _ -> error "invalid path"

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

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

398− rspBody res `shouldBe` ""

398+ responseBody res `shouldBe` ""

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

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

401− rspBody res `shouldBe` ""

401+ responseBody res `shouldBe` ""

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

403403 bs <- S.readFile fp

404404 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)

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

407407 res <- sendHEADwH

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

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

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

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

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

411411

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

413413consumeBody body =

warp/warp.cabal+1−1

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

185185 , bytestring >= 0.9.1.4

186186 , case-insensitive >= 0.2

187187 , ghc-prim

188− , HTTP

188+ , http-client

189189 , http-types >= 0.8.5

190190 , iproute >= 1.3.1

191191 , lifted-base >= 0.1