374aaac..master · typeable/wai

git.iko.soy/typeable/wai

33 files changed+223−123

unifiedsplit

stack.yaml+1−1

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

1−resolver: lts-14.20

1+resolver: lts-14.22

22packages:

33- ./auto-update

44- ./mime-types

wai-app-static/ChangeLog.md+4

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

11# wai-app-static changelog

3+## 3.1.7.1

5+* Update the test suite too

37## 3.1.7

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

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

@@ -164,11 +164,13 @@ 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− -- 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.

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.

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

173175

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

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

243245 response :: StaticResponse -> IO W.ResponseReceived

244246 response (FileResponse file ch) = do

245247 mimetype <- ssGetMimeType ss file

246− let filesize = fileGetSize file

248+ -- let filesize = fileGetSize file

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

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

249251 -- range requests into account

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

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

3939 }

4040

4141#if MIN_VERSION_optparse_applicative(0, 10, 0)

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

4243option' = option auto

4344#else

4445option' = 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,7 +7,6 @@ module WaiAppStatic.Storage.Embedded.TH(

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

99import Codec.Compression.GZip (compress)

10−import Control.Applicative

1110import Data.ByteString.Unsafe (unsafePackAddressLen)

1211import Data.Either (lefts, rights)

1312import GHC.Exts (Int(..))

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

@@ -59,6 +59,8 @@ 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.

6264type Pieces = [Piece]

6365

6466-- | 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 "301 redirect when multiple slashes" $ webApp $ do

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

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

66− assertStatus 301 req

66+ assertStatus 302 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 "301 redirect when multiple slashes" $ absoluteApp $

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

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

7474 req <- request (setRawPathInfo defRequest path)

75− assertStatus 301 req

75+ assertStatus 302 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 "301 redirect to add a trailing slash on directories if missing" $ do

134+ context "302 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 301 req

137+ assertStatus 302 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 301 req

147+ assertStatus 302 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 301 req

161+ assertStatus 302 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

2+version: 3.1.7.1

33license: MIT

44license-file: LICENSE

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

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

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

1717import Control.Monad (unless)

1818import Network.HTTP.Types

1919import Data.ByteString.Builder (Builder)

20−import Data.IORef

2120import qualified Data.Conduit.List as CL

2221

2322-- | Stream the request body.

2423--

2524-- Since 3.0.0

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

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

2726sourceRequestBody req =

2827 loop

2928 where

30− go = liftIO (requestBody req)

29+ go = liftIO (getRequestBodyChunk req)

3130

3231 loop = do

3332 bs <- go

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

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

3938--

4039-- Since 3.0.0

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

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

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

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

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

4443 case mbuilder of

4544 Chunk b -> send b

4645 Flush -> flush)

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

5049--

5150-- Since 3.0.0

5251responseRawSource :: (MonadIO m, MonadIO n)

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

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

5453 -> Response

5554 -> Response

5655responseRawSource app =

wai-extra/ChangeLog.md+4

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

11# Changelog for wai-extra

3+## 3.0.29.1

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

37## 3.0.29

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

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

@@ -99,6 +99,10 @@ 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'.

102106 }

103107data SResponse = SResponse

104108 { simpleStatus :: H.Status

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

106110 , simpleBody :: L.ByteString

107111 }

108112 deriving (Show, Eq)

113+

109114request :: Request -> Session SResponse

110−request = srequest . flip SRequest L.empty

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

111123

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

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

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

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

167179 return response

168180

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

182+-- 'L.ByteString'.

169183srequest :: SRequest -> Session SResponse

170184srequest (SRequest req bod) = do

171− app <- ask

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

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

186+ request $

187+ req

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

189+ case bss of

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

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

192+ }

185193

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

187195runResponse 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+41−11

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

44import Control.Monad (void)

6+import qualified Data.IORef as IORef

68import qualified Data.Text.Encoding as TE

810import Data.Time.Calendar (fromGregorian)

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

5355 it "sets rawQueryString to empty string" $ do

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

5557

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+

5674 describe "request" $ do

5775

58− let simpleApp _req respond =

76+ let echoApp req respond = do

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

78+ let reqHeaders = requestHeaders req

5979 respond $

6080 responseLBS

6181 status200

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

63− "simple"

82+ reqHeaders

83+ reqBody

6484

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

66− sresp <- runSession (request defaultRequest) simpleApp

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

86+ sresp <- runSession (request defaultRequest) echoApp

6787 simpleStatus sresp `shouldBe` status200

6888

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

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+ }

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

76106

77107 let cookieApp req respond =

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

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

11Name: wai-extra

2−Version: 3.0.29

2+Version: 3.0.29.1

33Synopsis: Provides some basic WAI handlers and middleware.

44description:

55 Provides basic WAI handler and middleware functionality:

wai-websockets/server.lhs+6

@@ -8,6 +8,8 @@ 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

1113> import Data.Char (isPunctuation, isSpace)

1214> import Data.Monoid (mappend)

1315> import Data.Text (Text)

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

99101

100102> application state pending = do

101103> conn <- WS.acceptRequest pending

104+#if __GLASGOW_HASKELL__ >= 806

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

106+#else

102107> WS.forkPingThread conn 30

108+#endif

103109

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

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

wai-websockets/wai-websockets.cabal+1

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

4545 , text

4646 , file-embed

4747 , http-types

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

4849 else

4950 buildable: False

5051

warp-tls/ChangeLog.md+4

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

1+## 3.2.11

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

15## 3.2.10

37* 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

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

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.10

2+Version: 3.2.11

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

44License: MIT

55License-file: LICENSE

warp/ChangeLog.md+16

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

1+## 3.3.9

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

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

6+## 3.3.8

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+

117## 3.3.6

218

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

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

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

7474 , setGracefulShutdownTimeout

7575 , setGracefulCloseTimeout1

7676 , setGracefulCloseTimeout2

77+ , setMaxTotalHeaderLength

7778 -- ** Getters

7879 , getPort

7980 , getHost

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

123124 , defaultPushPromise

124125 ) where

125126

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

127+import Control.Exception (SomeException, throwIO)

127128import Data.Streaming.Network (HostPreference)

128129import qualified Data.Vault.Lazy as Vault

129130import Data.X509

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

436437 -> Settings -> Settings

437438setGracefulShutdownTimeout time y = y { settingsGracefulShutdownTimeout = time }

438439

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+

439447-- | Explicitly pause the slowloris timeout.

440448--

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

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

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

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

3535

3636conditionalRequest :: I.FileInfo

37− -> H.ResponseHeaders -> IndexedHeader

37+ -> H.ResponseHeaders

38+ -> IndexedHeader -- ^ Response

39+ -> IndexedHeader -- ^ Request

3840 -> RspFileInfo

39−conditionalRequest finfo hs0 reqidx = case condition of

41+conditionalRequest finfo hs0 rspidx reqidx = case condition of

4042 nobody@(WithoutBody _) -> nobody

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

42− addContentHeaders hs0 off len size

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

4346 in WithBody s hs off len

4447 where

4548 !mtime = I.fileInfoTime finfo

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

@@ -72,7 +72,8 @@ 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− case conditionalRequest finfo rsphdr reqidx of

75+ rspidx = indexResponseHeader rsphdr

76+ case conditionalRequest finfo rsphdr rspidx reqidx of

7677 WithoutBody s -> return $ responseNoBody s rsphdr

7778 WithBody s rsphdr' off bytes -> do

7879 let !off' = fromIntegral off

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

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

6969data ResponseHeaderIndex = ResContentLength

7070 | ResServer

7171 | ResDate

72+ | ResLastModified

7273 deriving (Enum,Bounded)

7374

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

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

7980responseKeyIndex hn = case BS.length bs of

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

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

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

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

8385 _ -> -1

8486 where

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

@@ -17,7 +17,9 @@ 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

2021import Network.Socket (Socket)

22+import qualified System.IO.Error as E

2123#if MIN_VERSION_network(3,1,0)

2224import Network.Socket (withFdSocket)

2325#else

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

9496 siz' = siz - len

9597 loop bss' siz'

9698

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.

97102receive :: Socket -> BufferPool -> Recv

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

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

99104#if MIN_VERSION_network(3,1,0)

100105 withFdSocket sock $ \fd -> do

101106#elif MIN_VERSION_network(3,0,0)

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

105110#endif

106111 let size' = fromIntegral size

107112 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

108118

109119receiveBuf :: Socket -> RecvBuf

110120receiveBuf sock buf0 siz0 = do

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

143153 else

144154 return bytes

145155

156+#ifndef mingw32_HOST_OS

146157-- fixme: the type of the return value

147158foreign import ccall unsafe "recv"

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

160+#endif

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

@@ -38,13 +38,7 @@ 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)

42−

43−----------------------------------------------------------------

44−

45−-- FIXME come up with good values here

46−maxTotalHeaderLength :: Int

47−maxTotalHeaderLength = 50 * 1024

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

4842

4943----------------------------------------------------------------

5044

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

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

6963

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

71− hdrlines <- headerLines firstRequest src

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

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

7367 let idxhdr = indexRequestHeader hdr

7468 expect = idxhdr ! fromEnum ReqExpect

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

107101

108102----------------------------------------------------------------

109103

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

111−headerLines firstRequest src = do

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

105+headerLines maxTotalHeaderLength firstRequest src = do

112106 bs <- readSource src

113107 if S.null bs

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

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

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

117111 -- the Run module for more details.

118112 then if firstRequest then throwIO ConnectionClosedByPeer else throwIO NoKeepAliveRequest

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

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

120114

121115data NoKeepAliveRequest = NoKeepAliveRequest

122116 deriving (Show, Typeable)

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

226220close = throwIO IncompleteHeaders

227221-}

228222

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

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

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

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

231225 -- Too many bytes

232226 | len > maxTotalHeaderLength = throwIO OverLargeHeader

233227 | otherwise = push' mnl

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

255249 push' Nothing = do

256250 bst <- readSource' src

257251 when (S.null bst) $ throwIO IncompleteHeaders

258− push src status bst

252+ push maxTotalHeaderLength src status bst

259253 where

260254 len' = len + bsLen

261255 prepend' = S.append bs

262256 status = THStatus len' lines prepend'

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

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

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

265259 where

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

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

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

280274 in if start < bsLen then

281275 -- more bytes in this chunk, push again

282276 let bs'' = SU.unsafeDrop start bs

283− in push src status bs''

277+ in push maxTotalHeaderLength src status bs''

284278 else do

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

286280 bst <- readSource' src

287281 when (S.null bs) $ throwIO IncompleteHeaders

288− push src status bst

282+ push maxTotalHeaderLength src status bst

289283 where

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

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

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

@@ -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 rsp

119+ (ms, mlen) <- sendRsp conn ii ver s hs rspidxhdr 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 RspNoBody

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

127127 logger req s Nothing

128128 T.tickle th

129129 return isPersist

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

196196 -> H.HttpVersion

197197 -> H.Status

198198 -> H.ResponseHeaders

199+ -> IndexedHeader -- Response

199200 -> Rsp

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

201202

202203----------------------------------------------------------------

203204

204−sendRsp conn _ ver s hs RspNoBody = do

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

205206 -- Not adding Content-Length.

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

207208 composeHeader ver s hs >>= connSendAll conn

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

209210

210211----------------------------------------------------------------

211212

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

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

213214 header <- composeHeaderBuilder ver s hs needsChunked

214215 let hdrBdy

215216 | needsChunked = header <> chunkedTransferEncoding body

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

222223

223224----------------------------------------------------------------

224225

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

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

226227 header <- composeHeaderBuilder ver s hs needsChunked

227228 (recv, finish) <- newByteStringBuilderRecv $ reuseBufferStrategy

228229 $ toBuilderBuffer (connWriteBuffer conn) (connBufferSize conn)

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

246247

247248----------------------------------------------------------------

248249

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

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

250251 withApp recv send

251252 return (Nothing, Nothing)

252253 where

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

260261

261262-- Sophisticated WAI applications.

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

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

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

265266 where

266267 beg = filePartOffset part

267268 len = filePartByteCount part

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

271272

272273-- Simple WAI applications.

273274-- Status is ignored

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

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

275276 efinfo <- E.try $ getFileInfo ii path

276277 case efinfo of

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

278279#ifdef WARP_DEBUG

279280 print _ex >>

280281#endif

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

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

285286

286287----------------------------------------------------------------

287288

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

290291 -> H.HttpVersion

291292 -> H.Status

292293 -> H.ResponseHeaders

294+ -> IndexedHeader

293295 -> FilePath

294296 -> Integer

295297 -> Integer

296298 -> Bool

297299 -> IO ()

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

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

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

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

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

301303 | otherwise = do

302304 lheader <- composeHeader ver s hs

303305 (mfd, fresher) <- getFd ii path

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

310312 -> InternalInfo

311313 -> H.HttpVersion

312314 -> H.ResponseHeaders

315+ -> IndexedHeader

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

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

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

315318 where

316319 s = H.notFound404

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

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

@@ -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, atomicModifyIORef')

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

2121import Data.Streaming.Network (bindPortTCP)

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

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

@@ -59,7 +59,11 @@ 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)

6263socketConnection set s = do

64+#else

65+socketConnection _ s = do

66+#endif

6367 bufferPool <- newBufferPool

6468 writeBuf <- allocateBuffer bufferSize

6569 let sendall = Sock.sendAll s

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

7680 if tm == 0 then

7781 close s

7882 else

79− gracefulClose s tm

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

8084#else

8185 , connClose = close s

8286#endif

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

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

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

284288 -- exceptions are thrown.

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

289+ handle (settingsOnException set Nothing) $

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

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

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

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

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

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

298299 -- fact that async exceptions are still masked.

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

300+ bracket mkConn cleanUp (serve unmask)

300301 where

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

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

308303

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

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

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

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

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

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

316309 -- allow async exceptions.

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

322315 -- above ensures the connection is closed.

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

324317 where

325− register = T.registerKillThread (timeoutManager ii)

326− (closeConn ref conn)

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

327319 cancel = T.cancel

328320

329321 onOpen adr = increase counter >> settingsOnOpen set adr

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

@@ -128,6 +128,10 @@ 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

131135 }

132136

133137-- | Specify usage of the PROXY protocol.

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

166170 , settingsGracefulShutdownTimeout = Nothing

167171 , settingsGracefulCloseTimeout1 = 0

168172 , settingsGracefulCloseTimeout2 = 2000

173+ , settingsMaxTotalHeaderLength = 50 * 1024

169174 }

170175

171176-- | 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 [] (indexRequestHeader reqhs) `shouldBe` ans'

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

2525

2626spec :: Spec

2727spec = do

warp/test/RequestSpec.hs+11−7

@@ -7,6 +7,7 @@ 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)

1011import Test.Hspec

1112import Test.Hspec.QuickCheck

1213import qualified Data.ByteString as S

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

1718main :: IO ()

1819main = hspec spec

1920

21+defaultMaxTotalHeaderLength :: Int

22+defaultMaxTotalHeaderLength = settingsMaxTotalHeaderLength defaultSettings

23+

2024spec :: Spec

2125spec = do

2226 describe "headerLines" $ do

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

6367 describe "headerLines" $ do

6468 it "can handle a nomarl case" $ do

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

66− x <- headerLines True src

70+ x <- headerLines defaultMaxTotalHeaderLength True src

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

6872

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

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

71− x <- headerLines True src

75+ x <- headerLines defaultMaxTotalHeaderLength True src

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

7377

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

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

76− x <- headerLines True src

80+ x <- headerLines defaultMaxTotalHeaderLength True src

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

7882

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

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

81− x <- headerLines True src

85+ x <- headerLines defaultMaxTotalHeaderLength True src

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

8387

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

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

86− x <- headerLines True src

90+ x <- headerLines defaultMaxTotalHeaderLength True src

8791 x `shouldBe` []

88− y <- headerLines True src

92+ y <- headerLines defaultMaxTotalHeaderLength True src

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

9094

9195 where

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

111115 writeIORef ref z

112116 return y

113117 src' <- mkSource src

114− res <- headerLines True src'

118+ res <- headerLines defaultMaxTotalHeaderLength True src'

115119 return (res, src')

116120

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

warp/warp.cabal+1−1

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

11Name: warp

2−Version: 3.3.6

2+Version: 3.3.9

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

44License: MIT

55License-file: LICENSE