warp 0.4.5 → 0.4.6
raw patch · 2 files changed
+117/−85 lines, 2 filesdep ~bytestringdep ~enumeratordep ~network
Dependency ranges changed: bytestring, enumerator, network, transformers, unix-compat
Files
- Network/Wai/Handler/Warp.hs +110/−78
- warp.cabal +7/−7
Network/Wai/Handler/Warp.hs view
@@ -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])
warp.cabal view
@@ -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