cddb62e · typeable/wai

.travis.yml+1−1

@@ -4,7 +4,7 @@ install:

44 - sudo apt-get install libfcgi-dev

55 - cabal unpack wai-logger

66 - mv wai-logger-* wai-logger

7− - cabal install mega-sdist hspec doctest HTTP cabal-meta cabal-src

7+ - cabal install hspec doctest HTTP cabal-meta cabal-src

88 - cabal-meta install --force-reinstalls

99

1010script: mega-sdist --test

mime-types/Network/Mime.hs+2−2

@@ -49,9 +49,9 @@ mimeByExt mm def =

4949defaultMimeLookup :: FileName -> MimeType

5050defaultMimeLookup = mimeByExt defaultMimeMap defaultMimeType

5151

52−-- | Get a list of all of the file name extensions from a piece.

52+-- | Get a list of all of the file name extensions.

5353--

54−-- > pieceExtensions "foo.tar.gz" == ["tar.gz", "gz"]

54+-- > fileNameExtensions "foo.tar.gz" == ["tar.gz", "gz"]

5555fileNameExtensions :: FileName -> [Extension]

5656fileNameExtensions =

5757 go . T.toLower . dropToExt

mime-types/mime-types.cabal+1−1

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

11name: mime-types

2−version: 0.1.0.3

2+version: 0.1.0.4

33synopsis: Basic mime-type handling types and functions

44description: Basic mime-type handling types and functions

55homepage: https://github.com/yesodweb/wai

wai/Network/Wai/Internal.hs+8−6

@@ -46,26 +46,28 @@ data Request = Request {

4646 , isSecure :: Bool

4747 -- | The client\'s host information.

4848 , remoteHost :: SockAddr

49− -- | Path info in individual pieces- the url without a hostname/port and without a query string, split on forward slashes,

49+ -- | Path info in individual pieces- the url without a hostname/port and

50+ -- without a query string, split on forward slashes.

5051 , pathInfo :: [Text]

5152 -- | Parsed query string information

5253 , queryString :: H.Query

5354 -- | A request body provided as 'Source'.

5455 , requestBody :: C.Source IO B.ByteString

5556 -- | A location for arbitrary data to be shared by applications and middleware.

56− , vault :: Vault

57− -- | The size of the request body. In the case of a chunked request body, this may be unknown.

57+ , vault :: Vault

58+ -- | The size of the request body. In the case of a chunked request body,

59+ -- this may be unknown.

5860 --

5961 -- Since 1.4.0

60− , requestBodyLength :: RequestBodyLength

62+ , requestBodyLength :: RequestBodyLength

6163 -- | The value of the Host header in a HTTP request.

6264 --

6365 -- Since 2.0.0

64− , requestHeaderHost :: Maybe B.ByteString

66+ , requestHeaderHost :: Maybe B.ByteString

6567 -- | The value of the Range header in a HTTP request.

6668 --

6769 -- Since 2.0.0

68− , requestHeaderRange :: Maybe B.ByteString

70+ , requestHeaderRange :: Maybe B.ByteString

6971 }

7072 deriving (Typeable)

7173

wai/README.md+4−3

@@ -11,12 +11,10 @@ You want a minimal example? Here it is!

1111import Network.Wai

1212import Network.HTTP.Types

1313import Network.Wai.Handler.Warp (run)

14−import Data.ByteString.Lazy.Char8 () -- Just for an orphan instance

15−import Control.Monad.IO.Class (liftIO)

1614

1715app :: Application

1816app _ = do

19− liftIO $ putStrLn "I've done some IO here"

17+ putStrLn "I've done some IO here"

2018 return $ responseLBS

2119 status200

2220 [("Content-Type", "text/plain")]

@@ -54,6 +52,7 @@ Now we redefine `responseBody` to refer to that file:

5452app2 :: Application

5553app2 _ = return index

5654

55+index :: Response

5756index = responseFile

5857 status200

5958 [("Content-Type", "text/html")]

@@ -79,12 +78,14 @@ app3 request = case rawPathInfo request of

7978 "/raw/" -> return plainIndex

8079 _ -> return notFound

8180

81+plainIndex :: Response

8282plainIndex = responseFile

8383 status200

8484 [("Content-Type", "text/plain")]

8585 "index.html"

8686 Nothing

8787

88+notFound :: Response

8889notFound = responseLBS

8990 status404

9091 [("Content-Type", "text/plain")]

wai/wai.cabal+2−2

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

11Name: wai

2−Version: 2.1.0.1

2+Version: 2.1.0.2

33Synopsis: Web Application Interface.

44Description: Provides a common protocol for communication between web applications and web servers.

55License: MIT

@@ -21,7 +21,7 @@ Library

2121 , bytestring >= 0.9.1.4

2222 , blaze-builder >= 0.2.1.4 && < 0.4

2323 , conduit >= 1.0.8 && < 1.2

24− , conduit-extra

24+ , conduit-extra >= 1.0

2525 , network >= 2.2.1.5

2626 , http-types >= 0.7

2727 , text >= 0.7

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

@@ -121,7 +121,7 @@ runTLSSocket TLSSettings {..} set sock app = do

121121 { TLS.sharedCredentials = TLS.Credentials [credential]

122122 }

123123 }

124− runSettingsConnectionMaker set (getter params) app

124+ runSettingsConnectionMakerSecure set (getter params) app

125125 where

126126 getter params = do

127127 (s, sa) <- acceptSafe sock

@@ -171,14 +171,14 @@ runTLSSocket TLSSettings {..} set sock app = do

171171 , connBuffer = buf

172172 , connBufferSize = bufferSize

173173 }

174− return conn

174+ return (conn, True)

175175 else

176176 case onInsecure of

177177 AllowInsecure -> do

178178 conn' <- socketConnection s

179− return conn'

179+ return (conn'

180180 { connRecv = getNext $ fmap (fromMaybe B.empty) C.await

181− }

181+ }, False)

182182 DenyInsecure lbs -> do

183183 let src = do

184184 C.yield "HTTP/1.1 200 OK\r\nContent-Type: text/plain\r\n\r\n"

warp-tls/pong.hs+4−1

@@ -13,7 +13,9 @@ import Network.HTTP.Conduit

1313main = do

1414 putStrLn "https://localhost:3009/"

1515 --manager <- newManager def

16− runTLS (tlsSettings "certificate.pem" "key.pem") defaultSettings { settingsPort = 3009 } app

16+ runTLS (tlsSettings "certificate.pem" "key.pem")

17+ { onInsecure = AllowInsecure

18+ } defaultSettings { settingsPort = 3009 } app

1719

1820app req = return $

1921 case rawPathInfo req of

@@ -23,6 +25,7 @@ app req = return $

2325 "/file/nolen" -> fileNoLen

2426 "/source/withlen" -> sourceWithLen

2527 "/source/nolen" -> sourceNoLen

28+ "/secure" -> responseLBS status200 [] $ if isSecure req then "secure" else "insecure"

2629 x -> index x

2730

2831builderWithLen = responseBuilder

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

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

11Name: warp-tls

2−Version: 2.0.3.2

2+Version: 2.0.3.3

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

44License: MIT

55License-file: LICENSE

@@ -16,7 +16,7 @@ Library

1616 Build-Depends: base >= 4 && < 5

1717 , bytestring >= 0.9

1818 , wai >= 2.0 && < 2.2

19− , warp >= 2.0.2 && < 2.2

19+ , warp >= 2.1.4 && < 2.2

2020 , transformers >= 0.2

2121 , conduit >= 0.5 && < 1.2

2222 , conduit-extra

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

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

2323 , runSettingsSocket

2424 , runSettingsConnection

2525 , runSettingsConnectionMaker

26+ , runSettingsConnectionMakerSecure

2627 -- * Settings

2728 , Settings

2829 , defaultSettings

warp/Network/Wai/Handler/Warp/Request.hs+7−10

@@ -165,11 +165,12 @@ close :: Sink ByteString IO a

165165close = throwIO IncompleteHeaders

166166

167167push :: THStatus -> ByteString -> Sink ByteString IO (Maybe ByteString, [ByteString])

168−push (THStatus len lines prepend) bs

168+push (THStatus len lines prepend) bs'

169169 -- Too many bytes

170170 | len > maxTotalHeaderLength = throwIO OverLargeHeader

171171 | otherwise = push' mnl

172172 where

173+ bs = prepend bs'

173174 bsLen = S.length bs

174175 mnl = do

175176 nl <- S.elemIndex 10 bs

@@ -191,13 +192,13 @@ push (THStatus len lines prepend) bs

191192 push' Nothing = await >>= maybe close (push status)

192193 where

193194 len' = len + bsLen

194− prepend' = prepend . S.append bs

195+ prepend' = S.append bs

195196 status = THStatus len' lines prepend'

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

197198 push' (Just (end, True)) = push status rest

198199 where

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

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

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

201202 len' = len + end

202203 status = THStatus len' lines prepend'

203204 -- Found a newline at position end.

@@ -215,18 +216,14 @@ push (THStatus len lines prepend) bs

215216 status = THStatus len' lines' id

216217 in if start < bsLen then

217218 -- more bytes in this chunk, push again

218− let bs' = SU.unsafeDrop start bs

219− in push status bs'

219+ let bs'' = SU.unsafeDrop start bs

220+ in push status bs''

220221 else

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

222223 await >>= maybe close (push status)

223224 where

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

225− line

226− -- There were some bytes before the newline, get them

227− | end > 0 = prepend $ SU.unsafeTake (checkCR bs end) bs

228− -- No bytes before the newline

229− | otherwise = prepend S.empty

226+ line = SU.unsafeTake (checkCR bs end) bs

230227

231228{-# INLINE checkCR #-}

232229checkCR :: ByteString -> Int -> Int

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

@@ -226,7 +226,7 @@ sendRsp conn ver s0 hs0 restore (RspFile path mPart mRange hook) = restore $ do

226226 where

227227 hs = addAcceptRanges hs0

228228 s2 = H.status404

229− hs2 = replaceHeader H.hContentType "text/plain" hs0

229+ hs2 = replaceHeader H.hContentType "text/plain; charset=utf-8" hs0

230230 body = fromByteString "File not found"

231231

232232----------------------------------------------------------------

warp/Network/Wai/Handler/Warp/Run.hs+17−6

@@ -1,6 +1,7 @@

11{-# LANGUAGE CPP #-}

22{-# LANGUAGE OverloadedStrings #-}

33{-# LANGUAGE ScopedTypeVariables #-}

4+{-# LANGUAGE TupleSections #-}

45{-# OPTIONS_GHC -fno-warn-deprecations #-}

56

67module Network.Wai.Handler.Warp.Run where

@@ -124,10 +125,18 @@ runSettingsConnection set getConn app = runSettingsConnectionMaker set getConnMa

124125 (conn, sa) <- getConn

125126 return (return conn, sa)

126127

128+runSettingsConnectionMaker :: Settings -> IO (IO Connection, SockAddr) -> Application -> IO ()

129+runSettingsConnectionMaker x y =

130+ runSettingsConnectionMakerSecure x (go y)

131+ where

132+ go = fmap (\(a, b) -> (fmap (, False) a, b))

133+

127134-- | Allows you to provide a function which will return a function

128135-- which will return 'Connection'.

129−runSettingsConnectionMaker :: Settings -> IO (IO Connection, SockAddr) -> Application -> IO ()

130−runSettingsConnectionMaker set getConnMaker app = do

136+--

137+-- Since 2.1.4

138+runSettingsConnectionMakerSecure :: Settings -> IO (IO (Connection, Bool), SockAddr) -> Application -> IO ()

139+runSettingsConnectionMakerSecure set getConnMaker app = do

131140 settingsBeforeMainLoop set

132141

133142 -- Note that there is a thorough discussion of the exception safety of the

@@ -175,7 +184,7 @@ runSettingsConnectionMaker set getConnMaker app = do

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

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

177186 -- fact that async exceptions are still masked.

178− bracket mkConn connClose $ \conn' ->

187+ bracket mkConn (connClose . fst) $ \(conn', isSecure') ->

179188

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

181190 -- cancel that handler as soon as we exit.

@@ -195,7 +204,7 @@ runSettingsConnectionMaker set getConnMaker app = do

195204

196205 -- Actually serve this connection.

197206 -- onnClose above ensures the termination of the connection.

198− when goingon $ serveConnection conn ii addr set app

207+ when goingon $ serveConnection conn ii addr isSecure' set app

199208 where

200209 -- FIXME: only IOEception is caught. What about other exceptions?

201210 getConnLoop = getConnMaker `E.catch` \(e :: IOException) -> do

@@ -222,10 +231,11 @@ runSettingsConnectionMaker set getConnMaker app = do

222231serveConnection :: Connection

223232 -> InternalInfo

224233 -> SockAddr

234+ -> Bool -- ^ is secure?

225235 -> Settings

226236 -> Application

227237 -> IO ()

228−serveConnection conn ii addr settings app = do

238+serveConnection conn ii addr isSecure' settings app = do

229239 istatus <- newIORef False

230240 recvSendLoop istatus (connSource conn th istatus) `E.catch` \e -> do

231241 sendErrorResponse istatus e

@@ -244,7 +254,8 @@ serveConnection conn ii addr settings app = do

244254 errorResponse e = settingsOnExceptionResponse settings e

245255

246256 recvSendLoop istatus fromClient = do

247− (req, idxhdr, getSource, leftover') <- recvRequest settings conn ii addr fromClient

257+ (req', idxhdr, getSource, leftover') <- recvRequest settings conn ii addr fromClient

258+ let req = req' { isSecure = isSecure' }

248259 intercept' <- settingsIntercept settings req

249260 case intercept' of

250261 Nothing -> do

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

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

11{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, ViewPatterns #-}

2+{-# LANGUAGE PatternGuards #-}

23

34module Network.Wai.Handler.Warp.Settings where

45

@@ -7,7 +8,6 @@ import Control.Monad (when)

78import qualified Data.ByteString as S

89import qualified Data.Text as T

910import qualified Data.Text.IO as TIO

10−import qualified Data.ByteString.Lazy.Char8 as L8

1111import Data.Conduit

1212import Data.Conduit.Network (HostPreference)

1313import GHC.IO.Exception (IOErrorType(..))

@@ -18,6 +18,8 @@ import Network.Wai.Handler.Warp.Timeout

1818import Network.Wai.Handler.Warp.Types

1919import System.IO (stderr)

2020import System.IO.Error (ioeGetErrorType)

21+import qualified Data.Text.Lazy as TL

22+import qualified Data.Text.Lazy.Encoding as TLE

2123

2224-- | Various Warp server settings. This is purposely kept as an abstract data

2325-- type so that new settings can be added without breaking backwards

@@ -97,11 +99,11 @@ defaultExceptionHandler _ e =

9799 $ TIO.hPutStrLn stderr $ T.pack $ show e

98100

99101defaultExceptionResponse :: SomeException -> Response

100−defaultExceptionResponse _ = responseLBS H.internalServerError500 [(H.hContentType, "text/plain")] "Something went wrong"

102+defaultExceptionResponse _ = responseLBS H.internalServerError500 [(H.hContentType, "text/plain; charset=utf-8")] "Something went wrong"

101103

102104-- | Default implementation of 'settingsOnExceptionResponse' for the debugging purpose. 500, text/plain, a showed exception.

103105exceptionResponseForDebug :: SomeException -> Response

104−exceptionResponseForDebug e = responseLBS H.internalServerError500 [(H.hContentType, "text/plain")] (L8.pack $ "Exception: " ++ show e)

106+exceptionResponseForDebug e = responseLBS H.internalServerError500 [(H.hContentType, "text/plain; charset=utf-8")] (TLE.encodeUtf8 $ TL.pack $ "Exception: " ++ show e)

105107

106108{-# DEPRECATED settingsPort "Use setPort instead" #-}

107109{-# DEPRECATED settingsHost "Use setHost instead" #-}

warp/test/ExceptionSpec.hs+14−7

@@ -13,13 +13,21 @@ import Network.Wai.Internal (Request(..))

1313import Network.Wai.Handler.Warp

1414import System.IO.Unsafe (unsafePerformIO)

1515import Test.Hspec

16+import Control.Exception

17+import qualified Data.Streaming.Network as N

18+import Control.Concurrent.Async (withAsync)

19+import Network.Socket (sClose)

1620

1721main :: IO ()

1822main = hspec spec

1923

20−testServer :: IO ()

21−testServer =

22− run 2345 testApp

24+withTestServer :: (Int -> IO a) -> IO a

25+withTestServer inner = bracket

26+ (N.bindRandomPortTCP "*4")

27+ (sClose . snd)

28+ $ \(port, lsocket) -> do

29+ withAsync (runSettingsSocket defaultSettings lsocket testApp)

30+ $ \_ -> inner port

2331

2432testApp :: Application

2533testApp (Network.Wai.Internal.Request {pathInfo = [x]})

@@ -38,8 +46,7 @@ testApp _ =

3846 return $ responseLBS ok200 [] "foo"

3947

4048spec :: Spec

41−spec = unsafePerformIO $ (forkIO testServer >> threadDelay 100000 >>) $ return $

42− describe "responds even if there is an exception" $ do

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

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

4451 it "statusError" $ do

4552 sc <- rspCode <$> sendGET "http://localhost:2345/statusError"

@@ -54,8 +61,8 @@ spec = unsafePerformIO $ (forkIO testServer >> threadDelay 100000 >>) $ return $

5461 sc <- rspCode <$> sendGET "http://localhost:2345/bodyError"

5562 sc `shouldBe` (5,0,0)

5663 -}

57− it "ioException" $ do

58− sc <- rspCode <$> sendGET "http://localhost:2345/ioException"

64+ it "ioException" $ withTestServer $ \port -> do

65+ sc <- rspCode <$> sendGET (concat $ ["http://localhost:", show port, "/ioException"])

5966 sc `shouldBe` (5,0,0)

6067

6168----------------------------------------------------------------

warp/test/RequestSpec.hs+28−4

@@ -5,17 +5,17 @@

55module RequestSpec (main, spec) where

66

77import Data.Conduit

8−import Data.Conduit.List

8+import qualified Data.Conduit.Binary as CB

9+import Data.Conduit.List (sourceList)

910import Network.Wai.Handler.Warp.Request

1011import Network.Wai.Handler.Warp.RequestHeader (parseByteRanges)

1112import Network.Wai.Handler.Warp.Types

1213import Test.Hspec

14+import Test.Hspec.QuickCheck

1315import qualified Data.ByteString.Char8 as S8

16+import qualified Data.ByteString.Lazy as L

1417import qualified Network.HTTP.Types.Header as HH

1518

16−deriving instance Show HH.ByteRange

17−deriving instance Eq HH.ByteRange

18−

1919main :: IO ()

2020main = hspec spec

2121

@@ -30,6 +30,30 @@ spec = do

3030 tooMany `shouldThrow` overLargeHeader

3131 it "throws OverLargeHeader when too large" $

3232 tooLarge `shouldThrow` overLargeHeader

33+ it "known bad chunking behavior #239" $ do

34+ let chunks =

35+ [ "GET / HTTP/1.1\r\nConnection: Close\r"

36+ , "\n\r\n"

37+ ]

38+ (mleftover, actual) <- mapM_ yield chunks $$ headerLines

39+ mleftover `shouldBe` Nothing

40+ actual `shouldBe` ["GET / HTTP/1.1", "Connection: Close"]

41+ prop "random chunking" $ \breaks extraS -> do

42+ let bsFull = "GET / HTTP/1.1\r\nConnection: Close\r\n\r\n" `S8.append` extra

43+ extra = S8.pack extraS

44+ chunks = loop breaks bsFull

45+ loop [] bs = [bs, undefined]

46+ loop (x:xs) bs =

47+ bs1 : loop xs bs2

48+ where

49+ (bs1, bs2) = S8.splitAt ((x `mod` 10) + 1) bs

50+ (leftover, actual) <- mapM_ yield chunks $$ do

51+ (_, actual) <- headerLines

52+ x' <- CB.take (length extraS)

53+ let x = S8.concat $ L.toChunks x'

54+ return (x, actual)

55+ actual `shouldBe` ["GET / HTTP/1.1", "Connection: Close"]

56+ leftover `shouldBe` extra

3357 describe "parseByteRanges" $ do

3458 let test x y = it x $ parseByteRanges (S8.pack x) `shouldBe` y

3559 test "bytes=0-499" $ Just [HH.ByteRangeFromTo 0 499]

warp/warp.cabal+4−3

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

11Name: warp

2−Version: 2.1.3.3

2+Version: 2.1.4

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

44License: MIT

55License-file: LICENSE

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

131131 , conduit >= 0.5

132132 , ghc-prim

133133 , HTTP

134− , http-types >= 0.7

134+ , http-types >= 0.8.4

135135 , lifted-base >= 0.1

136136 , network-conduit

137137 , simple-sendfile >= 0.2.4 && < 0.3

@@ -147,7 +147,8 @@ Test-Suite spec

147147 , old-locale

148148 , text

149149 , conduit-extra

150− , streaming-commons

150+ , streaming-commons >= 0.1.1

151+ , async

151152

152153 if (os(linux) || os(freebsd) || os(darwin)) && flag(allow-sendfilefd)

153154 Cpp-Options: -DSENDFILEFD