diff --git a/Network/Wai/Handler/Warp.hs b/Network/Wai/Handler/Warp.hs --- a/Network/Wai/Handler/Warp.hs +++ b/Network/Wai/Handler/Warp.hs @@ -34,6 +34,8 @@ , settingsHost , settingsOnException , settingsTimeout + , settingsIntercept + , settingsManager -- * Datatypes , Port , InvalidRequest (..) @@ -47,6 +49,9 @@ , enumSocket , pause , resume + , T.cancel + , T.register + , T.initialize #if TEST , takeHeaders , readInt @@ -105,8 +110,6 @@ import qualified Network.HTTP.Types as H import qualified Data.CaseInsensitive as CI import System.IO (hPutStrLn, stderr) -import qualified Paths_warp -import Data.Version (showVersion) import Data.List (delete) @@ -116,6 +119,15 @@ import Network.Socket (withSocketsDo) #endif +#ifndef MEGA +import Data.Version (showVersion) +import qualified Paths_warp +warpVersion = showVersion Paths_warp.version +#else +warpVersion = "0.4.6" +#endif +warpVersion :: String + bindPort :: Int -> String -> IO Socket bindPort p s = do let hints = defaultHints { addrFlags = [AI_PASSIVE @@ -177,19 +189,21 @@ runSettingsSocket set socket app = do let onE = settingsOnException set port = settingsPort set - tm <- T.initialize $ settingsTimeout set * 1000000 + tm <- maybe (T.initialize $ settingsTimeout set * 1000000) return + $ settingsManager set forever $ do (conn, sa) <- accept socket _ <- forkIO $ do th <- T.registerKillThread tm - serveConnection th onE port app conn sa + serveConnection set th onE port app conn sa T.cancel th return () -serveConnection :: T.Handle +serveConnection :: Settings + -> T.Handle -> (SomeException -> IO ()) -> Port -> Application -> Socket -> SockAddr -> IO () -serveConnection th onException port app conn remoteHost' = do +serveConnection settings th onException port app conn remoteHost' = do catch (finally (E.run_ $ fromClient $$ serveConnection') @@ -199,12 +213,17 @@ fromClient = enumSocket th bytesPerRead conn serveConnection' = do (len, env) <- parseRequest port remoteHost' - -- Let the application run for as long as it wants - liftIO $ T.pause th - res <- E.joinI $ EB.isolate len $$ app env - liftIO $ T.resume th - keepAlive <- liftIO $ sendResponse th env conn res - if keepAlive then serveConnection' else return () + case settingsIntercept settings env of + Nothing -> do + -- Let the application run for as long as it wants + liftIO $ T.pause th + res <- E.joinI $ EB.isolate len $$ app env + liftIO $ T.resume th + keepAlive <- liftIO $ sendResponse th env conn res + if keepAlive then serveConnection' else return () + Just intercept -> do + liftIO $ T.pause th + intercept conn parseRequest :: Port -> SockAddr -> E.Iteratee S.ByteString IO (Integer, Request) parseRequest port remoteHost' = do @@ -344,20 +363,30 @@ sendResponse :: T.Handle -> Request -> Socket -> Response -> IO Bool -sendResponse th req socket (ResponseFile s hs fp mpart) = do - (hs', cl) <- - case (readInt `fmap` lookup "content-length" hs, mpart) of - (Just cl, _) -> return (hs, cl) - (Nothing, Nothing) -> do - cl <- P.fileSize `fmap` P.getFileStatus fp - return (("Content-Length", B.pack $ show cl):hs, fromIntegral cl) - (Nothing, Just part) -> do - let cl = filePartByteCount part - return (("Content-Length", B.pack $ show cl):hs, fromIntegral cl) - Sock.sendMany socket $ L.toChunks $ toLazyByteString $ headers (httpVersion req) s hs' False - let isPersist= checkPersist req - if hasBody s req - then do +sendResponse th req socket r = sendResponse' r + where + version = httpVersion req + isPersist = checkPersist req + isChunked' = isChunked version + needsChunked hs = isChunked' && not (hasLength hs) + isKeepAlive hs = isPersist && (isChunked' || hasLength hs) + hasLength hs = lookup "content-length" hs /= Nothing + + sendResponse' :: Response -> IO Bool + sendResponse' (ResponseFile s hs fp mpart) = do + (lengthyHeaders, cl) <- + case (readInt `fmap` lookup "content-length" hs, mpart) of + (Just cl, _) -> return (hs, cl) + (Nothing, Nothing) -> do + cl <- P.fileSize `fmap` P.getFileStatus fp + return $ addClToHeaders cl + (Nothing, Just part) -> do + let cl = filePartByteCount part + return $ addClToHeaders cl + Sock.sendMany socket $ L.toChunks $ toLazyByteString $ + headers version s lengthyHeaders False + + if not (hasBody s req) then return isPersist else do case mpart of Nothing -> sendfile socket fp PartOfFile { rangeOffset = 0 @@ -369,59 +398,58 @@ } (T.tickle th) T.tickle th return isPersist - else return isPersist -sendResponse th req socket (ResponseBuilder s hs b) - | hasBody s req = do - toByteStringIO (\bs -> do - Sock.sendAll socket bs - T.tickle th) b' - return isKeepAlive - | otherwise = do - Sock.sendMany socket - $ L.toChunks - $ toLazyByteString - $ headers (httpVersion req) s hs False - T.tickle th - return True - where - headers' = headers (httpVersion req) s hs isChunked' - b' = if isChunked' - then headers' - `mappend` chunkedTransferEncoding b - `mappend` chunkedTransferTerminator - else headers (httpVersion req) s hs False `mappend` b - hasLength = lookup "content-length" hs /= Nothing - isChunked' = isChunked (httpVersion req) && not hasLength - isPersist = checkPersist req - isKeepAlive = isPersist && (isChunked' || hasLength) -sendResponse th req socket (ResponseEnumerator res) = - res go - where - -- FIXME perhaps alloca a buffer per thread and reuse that in all functiosn below. Should lessen greatly the GC burden (I hope) - go s hs | not (hasBody s req) = do - liftIO $ Sock.sendMany socket - $ L.toChunks $ toLazyByteString - $ headers (httpVersion req) s hs False - return True - go s hs = chunk' - $ E.enumList 1 [headers (httpVersion req) s hs isChunked'] - $$ E.joinI $ builderToByteString -- FIXME unsafeBuilderToByteString - $$ (iterSocket th socket >> return isKeepAlive) where - hasLength = lookup "content-length" hs /= Nothing - isChunked' = isChunked (httpVersion req) && not hasLength - isPersist = checkPersist req - isKeepAlive = isPersist && (isChunked' || hasLength) - chunk' i = if isChunked' - then E.joinI $ chunk $$ i - else i - chunk :: E.Enumeratee Builder Builder IO Bool - chunk = E.checkDone $ E.continue . step - step k E.EOF = k (E.Chunks [chunkedTransferTerminator]) >>== return - step k (E.Chunks []) = E.continue $ step k - step k (E.Chunks [x]) = k (E.Chunks [chunkedTransferEncoding x]) >>== chunk - step k (E.Chunks xs) = k (E.Chunks [chunkedTransferEncoding $ mconcat xs]) >>== chunk + addClToHeaders cl = (("Content-Length", B.pack $ show cl):hs, fromIntegral cl) + sendResponse' (ResponseBuilder s hs b) + | hasBody s req = do + toByteStringIO (\bs -> do + Sock.sendAll socket bs + T.tickle th) body + return (isKeepAlive hs) + | otherwise = do + Sock.sendMany socket + $ L.toChunks + $ toLazyByteString + $ headers' False + T.tickle th + return isPersist + where + headers' = headers version s hs + needsChunked' = needsChunked hs + body = if needsChunked' + then (headers' needsChunked') + `mappend` chunkedTransferEncoding b + `mappend` chunkedTransferTerminator + else (headers' False) `mappend` b + + sendResponse' (ResponseEnumerator res) = res enumResponse + where + enumResponse s hs = response True + where + headers' = headers version s hs + -- FIXME perhaps alloca a buffer per thread and reuse that in all functiosn below. Should lessen greatly the GC burden (I hope) + response _ | not (hasBody s req) = do + liftIO $ Sock.sendMany socket + $ L.toChunks $ toLazyByteString + $ headers' False + return (checkPersist req) + response _ = chunk' + $ E.enumList 1 [headers' needsChunked'] + $$ E.joinI $ builderToByteString -- FIXME unsafeBuilderToByteString + $$ (iterSocket th socket >> return (isKeepAlive hs)) + where + needsChunked' = needsChunked hs + chunk' i = if needsChunked' + then E.joinI $ chunk $$ i + else i + chunk :: E.Enumeratee Builder Builder IO Bool + chunk = E.checkDone $ E.continue . step + step k E.EOF = k (E.Chunks [chunkedTransferTerminator]) >>== return + step k (E.Chunks []) = E.continue $ step k + step k (E.Chunks [x]) = k (E.Chunks [chunkedTransferEncoding x]) >>== chunk + step k (E.Chunks xs) = k (E.Chunks [chunkedTransferEncoding $ mconcat xs]) >>== chunk + parseHeaderNoAttr :: ByteString -> H.Header parseHeaderNoAttr s = let (k, rest) = S.breakByte 58 s -- ':' @@ -475,6 +503,8 @@ , settingsHost :: String -- ^ Host to bind to, or * for all. Default value: * , settingsOnException :: SomeException -> IO () -- ^ What to do with exceptions thrown by either the application or server. Default: ignore server-generated exceptions (see 'InvalidRequest') and print application-generated applications to stderr. , settingsTimeout :: Int -- ^ Timeout value in seconds. Default value: 30 + , settingsIntercept :: Request -> Maybe (Socket -> E.Iteratee S.ByteString IO ()) + , settingsManager :: Maybe Manager -- ^ Use an existing timeout manager instead of spawning a new one. If used, 'settingsTimeout' is ignored. Default is 'Nothing' } -- | The default settings for the Warp server. See the individual settings for @@ -491,6 +521,8 @@ then hPutStrLn stderr $ show e else return () , settingsTimeout = 30 + , settingsIntercept = const Nothing + , settingsManager = Nothing } where go :: InvalidRequest -> IO () @@ -587,6 +619,6 @@ Just svr -> servers svr : delete (key,svr) hdrs where key = "Server" - ver = B.pack $ "Warp/" ++ showVersion Paths_warp.version + ver = B.pack $ "Warp/" ++ warpVersion server = (key, ver) servers svr = (key, S.concat [svr, " ", ver]) diff --git a/warp.cabal b/warp.cabal --- a/warp.cabal +++ b/warp.cabal @@ -1,11 +1,11 @@ Name: warp -Version: 0.4.5 +Version: 0.4.6 Synopsis: A fast, light-weight web server for WAI applications. License: BSD3 License-file: LICENSE Author: Michael Snoyman, Matt Brown Maintainer: michael@snoyman.com -Homepage: http://github.com/snoyberg/warp +Homepage: http://github.com/yesodweb/wai Category: Web, Yesod Build-Type: Simple Cabal-Version: >=1.6 @@ -17,18 +17,18 @@ Library Build-Depends: base >= 3 && < 5 - , bytestring >= 0.9 && < 0.10 + , bytestring >= 0.9.1.4 && < 0.10 , wai >= 0.4 && < 0.5 , blaze-builder-enumerator >= 0.2 && < 0.3 - , transformers >= 0.2 && < 0.3 - , enumerator >= 0.4.5 && < 0.5 + , transformers >= 0.2.2 && < 0.3 + , enumerator >= 0.4.8 && < 0.5 , blaze-builder >= 0.2.1.4 && < 0.4 , simple-sendfile >= 0.1 && < 0.2 , http-types >= 0.6 && < 0.7 , case-insensitive >= 0.2 && < 0.4 - , unix-compat >= 0.2 && < 0.3 + , unix-compat >= 0.2 if flag(network-bytestring) - build-depends: network >= 2.2.1 && < 2.2.3 + build-depends: network >= 2.2.1.5 && < 2.2.3 , network-bytestring >= 0.1.3 && < 0.1.4 else build-depends: network >= 2.3 && < 2.4