master..374aaac · typeable/wai

git.iko.soy/typeable/wai

33 files changed+123−223

unifiedsplit

stack.yaml+1−1

@@ -1,4 +1,4 @@

1−resolver: lts-14.22

1+resolver: lts-14.20

22packages:

33- ./auto-update

44- ./mime-types

wai-app-static/ChangeLog.md−4

@@ -1,9 +1,5 @@

11# wai-app-static changelog

3−## 3.1.7.1

4−

5−* Update the test suite too

6−

73## 3.1.7

95* Use 302 instead of 301 redirect, to avoid caching the presence of an index.html file

wai-app-static/Network/Wai/Application/Static.hs+6−8

@@ -164,13 +164,11 @@ serveFile StaticSettings {..} req file

164164 -- Didn't match, but we have a hash value. Send the file contents

165165 -- with an ETag header.

166166 --

167− -- RFC7232 (HTTP 1.1):

168− -- > A recipient MUST ignore If-Modified-Since if the request contains an

169− -- > If-None-Match header field; the condition in If-None-Match is

170− -- > considered to be a more accurate replacement for the condition in

171− -- > If-Modified-Since, and the two are only combined for the sake of

172− -- > interoperating with older intermediaries that might not implement

173− -- > If-None-Match.

167+ -- Note: It would be arguably better to next check

168+ -- if-modified-since and return a 304 if that indicates a match as

169+ -- well. However, the circumstances under which such a situation

170+ -- could arise would be very anomalous, and should likely warrant a

171+ -- new file being sent anyway.

174172 (Just hash, _) -> respond [("ETag", hash)]

175173

176174 -- No hash value available, fall back to last modified support.

@@ -245,7 +243,7 @@ staticAppPieces ss rawPieces req sendResponse = liftIO $ do

245243 response :: StaticResponse -> IO W.ResponseReceived

246244 response (FileResponse file ch) = do

247245 mimetype <- ssGetMimeType ss file

248− -- let filesize = fileGetSize file

246+ let filesize = fileGetSize file

249247 let headers = ("Content-Type", mimetype)

250248 -- Let Warp provide the content-length, since it takes

251249 -- range requests into account

wai-app-static/WaiAppStatic/CmdLine.hs−1

@@ -39,7 +39,6 @@ data Args = Args

3939 }

4040

4141#if MIN_VERSION_optparse_applicative(0, 10, 0)

42−option' :: Mod OptionFields Int -> Parser Int

4342option' = option auto

4443#else

4544option' = option

wai-app-static/WaiAppStatic/Listing.hs+1−1

@@ -64,7 +64,7 @@ defaultListing pieces (Folder contents) = do

6464

6565 -- Add a link to the root of the tree

6666 showFolder' :: Bool -> Pieces -> H.Html

67− showFolder' hasTrailingSlash pieces' = showFolder hasTrailingSlash (unsafeToPiece "root" : pieces')

67+ showFolder' hasTrailingSlash pieces = showFolder hasTrailingSlash (unsafeToPiece "root" : pieces)

6868

6969 showFolder :: Bool -> Pieces -> H.Html

7070 showFolder _ [] = "/" -- won't happen

wai-app-static/WaiAppStatic/Storage/Embedded/TH.hs+1

@@ -7,6 +7,7 @@ module WaiAppStatic.Storage.Embedded.TH(

88import Data.ByteString.Builder.Extra (byteStringInsert)

99import Codec.Compression.GZip (compress)

10+import Control.Applicative

1011import Data.ByteString.Unsafe (unsafePackAddressLen)

1112import Data.Either (lefts, rights)

1213import GHC.Exts (Int(..))

wai-app-static/WaiAppStatic/Types.hs−2

@@ -59,8 +59,6 @@ toPieces :: [Text] -> Maybe Pieces

5959toPieces = mapM toPiece

6060

6161-- | Request coming from a user. Corresponds to @pathInfo@.

62−--

63−-- The root path is the empty list.

6462type Pieces = [Piece]

6563

6664-- | Values for the max-age component of the cache-control response header.

wai-app-static/test/WaiAppStaticTest.hs+8−8

@@ -61,18 +61,18 @@ spec = do

6161 assertStatus 404 =<<

6262 request (setRawPathInfo defRequest "doesNotExist")

6363

64− it "302 redirect when multiple slashes" $ webApp $ do

64+ it "301 redirect when multiple slashes" $ webApp $ do

6565 req <- request (setRawPathInfo defRequest "a//b/c")

66− assertStatus 302 req

66+ assertStatus 301 req

6767 assertHeader "Location" "../../a/b/c" req

6868

6969 let absoluteApp = flip runSession $ staticApp $ (defaultWebAppSettings "test") {

7070 ssMkRedirect = \_ u -> S8.append "http://www.example.com" u

7171 }

72− it "302 redirect when multiple slashes" $ absoluteApp $

72+ it "301 redirect when multiple slashes" $ absoluteApp $

7373 flip mapM_ ["/a//b/c", "a//b/c"] $ \path -> do

7474 req <- request (setRawPathInfo defRequest path)

75− assertStatus 302 req

75+ assertStatus 301 req

7676 assertHeader "Location" "http://www.example.com/a/b/c" req

7777

7878 describe "webApp when requesting a static asset" $ do

@@ -131,10 +131,10 @@ spec = do

131131 assertStatus 304 req

132132 assertNoHeader "Cache-Control" req

133133

134− context "302 redirect to add a trailing slash on directories if missing" $ do

134+ context "301 redirect to add a trailing slash on directories if missing" $ do

135135 it "works at the root" $ fileServerApp $ do

136136 req <- request (setRawPathInfo defRequest "/a")

137− assertStatus 302 req

137+ assertStatus 301 req

138138 assertHeader "Location" "/a/" req

139139

140140 it "works when an index.html is delivered" $ do

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

144144 inTempDirectory $ fileServerAppWithSettings settings $ do

145145 liftIO $ touch "foo/index.html"

146146 req <- request (setRawPathInfo defRequest "/foo")

147− assertStatus 302 req

147+ assertStatus 301 req

148148 assertHeader "Location" "/foo/" req

149149

150150 let urlMapApp = flip runSession $ \req send ->

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

158158 "urlMapApp: only works at subPath"

159159 it "works with subpath at the root of the file server" $ urlMapApp $ do

160160 req <- request (setRawPathInfo defRequest "/subPath")

161− assertStatus 302 req

161+ assertStatus 301 req

162162 assertHeader "Location" "/subPath/" req

163163

164164 context "with defaultWebAppSettings" $ do

wai-app-static/wai-app-static.cabal+1−1

@@ -1,5 +1,5 @@

11name: wai-app-static

2−version: 3.1.7.1

2+version: 3.1.7

33license: MIT

44license-file: LICENSE

55author: Michael Snoyman <michael@snoyman.com>

wai-conduit/Network/Wai/Conduit.hs+6−5

@@ -17,16 +17,17 @@ import qualified Data.ByteString as S

1717import Control.Monad (unless)

1818import Network.HTTP.Types

1919import Data.ByteString.Builder (Builder)

20+import Data.IORef

2021import qualified Data.Conduit.List as CL

2122

2223-- | Stream the request body.

2324--

2425-- Since 3.0.0

25−sourceRequestBody :: MonadIO m => Request -> ConduitT () ByteString m ()

26+sourceRequestBody :: MonadIO m => Request -> Source m ByteString

2627sourceRequestBody req =

2728 loop

2829 where

29− go = liftIO (getRequestBodyChunk req)

30+ go = liftIO (requestBody req)

3031

3132 loop = do

3233 bs <- go

@@ -37,9 +38,9 @@ sourceRequestBody req =

3738-- | Create an HTTP response out of a @Source@.

3839--

3940-- Since 3.0.0

40−responseSource :: Status -> ResponseHeaders -> ConduitT () (Flush Builder) IO () -> Response

41+responseSource :: Status -> ResponseHeaders -> Source IO (Flush Builder) -> Response

4142responseSource s hs src = responseStream s hs $ \send flush ->

42− runConduit $ src .| CL.mapM_ (\mbuilder ->

43+ src $$ CL.mapM_ (\mbuilder ->

4344 case mbuilder of

4445 Chunk b -> send b

4546 Flush -> flush)

@@ -49,7 +50,7 @@ responseSource s hs src = responseStream s hs $ \send flush ->

4950--

5051-- Since 3.0.0

5152responseRawSource :: (MonadIO m, MonadIO n)

52− => (ConduitT () ByteString m () -> ConduitT ByteString Void n () -> IO ())

53+ => (Source m ByteString -> Sink ByteString n () -> IO ())

5354 -> Response

5455 -> Response

5556responseRawSource app =

wai-extra/ChangeLog.md−4

@@ -1,9 +1,5 @@

11# Changelog for wai-extra

3−## 3.0.29.1

4−

5−* Fix `Network.Wai.Test.request` always sending an empty request body [#794](https://github.com/yesodweb/wai/pull/794)

6−

73## 3.0.29

95* Export `Network.Wai.EventSource.eventStreamAppRaw` [#786](https://github.com/yesodweb/wai/pull/786)

wai-extra/Network/Wai/Test.hs+14−22

@@ -99,10 +99,6 @@ runSession session app = ST.evalStateT (runReaderT session app) initState

9999data SRequest = SRequest

100100 { simpleRequest :: Request

101101 , simpleRequestBody :: L.ByteString

102− -- ^ Request body that will override the one set in 'simpleRequest'.

103− --

104− -- This is usually simpler than setting the body as a stateful IO-action

105− -- in 'simpleRequest'.

106102 }

107103data SResponse = SResponse

108104 { simpleStatus :: H.Status

@@ -110,16 +106,8 @@ data SResponse = SResponse

110106 , simpleBody :: L.ByteString

111107 }

112108 deriving (Show, Eq)

113−

114109request :: Request -> Session SResponse

115−request req = do

116− app <- ask

117− req' <- addCookiesToRequest req

118− response <- liftIO $ do

119− ref <- newIORef $ error "runResponse gave no result"

120− ResponseReceived <- app req' (runResponse ref)

121− readIORef ref

122− extractSetCookieFromSResponse response

110+request = srequest . flip SRequest L.empty

123111

124112-- | Set whole path (request path + query string).

125113setPath :: Request -> S8.ByteString -> Request

@@ -178,18 +166,22 @@ extractSetCookieFromSResponse response = do

178166 (Map.fromList [(Cookie.setCookieName c, c) | c <- newClientCookies ]))

179167 return response

180168

181−-- | Similar to 'request', but allows setting the request body as a plain

182−-- 'L.ByteString'.

183169srequest :: SRequest -> Session SResponse

184170srequest (SRequest req bod) = do

171+ app <- ask

185172 refChunks <- liftIO $ newIORef $ L.toChunks bod

186− request $

187− req

188− { requestBody = atomicModifyIORef refChunks $ \bss ->

189− case bss of

190− [] -> ([], S.empty)

191− x:y -> (y, x)

192− }

173+ let req' = req

174+ { requestBody = atomicModifyIORef refChunks $ \bss ->

175+ case bss of

176+ [] -> ([], S.empty)

177+ x:y -> (y, x)

178+ }

179+ req'' <- addCookiesToRequest req'

180+ response <- liftIO $ do

181+ ref <- newIORef $ error "runResponse gave no result"

182+ ResponseReceived <- app req'' (runResponse ref)

183+ readIORef ref

184+ extractSetCookieFromSResponse response

193185

194186runResponse :: IORef SResponse -> Response -> IO ResponseReceived

195187runResponse ref res = do

wai-extra/example/Main.hs+2−2

@@ -42,10 +42,10 @@ eventRaw = handle 0

4242 where

4343 handle counter emit flush = do

4444 threadDelay 1000000

45− _ <- emit $ ServerEvent (Just $ string8 "raw")

45+ emit $ ServerEvent (Just $ string8 "raw")

4646 Nothing

4747 [string8 . show $ counter]

48− _ <- flush

48+ flush

4949 handle (counter + 1) emit flush

5050

5151main :: IO ()

wai-extra/test/Network/Wai/TestSpec.hs+11−41

@@ -3,8 +3,6 @@ module Network.Wai.TestSpec (main, spec) where

44import Control.Monad (void)

6−import qualified Data.IORef as IORef

7−

86import qualified Data.Text.Encoding as TE

108import Data.Time.Calendar (fromGregorian)

@@ -55,53 +53,25 @@ spec = do

5553 it "sets rawQueryString to empty string" $ do

5654 rawQueryString (setPath defaultRequest "/foo/bar/baz") `shouldBe` ""

5755

58− describe "srequest" $ do

59−

60− let echoApp req respond = do

61− reqBody <- L8.fromStrict <$> getRequestBodyChunk req

62− let reqHeaders = requestHeaders req

63− respond $

64− responseLBS

65− status200

66− reqHeaders

67− reqBody

68−

69− it "returns the response body of an echo app" $ do

70− sresp <- flip runSession echoApp $

71− srequest $ SRequest defaultRequest "request body"

72− simpleBody sresp `shouldBe` "request body"

73−

7456 describe "request" $ do

7557

76− let echoApp req respond = do

77− reqBody <- L8.fromStrict <$> getRequestBodyChunk req

78− let reqHeaders = requestHeaders req

58+ let simpleApp _req respond =

7959 respond $

8060 responseLBS

8161 status200

82− reqHeaders

83− reqBody

62+ [("foo", "bar")]

63+ "simple"

8464

85− it "returns the status code of an echo app on default request" $ do

86− sresp <- runSession (request defaultRequest) echoApp

65+ it "returns the status code of a simple app on default request" $ do

66+ sresp <- runSession (request defaultRequest) simpleApp

8767 simpleStatus sresp `shouldBe` status200

8868

89− it "returns the response body of an echo app" $ do

90− bodyRef <- IORef.newIORef "request body"

91− let getBodyChunk = IORef.atomicModifyIORef bodyRef $ \leftover -> ("", leftover)

92− sresp <- flip runSession echoApp $

93− request $

94− defaultRequest

95− { requestBody = getBodyChunk

96− }

97− simpleBody sresp `shouldBe` "request body"

98−

99− it "returns the response headers of an echo app" $ do

100− sresp <- flip runSession echoApp $

101− request $

102− defaultRequest

103− { requestHeaders = [("foo", "bar")]

104− }

69+ it "returns the response body of a simple app on default request" $ do

70+ sresp <- runSession (request defaultRequest) simpleApp

71+ simpleBody sresp `shouldBe` "simple"

72+

73+ it "returns the response headers of a simple app on default request" $ do

74+ sresp <- runSession (request defaultRequest) simpleApp

10575 simpleHeaders sresp `shouldBe` [("foo", "bar")]

10676

10777 let cookieApp req respond =

wai-extra/wai-extra.cabal+1−1

@@ -1,5 +1,5 @@

11Name: wai-extra

2−Version: 3.0.29.1

2+Version: 3.0.29

33Synopsis: Provides some basic WAI handlers and middleware.

44description:

55 Provides basic WAI handler and middleware functionality:

wai-websockets/server.lhs−6

@@ -8,8 +8,6 @@ this example, keep the [reference](http://jaspervdj.be/websockets/reference)

88nearby to check out the functions we use.

1010> {-# LANGUAGE OverloadedStrings, TemplateHaskell #-}

11−> {-# LANGUAGE CPP #-}

12−> {-# OPTIONS_GHC -Wno-unused-top-binds #-} -- for numClients

1311> import Data.Char (isPunctuation, isSpace)

1412> import Data.Monoid (mappend)

1513> import Data.Text (Text)

@@ -101,11 +99,7 @@ stays alive on some browsers.

10199

102100> application state pending = do

103101> conn <- WS.acceptRequest pending

104−#if __GLASGOW_HASKELL__ >= 806

105−> WS.withPingThread conn 30 (return ()) $ do

106−#else

107102> WS.forkPingThread conn 30

108−#endif

109103

110104When a client is successfully connected, we read the first message. This should

111105be in the format of "Hi! I am Jasper", where Jasper is the requested username.

wai-websockets/wai-websockets.cabal−1

@@ -45,7 +45,6 @@ Executable wai-websockets-example

4545 , text

4646 , file-embed

4747 , http-types

48− other-modules: Network.Wai.Handler.WebSockets

4948 else

5049 buildable: False

5150

warp-tls/ChangeLog.md−4

@@ -1,7 +1,3 @@

1−## 3.2.11

2−

3−* Ignoring an exception from shutdown (gracefulClose).

4−

51## 3.2.10

73* Passing client certificate, if any, to Warp

warp-tls/Network/Wai/Handler/WarpTLS.hs+1−1

@@ -361,7 +361,7 @@ httpOverTls TLSSettings{..} _set s bs0 params = do

361361 backend recvN = TLS.Backend {

362362 TLS.backendFlush = return ()

363363#if MIN_VERSION_network(3,1,1)

364− , TLS.backendClose = gracefulClose s 5000 `E.catch` \(SomeException _) -> return ()

364+ , TLS.backendClose = gracefulClose s 5000

365365#else

366366 , TLS.backendClose = close s

367367#endif

warp-tls/warp-tls.cabal+1−1

@@ -1,5 +1,5 @@

11Name: warp-tls

2−Version: 3.2.11

2+Version: 3.2.10

33Synopsis: HTTP over TLS support for Warp via the TLS package

44License: MIT

55License-file: LICENSE

warp/ChangeLog.md−16

@@ -1,19 +1,3 @@

1−## 3.3.9

2−

3−* Don't insert Last-Modified: if exists.

4− [#791](https://github.com/yesodweb/wai/pull/791)

5−

6−## 3.3.8

7−

8−* Maximum header size is configurable.

9− [#781](https://github.com/yesodweb/wai/pull/781)

10−* Ignoring an exception from shutdown (gracefulClose).

11−

12−## 3.3.7

13−

14−* InvalidArgument (Bad file descriptor) is ignored in `receive`.

15− [#787](https://github.com/yesodweb/wai/pull/787)

16−

171## 3.3.6

182

193* Fixing a bug of thread killed in the case of event source with

warp/Network/Wai/Handler/Warp.hs+1−9

@@ -74,7 +74,6 @@ module Network.Wai.Handler.Warp (

7474 , setGracefulShutdownTimeout

7575 , setGracefulCloseTimeout1

7676 , setGracefulCloseTimeout2

77− , setMaxTotalHeaderLength

7877 -- ** Getters

7978 , getPort

8079 , getHost

@@ -124,7 +123,7 @@ module Network.Wai.Handler.Warp (

124123 , defaultPushPromise

125124 ) where

126125

127−import Control.Exception (SomeException, throwIO)

126+import Control.Exception (SomeException, throwIO, throw)

128127import Data.Streaming.Network (HostPreference)

129128import qualified Data.Vault.Lazy as Vault

130129import Data.X509

@@ -437,13 +436,6 @@ setGracefulShutdownTimeout :: Maybe Int

437436 -> Settings -> Settings

438437setGracefulShutdownTimeout time y = y { settingsGracefulShutdownTimeout = time }

439438

440−-- | Set the maximum header size that Warp will tolerate when using HTTP/1.x.

441−--

442−-- Since 3.3.8

443−setMaxTotalHeaderLength :: Int -> Settings -> Settings

444−setMaxTotalHeaderLength maxTotalHeaderLength settings = settings

445− { settingsMaxTotalHeaderLength = maxTotalHeaderLength }

446−

447439-- | Explicitly pause the slowloris timeout.

448440--

449441-- This is useful for cases where you partially consume a request body. For

warp/Network/Wai/Handler/Warp/File.hs+4−7

@@ -34,15 +34,12 @@ data RspFileInfo = WithoutBody H.Status

3434----------------------------------------------------------------

3535

3636conditionalRequest :: I.FileInfo

37− -> H.ResponseHeaders

38− -> IndexedHeader -- ^ Response

39− -> IndexedHeader -- ^ Request

37+ -> H.ResponseHeaders -> IndexedHeader

4038 -> RspFileInfo

41−conditionalRequest finfo hs0 rspidx reqidx = case condition of

39+conditionalRequest finfo hs0 reqidx = case condition of

4240 nobody@(WithoutBody _) -> nobody

43− WithBody s _ off len -> let !hs1 = addContentHeaders hs0 off len size

44− !hasLM = isJust $ rspidx ! fromEnum ResLastModified

45− !hs = [ (H.hLastModified,date) | not hasLM ] ++ hs1

41+ WithBody s _ off len -> let !hs = (H.hLastModified,date) :

42+ addContentHeaders hs0 off len size

4643 in WithBody s hs off len

4744 where

4845 !mtime = I.fileInfoTime finfo

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

@@ -72,8 +72,7 @@ responseFile _ rsphdr isHead path Nothing ii reqhdr = do

7272 Left (_ex :: E.IOException) -> return $ response404 rsphdr

7373 Right finfo -> do

7474 let reqidx = indexRequestHeader reqhdr

75− rspidx = indexResponseHeader rsphdr

76− case conditionalRequest finfo rsphdr rspidx reqidx of

75+ case conditionalRequest finfo rsphdr reqidx of

7776 WithoutBody s -> return $ responseNoBody s rsphdr

7877 WithBody s rsphdr' off bytes -> do

7978 let !off' = fromIntegral off

warp/Network/Wai/Handler/Warp/Header.hs−2

@@ -69,7 +69,6 @@ indexResponseHeader hdr = traverseHeader hdr responseMaxIndex responseKeyIndex

6969data ResponseHeaderIndex = ResContentLength

7070 | ResServer

7171 | ResDate

72− | ResLastModified

7372 deriving (Enum,Bounded)

7473

7574-- | The size for 'IndexedHeader' for HTTP Response.

@@ -80,7 +79,6 @@ responseKeyIndex :: HeaderName -> Int

8079responseKeyIndex hn = case BS.length bs of

8180 4 -> if bs == "date" then fromEnum ResDate else -1

8281 6 -> if bs == "server" then fromEnum ResServer else -1

83− 13 -> if bs == "last-modified" then fromEnum ResLastModified else -1

8482 14 -> if bs == "content-length" then fromEnum ResContentLength else -1

8583 _ -> -1

8684 where

warp/Network/Wai/Handler/Warp/Recv.hs+1−13

@@ -17,9 +17,7 @@ import Foreign.C.Types

1717import Foreign.ForeignPtr (withForeignPtr)

1818import Foreign.Ptr (Ptr, castPtr, plusPtr)

1919import GHC.Conc (threadWaitRead)

20−import qualified GHC.IO.Exception as E

2120import Network.Socket (Socket)

22−import qualified System.IO.Error as E

2321#if MIN_VERSION_network(3,1,0)

2422import Network.Socket (withFdSocket)

2523#else

@@ -96,11 +94,8 @@ spell init0 siz0 recv recvBuf

9694 siz' = siz - len

9795 loop bss' siz'

9896

99−-- The timeout manager may close the socket.

100−-- In that case, an error of "Bad file descriptor" occurs.

101−-- We ignores it because we expect TimeoutThread.

10297receive :: Socket -> BufferPool -> Recv

103−receive sock pool = E.handle handler $ withBufferPool pool $ \ (ptr, size) -> do

98+receive sock pool = withBufferPool pool $ \ (ptr, size) -> do

10499#if MIN_VERSION_network(3,1,0)

105100 withFdSocket sock $ \fd -> do

106101#elif MIN_VERSION_network(3,0,0)

@@ -110,11 +105,6 @@ receive sock pool = E.handle handler $ withBufferPool pool $ \ (ptr, size) -> do

110105#endif

111106 let size' = fromIntegral size

112107 fromIntegral <$> receiveloop fd ptr size'

113− where

114− handler :: E.IOException -> IO ByteString

115− handler e

116− | E.ioeGetErrorType e == E.InvalidArgument = return ""

117− | otherwise = E.throwIO e

118108

119109receiveBuf :: Socket -> RecvBuf

120110receiveBuf sock buf0 siz0 = do

@@ -153,8 +143,6 @@ receiveloop sock ptr size = do

153143 else

154144 return bytes

155145

156−#ifndef mingw32_HOST_OS

157146-- fixme: the type of the return value

158147foreign import ccall unsafe "recv"

159148 c_recv :: CInt -> Ptr CChar -> CSize -> CInt -> IO CInt

160−#endif

warp/Network/Wai/Handler/Warp/Request.hs+17−11

@@ -38,7 +38,13 @@ import Network.Wai.Handler.Warp.Header

3838import Network.Wai.Handler.Warp.Imports hiding (readInt, lines)

3939import Network.Wai.Handler.Warp.ReadInt

4040import Network.Wai.Handler.Warp.RequestHeader

41−import Network.Wai.Handler.Warp.Settings (Settings, settingsNoParsePath, settingsMaxTotalHeaderLength)

41+import Network.Wai.Handler.Warp.Settings (Settings, settingsNoParsePath)

42+

43+----------------------------------------------------------------

44+

45+-- FIXME come up with good values here

46+maxTotalHeaderLength :: Int

47+maxTotalHeaderLength = 50 * 1024

4248

4349----------------------------------------------------------------

4450

@@ -62,7 +68,7 @@ recvRequest :: Bool -- ^ first request on this connection?

6268 -- Body producing action used for flushing the request body

6369

6470recvRequest firstRequest settings conn ii th addr src transport = do

65− hdrlines <- headerLines (settingsMaxTotalHeaderLength settings) firstRequest src

71+ hdrlines <- headerLines firstRequest src

6672 (method, unparsedPath, path, query, httpversion, hdr) <- parseHeaderLines hdrlines

6773 let idxhdr = indexRequestHeader hdr

6874 expect = idxhdr ! fromEnum ReqExpect

@@ -101,8 +107,8 @@ recvRequest firstRequest settings conn ii th addr src transport = do

101107

102108----------------------------------------------------------------

103109

104−headerLines :: Int -> Bool -> Source -> IO [ByteString]

105−headerLines maxTotalHeaderLength firstRequest src = do

110+headerLines :: Bool -> Source -> IO [ByteString]

111+headerLines firstRequest src = do

106112 bs <- readSource src

107113 if S.null bs

108114 -- When we're working on a keep-alive connection and trying to

@@ -110,7 +116,7 @@ headerLines maxTotalHeaderLength firstRequest src = do

110116 -- lack of data as a real exception. See the http1 function in

111117 -- the Run module for more details.

112118 then if firstRequest then throwIO ConnectionClosedByPeer else throwIO NoKeepAliveRequest

113− else push maxTotalHeaderLength src (THStatus 0 id id) bs

119+ else push src (THStatus 0 id id) bs

114120

115121data NoKeepAliveRequest = NoKeepAliveRequest

116122 deriving (Show, Typeable)

@@ -220,8 +226,8 @@ close :: Sink ByteString IO a

220226close = throwIO IncompleteHeaders

221227-}

222228

223−push :: Int -> Source -> THStatus -> ByteString -> IO [ByteString]

224−push maxTotalHeaderLength src (THStatus len lines prepend) bs'

229+push :: Source -> THStatus -> ByteString -> IO [ByteString]

230+push src (THStatus len lines prepend) bs'

225231 -- Too many bytes

226232 | len > maxTotalHeaderLength = throwIO OverLargeHeader

227233 | otherwise = push' mnl

@@ -249,13 +255,13 @@ push maxTotalHeaderLength src (THStatus len lines prepend) bs'

249255 push' Nothing = do

250256 bst <- readSource' src

251257 when (S.null bst) $ throwIO IncompleteHeaders

252− push maxTotalHeaderLength src status bst

258+ push src status bst

253259 where

254260 len' = len + bsLen

255261 prepend' = S.append bs

256262 status = THStatus len' lines prepend'

257263 -- Found a newline, but next line continues as a multiline header

258− push' (Just (end, True)) = push maxTotalHeaderLength src status rest

264+ push' (Just (end, True)) = push src status rest

259265 where

260266 rest = S.drop (end + 1) bs

261267 prepend' = S.append (SU.unsafeTake (checkCR bs end) bs)

@@ -274,12 +280,12 @@ push maxTotalHeaderLength src (THStatus len lines prepend) bs'

274280 in if start < bsLen then

275281 -- more bytes in this chunk, push again

276282 let bs'' = SU.unsafeDrop start bs

277− in push maxTotalHeaderLength src status bs''

283+ in push src status bs''

278284 else do

279285 -- no more bytes in this chunk, ask for more

280286 bst <- readSource' src

281287 when (S.null bs) $ throwIO IncompleteHeaders

282− push maxTotalHeaderLength src status bst

288+ push src status bst

283289 where

284290 start = end + 1 -- start of next chunk

285291 line = SU.unsafeTake (checkCR bs end) bs

warp/Network/Wai/Handler/Warp/Response.hs+16−19

@@ -116,14 +116,14 @@ sendResponse settings conn ii th req reqidxhdr src response = do

116116 -- and status, the response to HEAD is processed here.

117117 --

118118 -- See definition of rsp below for proper body stripping.

119− (ms, mlen) <- sendRsp conn ii ver s hs rspidxhdr rsp

119+ (ms, mlen) <- sendRsp conn ii ver s hs rsp

120120 case ms of

121121 Nothing -> return ()

122122 Just realStatus -> logger req realStatus mlen

123123 T.tickle th

124124 return ret

125125 else do

126− _ <- sendRsp conn ii ver s hs rspidxhdr RspNoBody

126+ _ <- sendRsp conn ii ver s hs RspNoBody

127127 logger req s Nothing

128128 T.tickle th

129129 return isPersist

@@ -196,13 +196,12 @@ sendRsp :: Connection

196196 -> H.HttpVersion

197197 -> H.Status

198198 -> H.ResponseHeaders

199− -> IndexedHeader -- Response

200199 -> Rsp

201200 -> IO (Maybe H.Status, Maybe Integer)

202201

203202----------------------------------------------------------------

204203

205−sendRsp conn _ ver s hs _ RspNoBody = do

204+sendRsp conn _ ver s hs RspNoBody = do

206205 -- Not adding Content-Length.

207206 -- User agents treats it as Content-Length: 0.

208207 composeHeader ver s hs >>= connSendAll conn

@@ -210,7 +209,7 @@ sendRsp conn _ ver s hs _ RspNoBody = do

210209

211210----------------------------------------------------------------

212211

213−sendRsp conn _ ver s hs _ (RspBuilder body needsChunked) = do

212+sendRsp conn _ ver s hs (RspBuilder body needsChunked) = do

214213 header <- composeHeaderBuilder ver s hs needsChunked

215214 let hdrBdy

216215 | needsChunked = header <> chunkedTransferEncoding body

@@ -223,7 +222,7 @@ sendRsp conn _ ver s hs _ (RspBuilder body needsChunked) = do

223222

224223----------------------------------------------------------------

225224

226−sendRsp conn _ ver s hs _ (RspStream streamingBody needsChunked th) = do

225+sendRsp conn _ ver s hs (RspStream streamingBody needsChunked th) = do

227226 header <- composeHeaderBuilder ver s hs needsChunked

228227 (recv, finish) <- newByteStringBuilderRecv $ reuseBufferStrategy

229228 $ toBuilderBuffer (connWriteBuffer conn) (connBufferSize conn)

@@ -247,7 +246,7 @@ sendRsp conn _ ver s hs _ (RspStream streamingBody needsChunked th) = do

247246

248247----------------------------------------------------------------

249248

250−sendRsp conn _ _ _ _ _ (RspRaw withApp src tickle) = do

249+sendRsp conn _ _ _ _ (RspRaw withApp src tickle) = do

251250 withApp recv send

252251 return (Nothing, Nothing)

253252 where

@@ -261,8 +260,8 @@ sendRsp conn _ _ _ _ _ (RspRaw withApp src tickle) = do

261260

262261-- Sophisticated WAI applications.

263262-- We respect s0. s0 MUST be a proper value.

264−sendRsp conn ii ver s0 hs0 rspidxhdr (RspFile path (Just part) _ isHead hook) =

265− sendRspFile2XX conn ii ver s0 hs rspidxhdr path beg len isHead hook

263+sendRsp conn ii ver s0 hs0 (RspFile path (Just part) _ isHead hook) =

264+ sendRspFile2XX conn ii ver s0 hs path beg len isHead hook

266265 where

267266 beg = filePartOffset part

268267 len = filePartByteCount part

@@ -272,17 +271,17 @@ sendRsp conn ii ver s0 hs0 rspidxhdr (RspFile path (Just part) _ isHead hook) =

272271

273272-- Simple WAI applications.

274273-- Status is ignored

275−sendRsp conn ii ver _ hs0 rspidxhdr (RspFile path Nothing reqidxhdr isHead hook) = do

274+sendRsp conn ii ver _ hs0 (RspFile path Nothing idxhdr isHead hook) = do

276275 efinfo <- E.try $ getFileInfo ii path

277276 case efinfo of

278277 Left (_ex :: E.IOException) ->

279278#ifdef WARP_DEBUG

280279 print _ex >>

281280#endif

282− sendRspFile404 conn ii ver hs0 rspidxhdr

283− Right finfo -> case conditionalRequest finfo hs0 rspidxhdr reqidxhdr of

284− WithoutBody s -> sendRsp conn ii ver s hs0 rspidxhdr RspNoBody

285− WithBody s hs beg len -> sendRspFile2XX conn ii ver s hs rspidxhdr path beg len isHead hook

281+ sendRspFile404 conn ii ver hs0

282+ Right finfo -> case conditionalRequest finfo hs0 idxhdr of

283+ WithoutBody s -> sendRsp conn ii ver s hs0 RspNoBody

284+ WithBody s hs beg len -> sendRspFile2XX conn ii ver s hs path beg len isHead hook

286285

287286----------------------------------------------------------------

288287

@@ -291,15 +290,14 @@ sendRspFile2XX :: Connection

291290 -> H.HttpVersion

292291 -> H.Status

293292 -> H.ResponseHeaders

294− -> IndexedHeader

295293 -> FilePath

296294 -> Integer

297295 -> Integer

298296 -> Bool

299297 -> IO ()

300298 -> IO (Maybe H.Status, Maybe Integer)

301−sendRspFile2XX conn ii ver s hs rspidxhdr path beg len isHead hook

302− | isHead = sendRsp conn ii ver s hs rspidxhdr RspNoBody

299+sendRspFile2XX conn ii ver s hs path beg len isHead hook

300+ | isHead = sendRsp conn ii ver s hs RspNoBody

303301 | otherwise = do

304302 lheader <- composeHeader ver s hs

305303 (mfd, fresher) <- getFd ii path

@@ -312,9 +310,8 @@ sendRspFile404 :: Connection

312310 -> InternalInfo

313311 -> H.HttpVersion

314312 -> H.ResponseHeaders

315− -> IndexedHeader

316313 -> IO (Maybe H.Status, Maybe Integer)

317−sendRspFile404 conn ii ver hs0 rspidxhdr = sendRsp conn ii ver s hs rspidxhdr (RspBuilder body True)

314+sendRspFile404 conn ii ver hs0 = sendRsp conn ii ver s hs (RspBuilder body True)

318315 where

319316 s = H.notFound404

320317 hs = replaceHeader H.hContentType "text/plain; charset=utf-8" hs0

warp/Network/Wai/Handler/Warp/Run.hs+20−12

@@ -17,7 +17,7 @@ import qualified Control.Concurrent as Conc (yield)

1717import Control.Exception as E

1818import qualified Data.ByteString as S

1919import Data.Char (chr)

20−import Data.IORef (IORef, newIORef, readIORef, writeIORef)

20+import Data.IORef (IORef, newIORef, readIORef, writeIORef, atomicModifyIORef')

2121import Data.Streaming.Network (bindPortTCP)

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

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

@@ -59,11 +59,7 @@ import Network.Socket (fdSocket)

5959

6060-- | Creating 'Connection' for plain HTTP based on a given socket.

6161socketConnection :: Settings -> Socket -> IO Connection

62−#if MIN_VERSION_network(3,1,1)

6362socketConnection set s = do

64−#else

65−socketConnection _ s = do

66−#endif

6763 bufferPool <- newBufferPool

6864 writeBuf <- allocateBuffer bufferSize

6965 let sendall = Sock.sendAll s

@@ -80,7 +76,7 @@ socketConnection _ s = do

8076 if tm == 0 then

8177 close s

8278 else

83− gracefulClose s tm `E.catch` \(E.SomeException _) -> return ()

79+ gracefulClose s tm

8480#else

8581 , connClose = close s

8682#endif

@@ -286,7 +282,10 @@ fork :: Settings

286282fork set mkConn addr app counter ii = settingsFork set $ \unmask ->

287283 -- Call the user-supplied on exception code if any

288284 -- exceptions are thrown.

289− handle (settingsOnException set Nothing) $

285+ handle (settingsOnException set Nothing) .

286+ -- Allocate a new IORef indicating whether the connection has been

287+ -- closed, to avoid double-freeing a connection

288+ withClosedRef $ \ref ->

290289 -- Run the connection maker to get a new connection, and ensure

291290 -- that the connection is closed. If the mkConn call throws an

292291 -- exception, we will leak the connection. If the mkConn call is

@@ -297,13 +296,21 @@ fork set mkConn addr app counter ii = settingsFork set $ \unmask ->

297296 -- We grab the connection before registering timeouts since the

298297 -- timeouts will be useless during connection creation, due to the

299298 -- fact that async exceptions are still masked.

300− bracket mkConn cleanUp (serve unmask)

299+ bracket mkConn (cleanUp ref) (serve unmask ref)

301300 where

302− cleanUp (conn, _) = connClose conn `finally` connFree conn

301+ withClosedRef inner = newIORef False >>= inner

302+

303+ closeConn ref conn = do

304+ isClosed <- atomicModifyIORef' ref $ \x -> (True, x)

305+ unless isClosed $ connClose conn

306+

307+ cleanUp ref (conn, _) = closeConn ref conn `finally` connFree conn

303308

304309 -- We need to register a timeout handler for this thread, and

305− -- cancel that handler as soon as we exit.

306− serve unmask (conn, transport) = bracket register cancel $ \th -> do

310+ -- cancel that handler as soon as we exit. We additionally close

311+ -- the connection immediately in case the child thread catches the

312+ -- async exception or performs some long-running cleanup action.

313+ serve unmask ref (conn, transport) = bracket register cancel $ \th -> do

307314 -- We now have fully registered a connection close handler in

308315 -- the case of all exceptions, so it is safe to once again

309316 -- allow async exceptions.

@@ -315,7 +322,8 @@ fork set mkConn addr app counter ii = settingsFork set $ \unmask ->

315322 -- above ensures the connection is closed.

316323 when goingon $ serveConnection conn ii th addr transport set app

317324 where

318− register = T.registerKillThread (timeoutManager ii) (connClose conn)

325+ register = T.registerKillThread (timeoutManager ii)

326+ (closeConn ref conn)

319327 cancel = T.cancel

320328

321329 onOpen adr = increase counter >> settingsOnOpen set adr

warp/Network/Wai/Handler/Warp/Settings.hs−5

@@ -128,10 +128,6 @@ data Settings = Settings

128128 -- Default: 2000.

129129 --

130130 -- Since 3.3.5

131− , settingsMaxTotalHeaderLength :: Int

132− -- ^ Determines the maximum header size that Warp will tolerate when using HTTP/1.x.

133− --

134− -- Since 3.3.8

135131 }

136132

137133-- | Specify usage of the PROXY protocol.

@@ -170,7 +166,6 @@ defaultSettings = Settings

170166 , settingsGracefulShutdownTimeout = Nothing

171167 , settingsGracefulCloseTimeout1 = 0

172168 , settingsGracefulCloseTimeout2 = 2000

173− , settingsMaxTotalHeaderLength = 50 * 1024

174169 }

175170

176171-- | Apply the logic provided by 'defaultOnException' to determine if an

warp/test/FileSpec.hs+1−1

@@ -21,7 +21,7 @@ testFileRange desc reqhs file ans = it desc $ do

2121 let WithBody s hs off len = ans

2222 hs' = ("Last-Modified",fileInfoDate finfo) : hs

2323 ans' = WithBody s hs' off len

24− conditionalRequest finfo [] (indexResponseHeader hs) (indexRequestHeader reqhs) `shouldBe` ans'

24+ conditionalRequest finfo [] (indexRequestHeader reqhs) `shouldBe` ans'

2525

2626spec :: Spec

2727spec = do

warp/test/RequestSpec.hs+7−11

@@ -7,7 +7,6 @@ module RequestSpec (main, spec) where

77import Network.Wai.Handler.Warp.File (parseByteRanges)

88import Network.Wai.Handler.Warp.Request

99import Network.Wai.Handler.Warp.Types

10−import Network.Wai.Handler.Warp.Settings (settingsMaxTotalHeaderLength, defaultSettings)

1110import Test.Hspec

1211import Test.Hspec.QuickCheck

1312import qualified Data.ByteString as S

@@ -18,9 +17,6 @@ import Data.IORef

1817main :: IO ()

1918main = hspec spec

2019

21−defaultMaxTotalHeaderLength :: Int

22−defaultMaxTotalHeaderLength = settingsMaxTotalHeaderLength defaultSettings

23−

2420spec :: Spec

2521spec = do

2622 describe "headerLines" $ do

@@ -67,29 +63,29 @@ spec = do

6763 describe "headerLines" $ do

6864 it "can handle a nomarl case" $ do

6965 src <- mkSourceFunc ["Status: 200\r\nContent-Type: text/plain\r\n\r\n"] >>= mkSource

70− x <- headerLines defaultMaxTotalHeaderLength True src

66+ x <- headerLines True src

7167 x `shouldBe` ["Status: 200", "Content-Type: text/plain"]

7268

7369 it "can handle a nasty case (1)" $ do

7470 src <- mkSourceFunc ["Status: 200", "\r\nContent-Type: text/plain", "\r\n\r\n"] >>= mkSource

75− x <- headerLines defaultMaxTotalHeaderLength True src

71+ x <- headerLines True src

7672 x `shouldBe` ["Status: 200", "Content-Type: text/plain"]

7773

7874 it "can handle a nasty case (1)" $ do

7975 src <- mkSourceFunc ["Status: 200", "\r", "\nContent-Type: text/plain", "\r", "\n\r\n"] >>= mkSource

80− x <- headerLines defaultMaxTotalHeaderLength True src

76+ x <- headerLines True src

8177 x `shouldBe` ["Status: 200", "Content-Type: text/plain"]

8278

8379 it "can handle a nasty case (1)" $ do

8480 src <- mkSourceFunc ["Status: 200", "\r", "\n", "Content-Type: text/plain", "\r", "\n", "\r", "\n"] >>= mkSource

85− x <- headerLines defaultMaxTotalHeaderLength True src

81+ x <- headerLines True src

8682 x `shouldBe` ["Status: 200", "Content-Type: text/plain"]

8783

8884 it "can handle an illegal case (1)" $ do

8985 src <- mkSourceFunc ["\nStatus:", "\n 200", "\nContent-Type: text/plain", "\r\n\r\n"] >>= mkSource

90− x <- headerLines defaultMaxTotalHeaderLength True src

86+ x <- headerLines True src

9187 x `shouldBe` []

92− y <- headerLines defaultMaxTotalHeaderLength True src

88+ y <- headerLines True src

9389 y `shouldBe` ["Status: 200", "Content-Type: text/plain"]

9490

9591 where

@@ -115,7 +111,7 @@ headerLinesList' orig = do

115111 writeIORef ref z

116112 return y

117113 src' <- mkSource src

118− res <- headerLines defaultMaxTotalHeaderLength True src'

114+ res <- headerLines True src'

119115 return (res, src')

120116

121117consumeLen :: Int -> Source -> IO S8.ByteString

warp/warp.cabal+1−1

@@ -1,5 +1,5 @@

11Name: warp

2−Version: 3.3.9

2+Version: 3.3.6

33Synopsis: A fast, light-weight web server for WAI applications.

44License: MIT

55License-file: LICENSE