@@ -3,6 +3,7 @@
33{-# LANGUAGE OverloadedStrings #-}
44{-# LANGUAGE CPP #-}
55{-# LANGUAGE BangPatterns #-}
6+{-# LANGUAGE MagicHash #-}
67---------------------------------------------------------
78--
89-- Module : Network.Wai.Handler.Warp
@@ -83,8 +84,7 @@ import Control.Exception
8384 , bracketOnError
8485 )
8586import Control.Concurrent (forkIO)
86−import qualified Data.Char as C
87−import Data.Maybe (fromMaybe)
87+import Data.Maybe (fromMaybe, isJust)
8888
8989import Data.Typeable (Typeable)
9090
@@ -113,6 +113,8 @@ import Control.Monad (forever, when)
113113import qualified Network.HTTP.Types as H
114114import qualified Data.CaseInsensitive as CI
115115import System.IO (hPutStrLn, stderr)
116+import ReadInt (readInt64)
117+
116118
117119#if WINDOWS
118120import Control.Concurrent (threadDelay)
@@ -176,7 +178,7 @@ bindPort p s = do
176178 addr = if null addrs' then head addrs else head addrs'
177179 bracketOnError
178180 (Network.Socket.socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr))
179− (sClose)
181+ sClose
180182 (\sock -> do
181183 setSocketOption sock ReuseAddr 1
182184 bindSocket sock (addrAddress addr)
@@ -207,7 +209,7 @@ runSettings set =
207209 bracket
208210 (bindPort (settingsPort set) (settingsHost set))
209211 sClose .
210− (flip (runSettingsSocket set))
212+ flip (runSettingsSocket set)
211213#endif
212214
213215type Port = Int
@@ -219,7 +221,7 @@ type Port = Int
219221-- Note that the 'settingsPort' will still be passed to 'Application's via the
220222-- 'serverPort' record.
221223runSettingsSocket :: Settings -> Socket -> Application -> IO ()
222−runSettingsSocket set socket app = do
224+runSettingsSocket set socket app =
223225 runSettingsConnection set getter app
224226 where
225227 getter = do
@@ -244,7 +246,7 @@ serveConnection :: Settings
244246 -> T.Handle
245247 -> (SomeException -> IO ())
246248 -> Port -> Application -> Connection -> SockAddr -> IO ()
247−serveConnection settings th onException port app conn remoteHost' = do
249+serveConnection settings th onException port app conn remoteHost' =
248250 catch
249251 (finally
250252 (runResourceT serveConnection')
@@ -269,7 +271,7 @@ serveConnection settings th onException port app conn remoteHost' = do
269271
270272 liftIO $ T.resume th
271273 keepAlive <- sendResponse th env conn res
272− if keepAlive then serveConnection'' fromClient else return ()
274+ when keepAlive $ serveConnection'' fromClient
273275 Just intercept -> do
274276 liftIO $ T.pause th
275277 intercept fromClient conn
@@ -304,18 +306,16 @@ parseRequest' :: Port
304306parseRequest' _ [] _ _ = throwIO $ NotEnoughLines []
305307parseRequest' port (firstLine:otherLines) remoteHost' src = do
306308 (method, rpath', gets, httpversion) <- parseFirst firstLine
307− let (host',rpath) =
308− if S.null rpath'
309− then ("","/")
310− else if "http://" `S.isPrefixOf` rpath'
311− then S.breakByte 47 $ S.drop 7 rpath' -- '/'
312− else ("", rpath')
309+ let (host',rpath)
310+ | S.null rpath' = ("", "/")
311+ | "http://" `S.isPrefixOf` rpath' = S.breakByte 47 $ S.drop 7 rpath'
312+ | otherwise = ("", rpath')
313313 let heads = map parseHeaderNoAttr otherLines
314314 let host = fromMaybe host' $ lookup "host" heads
315315 let len =
316316 case lookup "content-length" heads of
317317 Nothing -> 0
318− Just bs -> fromIntegral $ B.foldl' (\i c -> i * 10 + C.digitToInt c) 0 $ B.takeWhile C.isDigit bs
318+ Just bs -> readInt bs
319319 let serverName' = takeUntil 58 host -- ':'
320320 -- FIXME isolate takes an Integer instead of Int or Int64. If this is a
321321 -- performance penalty, we may need our own version.
@@ -349,7 +349,7 @@ takeUntil c bs =
349349
350350parseFirst :: ByteString
351351 -> ResourceT IO (ByteString, ByteString, ByteString, H.HttpVersion)
352−parseFirst s =
352+parseFirst s =
353353 case S.split 32 s of -- ' '
354354 [method, query, http'] -> do
355355 let (hfirst, hsecond) = B.splitAt 5 http'
@@ -375,8 +375,8 @@ colonSpaceBuilder = copyByteString ": "
375375headers :: H.HttpVersion -> H.Status -> H.ResponseHeaders -> Bool -> Builder
376376headers !httpversion !status !responseHeaders !isChunked' = {-# SCC "headers" #-}
377377 let !start = httpBuilder
378− `mappend` (copyByteString $
379− case httpversion of
378+ `mappend` copyByteString
379+ (case httpversion of
380380 H.HttpVersion 1 1 -> "1.1"
381381 _ -> "1.0")
382382 `mappend` spaceBuilder
@@ -415,7 +415,7 @@ isChunked :: H.HttpVersion -> Bool
415415isChunked = (==) H.http11
416416
417417hasBody :: H.Status -> Request -> Bool
418−hasBody s req = s /= (H.Status 204 "") && s /= H.status304 &&
418+hasBody s req = s /= H.Status 204 "" && s /= H.status304 &&
419419 H.statusCode s >= 200 && requestMethod req /= "HEAD"
420420
421421sendResponse :: T.Handle
@@ -427,7 +427,7 @@ sendResponse th req conn r = sendResponse' r
427427 isChunked' = isChunked version
428428 needsChunked hs = isChunked' && not (hasLength hs)
429429 isKeepAlive hs = isPersist && (isChunked' || hasLength hs)
430− hasLength hs = lookup "content-length" hs /= Nothing
430+ hasLength hs = isJust $ lookup "content-length" hs
431431
432432 sendResponse' :: Response -> ResourceT IO Bool
433433 sendResponse' (ResponseFile s hs fp mpart) = liftIO $ do
@@ -471,10 +471,10 @@ sendResponse th req conn r = sendResponse' r
471471 headers' = headers version s hs
472472 needsChunked' = needsChunked hs
473473 body = if needsChunked'
474− then (headers' needsChunked')
474+ then headers' needsChunked'
475475 `mappend` chunkedTransferEncoding b
476476 `mappend` chunkedTransferTerminator
477− else (headers' False) `mappend` b
477+ else headers' False `mappend` b
478478
479479 sendResponse' (ResponseSource s hs body) =
480480 response
@@ -497,7 +497,7 @@ sendResponse th req conn r = sendResponse' r
497497 return $ isKeepAlive hs
498498 needsChunked' = needsChunked hs
499499 chunk :: C.Conduit Builder IO Builder
500− chunk = C.Conduit $ return $ C.PreparedConduit
500+ chunk = C.Conduit $ return C.PreparedConduit
501501 { C.conduitPush = push
502502 , C.conduitClose = close
503503 }
@@ -529,17 +529,18 @@ connSource Connection { connRecv = recv } th = C.PreparedSource
529529
530530-- | Use 'connSendAll' to send this data while respecting timeout rules.
531531connSink :: Connection -> T.Handle -> C.Sink B.ByteString IO ()
532−connSink Connection { connSendAll = send } th = C.Sink $ return $ C.SinkData
532+connSink Connection { connSendAll = send } th = C.Sink $ return C.SinkData
533533 { C.sinkPush = push
534534 , C.sinkClose = close
535535 }
536536 where
537537 close = liftIO (T.resume th)
538538 push x = do
539− liftIO $ T.resume th
540− liftIO $ send x
541− liftIO $ T.pause th
542− return $ C.Processing
539+ liftIO $ do
540+ T.resume th
541+ send x
542+ T.pause th
543+ return C.Processing
543544 -- We pause timeouts before passing control back to user code. This ensures
544545 -- that a timeout will only ever be executed when Warp is in control. We
545546 -- also make sure to resume the timeout after the completion of user code
@@ -573,9 +574,8 @@ defaultSettings = Settings
573574 case fromException e of
574575 Just x -> go x
575576 Nothing ->
576− if go' $ fromException e
577− then hPutStrLn stderr $ show e
578− else return ()
577+ when (go' $ fromException e) $
578+ hPutStrLn stderr $ show e
579579 , settingsTimeout = 30
580580 , settingsIntercept = const Nothing
581581 , settingsManager = Nothing
@@ -649,10 +649,10 @@ checkCR bs pos =
649649 else pos
650650{-# INLINE checkCR #-}
651651
652−-- Note: This function produces garbage on invalid input. But serving an
653−-- invalid content-length is a bad idea, mkay?
654−readInt :: S.ByteString -> Integer
655−readInt = S.foldl' (\x w -> x * 10 + fromIntegral w - 48) 0
652+readInt :: Integral a => ByteString -> a
653+readInt bs = fromIntegral $ readInt64 bs
654+{-# INLINE readInt #-}
655+
656656
657657-- | Call the inner function with a timeout manager.
658658withManager :: Int -- ^ timeout in microseconds