44b5d84 · typeable/wai

git.iko.soy/typeable/wai

on master help sign in

WAI 0.4

44b5d84Michael Snoyman16 years ago

Network/Wai/Handler/Warp.hs+34−21

compare with master

unifiedsplit

@@ -87,6 +87,8 @@ import qualified Timeout as T

87import Data.Word (Word8)

88import Data.List (foldl')

89import Control.Monad (forever)

90+import qualified Network.HTTP.Types as H

91+import qualified Data.Ascii as A

91#if WINDOWS

93#if WINDOWS

92import Control.Concurrent (threadDelay)

94import Control.Concurrent (threadDelay)

@@ -149,6 +151,7 @@ serveConnections' set app socket = do

149 tm <- T.initialize $ settingsTimeout set * 1000000

151 tm <- T.initialize $ settingsTimeout set * 1000000

150 forever $ do

152 forever $ do

151 (conn, sa) <- accept socket

153 (conn, sa) <- accept socket

154+ putStrLn "Accepted a connection"

152 _ <- forkIO $ do

155 _ <- forkIO $ do

153 th <- T.registerKillThread tm

156 th <- T.registerKillThread tm

154 serveConnection th onE port app conn sa

157 serveConnection th onE port app conn sa

@@ -214,19 +217,22 @@ parseRequest' port (firstLine:otherLines) remoteHost' = do

214 then S.breakByte 47 $ S.drop 7 rpath' -- '/'

217 then S.breakByte 47 $ S.drop 7 rpath' -- '/'

215 else ("", rpath')

218 else ("", rpath')

216 let heads = map parseHeaderNoAttr otherLines

219 let heads = map parseHeaderNoAttr otherLines

220+ let host = A.toByteString $ fromMaybe (A.unsafeFromByteString host')

217− let host = fromMaybe host' $ lookup "host" heads

221+ $ lookup "host" heads

218 let len =

222 let len =

219 case lookup "content-length" heads of

223 case lookup "content-length" heads of

220 Nothing -> 0

224 Nothing -> 0

221− Just bs -> fromIntegral $ B.foldl' (\i c -> i * 10 + C.digitToInt c) 0 $ B.takeWhile C.isDigit bs

225+ Just bs -> fromIntegral $ B.foldl' (\i c -> i * 10 + C.digitToInt c) 0 $ B.takeWhile C.isDigit $ A.toByteString bs

222 let serverName' = takeUntil 58 host -- ':'

226 let serverName' = takeUntil 58 host -- ':'

223 -- FIXME isolate takes an Integer instead of Int or Int64. If this is a

227 -- FIXME isolate takes an Integer instead of Int or Int64. If this is a

224 -- performance penalty, we may need our own version.

228 -- performance penalty, we may need our own version.

225 return (EB.isolate len, Request

229 return (EB.isolate len, Request

226− { requestMethod = method

230+ { requestMethod = A.unsafeFromByteString method

227 , httpVersion = httpversion

231 , httpVersion = httpversion

228− , pathInfo = rpath

232+ , pathInfo = H.decodePathSegments rpath

233+ , rawPathInfo = rpath

234+ , rawQueryString = gets

229− , queryString = gets

235+ , queryString = H.parseQuery gets

230 , serverName = serverName'

236 , serverName = serverName'

231 , serverPort = port

237 , serverPort = port

232 , requestHeaders = heads

238 , requestHeaders = heads

@@ -244,14 +250,18 @@ takeUntil c bs =

244{-# INLINE takeUntil #-}

250{-# INLINE takeUntil #-}

245

251

246parseFirst :: ByteString

252parseFirst :: ByteString

247− -> E.Iteratee S.ByteString IO (ByteString, ByteString, ByteString, HttpVersion)

253+ -> E.Iteratee S.ByteString IO (ByteString, ByteString, ByteString, H.HttpVersion)

248parseFirst s =

254parseFirst s =

249 case S.split 32 s of -- ' '

255 case S.split 32 s of -- ' '

250 [method, query, http'] -> do

256 [method, query, http'] -> do

251 let (hfirst, hsecond) = B.splitAt 5 http'

257 let (hfirst, hsecond) = B.splitAt 5 http'

252 if hfirst == "HTTP/"

258 if hfirst == "HTTP/"

253 then let (rpath, qstring) = S.breakByte 63 query -- '?'

259 then let (rpath, qstring) = S.breakByte 63 query -- '?'

260+ hv =

261+ case hsecond of

262+ "1.1" -> H.http11

263+ _ -> H.http10

254− in return (method, rpath, qstring, hsecond)

264+ in return (method, rpath, qstring, hv)

255 else E.throwError NonHttp

265 else E.throwError NonHttp

256 _ -> E.throwError $ BadFirstLine $ B.unpack s

266 _ -> E.throwError $ BadFirstLine $ B.unpack s

257{-# INLINE parseFirst #-} -- FIXME is this inline necessary? the function is only called from one place and not exported

267{-# INLINE parseFirst #-} -- FIXME is this inline necessary? the function is only called from one place and not exported

@@ -264,14 +274,17 @@ newlineBuilder = copyByteString "\r\n"

264transferEncodingBuilder = copyByteString "Transfer-Encoding: chunked\r\n\r\n"

274transferEncodingBuilder = copyByteString "Transfer-Encoding: chunked\r\n\r\n"

265colonSpaceBuilder = copyByteString ": "

275colonSpaceBuilder = copyByteString ": "

266

276

267−headers :: HttpVersion -> Status -> ResponseHeaders -> Bool -> Builder

277+headers :: H.HttpVersion -> H.Status -> H.ResponseHeaders -> Bool -> Builder

268headers !httpversion !status !responseHeaders !isChunked' = {-# SCC "headers" #-}

278headers !httpversion !status !responseHeaders !isChunked' = {-# SCC "headers" #-}

269 let !start = httpBuilder

279 let !start = httpBuilder

270− `mappend` copyByteString httpversion

280+ `mappend` (copyByteString $

281+ case httpversion of

282+ H.HttpVersion 1 1 -> "1.1"

283+ _ -> "1.0")

271 `mappend` spaceBuilder

284 `mappend` spaceBuilder

272− `mappend` fromShow (statusCode status)

285+ `mappend` fromShow (H.statusCode status)

273 `mappend` spaceBuilder

286 `mappend` spaceBuilder

274− `mappend` copyByteString (statusMessage status)

287+ `mappend` copyByteString (A.toByteString $ H.statusMessage status)

275 `mappend` newlineBuilder

288 `mappend` newlineBuilder

276 !start' = foldl' responseHeaderToBuilder start responseHeaders

289 !start' = foldl' responseHeaderToBuilder start responseHeaders

277 !end = if isChunked'

290 !end = if isChunked'

@@ -279,21 +292,21 @@ headers !httpversion !status !responseHeaders !isChunked' = {-# SCC "headers" #-

279 else newlineBuilder

292 else newlineBuilder

280 in start' `mappend` end

293 in start' `mappend` end

281

294

282−responseHeaderToBuilder :: Builder -> (CIByteString, ByteString) -> Builder

295+responseHeaderToBuilder :: Builder -> (A.CIAscii, A.Ascii) -> Builder

283responseHeaderToBuilder b (x, y) = b

296responseHeaderToBuilder b (x, y) = b

284− `mappend` (copyByteString $ ciOriginal x)

297+ `mappend` (copyByteString $ A.ciToByteString x)

285 `mappend` colonSpaceBuilder

298 `mappend` colonSpaceBuilder

286− `mappend` copyByteString y

299+ `mappend` copyByteString (A.toByteString y)

287 `mappend` newlineBuilder

300 `mappend` newlineBuilder

288

301

289−isChunked :: HttpVersion -> Bool

302+isChunked :: H.HttpVersion -> Bool

290−isChunked = (==) http11

303+isChunked = (==) H.http11

291

304

292−hasBody :: Status -> Request -> Bool

305+hasBody :: H.Status -> Request -> Bool

293−hasBody s req = s /= (Status 204 "") && requestMethod req /= "HEAD"

306+hasBody s req = s /= (H.Status 204 "") && requestMethod req /= "HEAD"

294

307

295sendResponse :: T.Handle

308sendResponse :: T.Handle

296− -> Request -> HttpVersion -> Socket -> Response -> IO Bool

309+ -> Request -> H.HttpVersion -> Socket -> Response -> IO Bool

297sendResponse th req hv socket (ResponseFile s hs fp) = do

310sendResponse th req hv socket (ResponseFile s hs fp) = do

298 Sock.sendMany socket $ L.toChunks $ toLazyByteString $ headers hv s hs False

311 Sock.sendMany socket $ L.toChunks $ toLazyByteString $ headers hv s hs False

299 if hasBody s req

312 if hasBody s req

@@ -361,7 +374,7 @@ sendResponse th req hv socket (ResponseEnumerator res) =

361 step k (E.Chunks [x]) = k (E.Chunks [chunkedTransferEncoding x]) >>== chunk

374 step k (E.Chunks [x]) = k (E.Chunks [chunkedTransferEncoding x]) >>== chunk

362 step k (E.Chunks xs) = k (E.Chunks [chunkedTransferEncoding $ mconcat xs]) >>== chunk

375 step k (E.Chunks xs) = k (E.Chunks [chunkedTransferEncoding $ mconcat xs]) >>== chunk

363

376

364−parseHeaderNoAttr :: ByteString -> (CIByteString, ByteString)

377+parseHeaderNoAttr :: ByteString -> H.Header

365parseHeaderNoAttr s =

378parseHeaderNoAttr s =

366 let (k, rest) = S.breakByte 58 s -- ':'

379 let (k, rest) = S.breakByte 58 s -- ':'

367 restLen = S.length rest

380 restLen = S.length rest

@@ -369,7 +382,7 @@ parseHeaderNoAttr s =

369 rest' = if restLen > 1 && SU.unsafeTake 2 rest == ": "

382 rest' = if restLen > 1 && SU.unsafeTake 2 rest == ": "

370 then SU.unsafeDrop 2 rest

383 then SU.unsafeDrop 2 rest

371 else rest

384 else rest

372− in (mkCIByteString k, rest')

385+ in (A.toCIAscii $ A.unsafeFromByteString k, A.unsafeFromByteString rest')

373

386

374enumSocket :: T.Handle -> Int -> Socket -> E.Enumerator ByteString IO a

387enumSocket :: T.Handle -> Int -> Socket -> E.Enumerator ByteString IO a

375enumSocket th len socket =

388enumSocket th len socket =

warp.cabal+4−2

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

1Name: warp

2−Version: 0.3.2.3

2+Version: 0.4.0

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

4License: BSD3

5License-file: LICENSE

@@ -19,12 +19,14 @@ flag network-bytestring

19Library

20 Build-Depends: base >= 3 && < 5

21 , bytestring >= 0.9 && < 0.10

22− , wai >= 0.3.0 && < 0.4

22+ , wai >= 0.4 && < 0.5

23 , blaze-builder-enumerator >= 0.2 && < 0.3

24 , transformers >= 0.2 && < 0.3

25 , enumerator >= 0.4.5 && < 0.5

26 , blaze-builder >= 0.2.1.4 && < 0.3

27 , sendfile >= 0.7.2 && < 0.8

28+ , http-types >= 0.5 && < 0.6

29+ , ascii >= 0.0.2 && < 0.1

28 if flag(network-bytestring)

30 if flag(network-bytestring)

29 build-depends: network >= 2.2.1 && < 2.2.3

31 build-depends: network >= 2.2.1 && < 2.2.3

30 , network-bytestring >= 0.1.3 && < 0.1.4

32 , network-bytestring >= 0.1.3 && < 0.1.4