dd9f0d2 · typeable/wai

git.iko.soy/typeable/wai

Merge "no more Network and getting http-client back".

commitdd9f0d201b3baf8867713b8a22b6166a0bee40e7 authorKazu Yamamoto <kazu@iij.ad.jp> dateFri 19 Jan 2018, 16:40 (9 years ago) parent0033a3d bf7e638

8 files changed+88−78

compare with master

unifiedsplit

warp/Network/Wai/Handler/Warp/Run.hs+1−2 warp/Network/Wai/Handler/Warp/WithApplication.hs+7−3 warp/test/ExceptionSpec.hs+11−11 warp/test/HTTP.hs+26−28 warp/test/ResponseSpec.hs+5−5 warp/test/RunSpec.hs+35−28 warp/test/WithApplicationSpec.hs+2 warp/warp.cabal+1−1

warp/Network/Wai/Handler/Warp/Run.hs+1−2

@@ -19,8 +19,7 @@ import Data.IORef (IORef, newIORef, readIORef, writeIORef, atomicModifyIORef')

1919import Data.Streaming.Network (bindPortTCP)

2020import Foreign.C.Error (Errno(..), eCONNABORTED)

2121import GHC.IO.Exception (IOException(..))

22−import Network (Socket)

23−import Network.Socket (close, accept, withSocketsDo, SockAddr(SockAddrInet, SockAddrInet6), setSocketOption, SocketOption(..))

22+import Network.Socket (Socket, close, accept, withSocketsDo, SockAddr(SockAddrInet, SockAddrInet6), setSocketOption, SocketOption(..))

2423import qualified Network.Socket.ByteString as Sock

2524import Network.Wai

2625import Network.Wai.Internal (ResponseReceived (ResponseReceived))

warp/Network/Wai/Handler/Warp/WithApplication.hs+7−3

@@ -94,9 +94,13 @@ mkWaiter = do

9494-- @since 3.2.4

9595openFreePort :: IO (Port, Socket)

9696openFreePort = do

97− s <- socket AF_INET Stream defaultProtocol

98− localhost <- inet_addr "127.0.0.1"

99− bind s (SockAddrInet aNY_PORT localhost)

97+ let hints = defaultHints {

98+ addrFlags = [AI_PASSIVE]

99+ , addrSocketType = Stream

100+ }

101+ addr:_ <- getAddrInfo (Just hints) (Just "127.0.0.1") Nothing

102+ s <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)

103+ bind s $ addrAddress addr

100104 listen s 1

101105 port <- socketPort s

102106 return (fromIntegral port, s)

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+5−5

@@ -6,9 +6,8 @@ import Control.Concurrent (threadDelay)

66import qualified Data.ByteString as S

77import qualified Data.ByteString.Char8 as S8

88import Data.Maybe (mapMaybe)

9−import Network (connectTo, PortID (PortNumber))

109import Network.HTTP.Types

11−import Network.Wai

10+import Network.Wai hiding (responseHeaders)

1211import Network.Wai.Handler.Warp

1312import Network.Wai.Handler.Warp.Response

1413import RunSpec (withApp)

@@ -16,6 +15,7 @@ import System.IO (hClose, hFlush)

1615import Test.Hspec

1716

1817import HTTP

18+import RunSpec (connectTo)

1919

2020main :: IO ()

2121main = hspec spec

@@ -25,7 +25,7 @@ testRange :: S.ByteString -- ^ range value

2525 -> Maybe String -- ^ expected content-range value

2626 -> Spec

2727testRange range out crange = it title $ withApp defaultSettings app $ \port -> do

28− handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port

28+ handle <- connectTo "127.0.0.1" port

2929 S.hPutStr handle "GET / HTTP/1.0\r\n"

3030 S.hPutStr handle "Range: bytes="

3131 S.hPutStr handle range

@@ -52,7 +52,7 @@ testPartial :: Integer -- ^ file size

5252 -> String -- ^ expected output

5353 -> Spec

5454testPartial size offset count out = it title $ withApp defaultSettings app $ \port -> do

55− handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port

55+ handle <- connectTo "127.0.0.1" port

5656 S.hPutStr handle "GET / HTTP/1.0\r\n\r\n"

5757 hFlush handle

5858 threadDelay 10000

@@ -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+35−28

@@ -2,7 +2,7 @@

22{-# LANGUAGE OverloadedStrings #-}

33{-# LANGUAGE ScopedTypeVariables #-}

5−module RunSpec (main, spec, withApp) where

5+module RunSpec (main, spec, withApp, connectTo) where

77import Control.Concurrent (forkIO, killThread, threadDelay)

88import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar)

@@ -17,13 +17,12 @@ import qualified Data.ByteString.Char8 as S8

1717import qualified Data.ByteString.Lazy as L

1818import qualified Data.IORef as I

1919import Data.Streaming.Network (bindPortTCP, getSocketTCP, safeRecv)

20−import Network (connectTo, PortID (PortNumber))

2120import Network.HTTP.Types

22−import Network.Socket (close)

21+import Network.Socket

2322import Network.Socket.ByteString (sendAll)

24−import Network.Wai

23+import Network.Wai hiding (responseHeaders)

2524import Network.Wai.Handler.Warp

26−import System.IO (hFlush, hClose)

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

2726import System.IO.Unsafe (unsafePerformIO)

2827import System.Timeout (timeout)

2928import Test.Hspec

@@ -36,6 +35,14 @@ main = hspec spec

3635type Counter = I.IORef (Either String Int)

3736type CounterApplication = Counter -> Application

3837

38+connectTo :: HostName -> Int -> IO Handle

39+connectTo host port = do

40+ let hints = defaultHints { addrSocketType = Stream }

41+ addr:_ <- getAddrInfo (Just hints) (Just host) (Just $ show port)

42+ sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)

43+ connect sock $ addrAddress addr

44+ socketToHandle sock ReadWriteMode

45+

3946incr :: MonadIO m => Counter -> m ()

4047incr icount = liftIO $ I.atomicModifyIORef icount $ \ecount ->

4148 ((case ecount of

@@ -83,8 +90,8 @@ getPort = do

8390 esocket <- try $ bindPortTCP port "127.0.0.1"

8491 case esocket of

8592 Left (_ :: IOException) -> RunSpec.getPort

86− Right socket -> do

87− close socket

93+ Right sock -> do

94+ close sock

8895 return port

8996

9097withApp :: Settings -> Application -> (Int -> IO a) -> IO a

@@ -107,7 +114,7 @@ runTest :: Int -- ^ expected number of requests

107114runTest expected app chunks = do

108115 ref <- I.newIORef (Right 0)

109116 withApp defaultSettings (app ref) $ \port -> do

110− handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port

117+ handle <- connectTo "127.0.0.1" port

111118 forM_ chunks $ \chunk -> hPutStr handle chunk >> hFlush handle

112119 _ <- timeout 100000 $ replicateM_ expected $ hGetSome handle 4096

113120 res <- I.readIORef ref

@@ -125,7 +132,7 @@ runTerminateTest expected input = do

125132 ref <- I.newIORef Nothing

126133 let onExc _ = I.writeIORef ref . Just

127134 withApp (setOnException onExc defaultSettings) dummyApp $ \port -> do

128− handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port

135+ handle <- connectTo "127.0.0.1" port

129136 hPutStr handle input

130137 hFlush handle

131138 hClose handle

@@ -200,7 +207,7 @@ spec = do

200207 liftIO $ I.writeIORef iheaders $ requestHeaders req

201208 f $ responseLBS status200 [] ""

202209 withApp defaultSettings app $ \port -> do

203− handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port

210+ handle <- connectTo "127.0.0.1" port

204211 let input = S.concat

205212 [ "GET / HTTP/1.1\r\nfoo: bar\r\n baz\r\n\tbin\r\n\r\n"

206213 ]

@@ -218,7 +225,7 @@ spec = do

218225 liftIO $ I.writeIORef iheaders $ requestHeaders req

219226 f $ responseLBS status200 [] ""

220227 withApp defaultSettings app $ \port -> do

221− handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port

228+ handle <- connectTo "127.0.0.1" port

222229 let input = S.concat

223230 [ "GET / HTTP/1.1\r\nfoo:bar\r\n\r\n"

224231 ]

@@ -239,7 +246,7 @@ spec = do

239246 liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())

240247 f $ responseLBS status200 [] ""

241248 withApp defaultSettings app $ \port -> do

242− handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port

249+ handle <- connectTo "127.0.0.1" port

243250 let input = S.concat

244251 [ "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"

245252 , "c\r\nHello World\n\r\n3\r\nBye\r\n0\r\n\r\n"

@@ -262,7 +269,7 @@ spec = do

262269 I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())

263270 f $ responseLBS status200 [] ""

264271 withApp defaultSettings app $ \port -> do

265− handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port

272+ handle <- connectTo "127.0.0.1" port

266273 let input = concat $ replicate 2 $

267274 ["POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"] ++

268275 (replicate 50 "5\r\n12345\r\n") ++

@@ -279,7 +286,7 @@ spec = do

279286 liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())

280287 f $ responseLBS status200 [] ""

281288 withApp defaultSettings app $ \port -> do

282− handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port

289+ handle <- connectTo "127.0.0.1" port

283290 let input = S.concat

284291 [ "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"

285292 , "c\r\nHello World\n\r\n3\r\nBye\r\n0\r\n"

@@ -310,7 +317,7 @@ spec = do

310317 let bs1 = S.replicate 2048 88

311318 bs2 = "This is short"

312319 bs = S.append bs1 bs2

313− handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port

320+ handle <- connectTo "127.0.0.1" port

314321 hPutStr handle "POST / HTTP/1.1\r\n"

315322 hPutStr handle "content-length: "

316323 hPutStr handle $ S8.pack $ show $ S.length bs

@@ -336,7 +343,7 @@ spec = do

336343 loop

337344 doubleBS = S.concatMap $ \w -> S.pack [w, w]

338345 withApp defaultSettings app $ \port -> do

339− handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port

346+ handle <- connectTo "127.0.0.1" port

340347 hPutStr handle "POST / HTTP/1.1\r\n\r\n12345"

341348 hFlush handle

342349 timeout 100000 (S.hGet handle 10) >>= (`shouldBe` Just "1122334455")

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

351358 ] ""

352359 withApp defaultSettings app $ \port -> do

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

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

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

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

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

356363

357364 it "streaming echo #249" $ do

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

@@ -363,11 +370,11 @@ spec = do

363370 loop

364371 loop

365372 withApp defaultSettings app $ \port -> do

366− (socket, _addr) <- getSocketTCP "127.0.0.1" port

367− sendAll socket "POST / HTTP/1.1\r\ntransfer-encoding: chunked\r\n\r\n"

373+ (sock, _addr) <- getSocketTCP "127.0.0.1" port

374+ sendAll sock "POST / HTTP/1.1\r\ntransfer-encoding: chunked\r\n\r\n"

368375 threadDelay 10000

369− sendAll socket "5\r\nhello\r\n0\r\n\r\n"

370− bs <- safeRecv socket 4096

376+ sendAll sock "5\r\nhello\r\n0\r\n\r\n"

377+ bs <- safeRecv sock 4096

371378 S.takeWhile (/= 13) bs `shouldBe` "HTTP/1.1 200 OK"

372379

373380 it "streaming response with length" $ do

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

375382 replicateM_ 4 $ write $ byteString "Hello"

376383 withApp defaultSettings app $ \port -> do

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

378− rspBody res `shouldBe` "HelloHelloHelloHello"

385+ responseBody res `shouldBe` "HelloHelloHelloHello"

379386

380387 describe "head requests" $ do

381388 let fp = "test/head-response"

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

388395 _ -> error "invalid path"

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

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

391− rspBody res `shouldBe` ""

398+ responseBody res `shouldBe` ""

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

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

394− rspBody res `shouldBe` ""

401+ responseBody res `shouldBe` ""

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

396403 bs <- S.readFile fp

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

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

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

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

400407 res <- sendHEADwH

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

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

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

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

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

404411

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

406413consumeBody body =

warp/test/WithApplicationSpec.hs+2

@@ -42,8 +42,10 @@ spec = do

4242 readProcess "curl" ["-s", "localhost:" ++ show port] "")

4343 `shouldThrow` (errorCall "foo")

4444

45+{- The future netwrok library will not export MkSocket.

4546 describe "withFreePort" $ do

4647 it "closes the socket before exiting" $ do

4748 MkSocket _ _ _ _ statusMVar <- withFreePort $ \ (_, sock) -> do

4849 return sock

4950 readMVar statusMVar `shouldReturn` Closed

51+-}

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