warp 0.3.3 → 0.4.0
raw patch · 2 files changed
+95/−75 lines, 2 filesdep +case-insensitivedep +http-typesdep ~blaze-builderdep ~wai
Dependencies added: case-insensitive, http-types
Dependency ranges changed: blaze-builder, wai
Files
- Network/Wai/Handler/Warp.hs +90/−72
- warp.cabal +5/−3
Network/Wai/Handler/Warp.hs view
@@ -25,22 +25,18 @@ module Network.Wai.Handler.Warp ( -- * Run a Warp server run- , runEx- , serveConnections- , serveConnections'- -- * Run a Warp server with full settings control , runSettings+ , runSettingsSocket+ -- * Settings , Settings , defaultSettings , settingsPort+ , settingsHost , settingsOnException , settingsTimeout -- * Datatypes , Port , InvalidRequest (..)- -- * Utility functions for other packages- , sendResponse- , parseRequest #if TEST , takeHeaders #endif@@ -48,17 +44,19 @@ import Prelude hiding (catch, lines) import Network.Wai-import qualified System.IO import Data.ByteString (ByteString) import qualified Data.ByteString as S import qualified Data.ByteString.Unsafe as SU import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy as L-import Network (listenOn, sClose, PortID(PortNumber), Socket)+import Network (sClose, Socket) import Network.Socket- ( accept, SockAddr+ ( accept, SockAddr (SockAddrInet), Family (AF_INET)+ , SocketType (Stream), listen, bindSocket, setSocketOption+ , SocketOption (ReuseAddr), iNADDR_ANY, inet_addr, SockAddr (SockAddrInet) )+import qualified Network.Socket import qualified Network.Socket.ByteString as Sock import Control.Exception ( bracket, finally, Exception, SomeException, catch@@ -81,13 +79,16 @@ (copyByteString, Builder, toLazyByteString, toByteStringIO) import Blaze.ByteString.Builder.Char8 (fromChar, fromShow) import Data.Monoid (mappend, mconcat)-import Network.Socket.SendFile (sendFileIterWith, Iter (..))+import Network.Socket.SendFile (sendFileIterWith,sendFileIterWith', Iter (..)) import Control.Monad.IO.Class (liftIO) import qualified Timeout as T import Data.Word (Word8) import Data.List (foldl') import Control.Monad (forever)+import qualified Network.HTTP.Types as H+import qualified Data.CaseInsensitive as CI+import System.IO (hPutStrLn, stderr) #if WINDOWS import Control.Concurrent (threadDelay)@@ -95,56 +96,52 @@ import Network.Socket (withSocketsDo) #endif --- | Run an 'Application' on the given port, ignoring all exceptions.-run :: Port -> Application -> IO ()-run = runEx (const $ return ())+bindPort :: Int -> String -> IO Socket+bindPort p s = do+ sock <- Network.Socket.socket AF_INET Stream 0+ h <- if s == "*" then return iNADDR_ANY else inet_addr s+ let addr = SockAddrInet (fromIntegral p) h+ setSocketOption sock ReuseAddr 1+ bindSocket sock addr+ listen sock 150+ return sock --- | Run an 'Application' on the given port, with the given exception handler.--- Please note that you will also receive 'InvalidRequest' exceptions.-runEx :: (SomeException -> IO ()) -> Port -> Application -> IO ()-runEx onE port = runSettings Settings- { settingsPort = port- , settingsOnException = onE- , settingsTimeout = 30- }+-- | Run an 'Application' on the given port. This calls 'runSettings' with+-- 'defaultSettings'.+run :: Port -> Application -> IO ()+run p = runSettings defaultSettings { settingsPort = p } +-- | Run a Warp server with the given settings. runSettings :: Settings -> Application -> IO () #if WINDOWS runSettings set app = withSocketsDo $ do var <- MV.newMVar Nothing let clean = MV.modifyMVar_ var $ \s -> maybe (return ()) sClose s >> return Nothing _ <- forkIO $ bracket- (listenOn $ PortNumber $ fromIntegral $ settingsPort set)+ (bindPort (settingsPort set) (settingsHost set)) (const clean) (\s -> do MV.modifyMVar_ var (\_ -> return $ Just s)- serveConnections' set app s)+ runSettingsSocket set s app) forever (threadDelay maxBound) `finally` clean #else runSettings set = bracket- (listenOn $ PortNumber $ fromIntegral $ settingsPort set)+ (bindPort (settingsPort set) (settingsHost set)) sClose .- serveConnections' set+ (flip (runSettingsSocket set)) #endif type Port = Int --- | Runs a server, listening on the given socket. The user is responsible for--- closing the socket after 'runWithSocket' completes. You must also supply a--- 'Port' argument for use in the 'serverPort' record; however, this field is--- only used for informational purposes. If you are in fact listening on a--- non-TCP socket, this can be a ficticious value.-serveConnections :: (SomeException -> IO ())- -> Port -> Application -> Socket -> IO ()-serveConnections onE port = serveConnections' defaultSettings- { settingsOnException = onE- , settingsPort = port- }--serveConnections' :: Settings- -> Application -> Socket -> IO ()-serveConnections' set app socket = do+-- | Same as 'runSettings', but uses a user-supplied socket instead of opening+-- one. This allows the user to provide, for example, Unix named socket, which+-- can be used when reverse HTTP proxying into your application.+--+-- Note that the 'settingsPort' will still be passed to 'Application's via the+-- 'serverPort' record.+runSettingsSocket :: Settings -> Socket -> Application -> IO ()+runSettingsSocket set socket app = do let onE = settingsOnException set port = settingsPort set tm <- T.initialize $ settingsTimeout set * 1000000@@ -168,15 +165,15 @@ where fromClient = enumSocket th bytesPerRead conn serveConnection' = do- (enumeratee, env) <- parseRequest port remoteHost'+ (len, env) <- parseRequest port remoteHost' -- Let the application run for as long as it wants liftIO $ T.pause th- res <- E.joinI $ enumeratee $$ app env+ res <- E.joinI $ EB.isolate len $$ app env liftIO $ T.resume th keepAlive <- liftIO $ sendResponse th env (httpVersion env) conn res if keepAlive then serveConnection' else return () -parseRequest :: Port -> SockAddr -> E.Iteratee S.ByteString IO (E.Enumeratee ByteString ByteString IO a, Request)+parseRequest :: Port -> SockAddr -> E.Iteratee S.ByteString IO (Integer, Request) parseRequest port remoteHost' = do headers' <- takeHeaders parseRequest' port headers' remoteHost'@@ -193,10 +190,8 @@ NotEnoughLines [String] | BadFirstLine String | NonHttp- | TooManyHeaders | IncompleteHeaders | OverLargeHeader- | SocketTimeout deriving (Show, Typeable, Eq) instance Exception InvalidRequest @@ -204,7 +199,7 @@ parseRequest' :: Port -> [ByteString] -> SockAddr- -> E.Iteratee S.ByteString IO (E.Enumeratee S.ByteString S.ByteString IO a, Request)+ -> E.Iteratee S.ByteString IO (Integer, Request) parseRequest' _ [] _ = E.throwError $ NotEnoughLines [] parseRequest' port (firstLine:otherLines) remoteHost' = do (method, rpath', gets, httpversion) <- parseFirst firstLine@@ -223,16 +218,17 @@ let serverName' = takeUntil 58 host -- ':' -- FIXME isolate takes an Integer instead of Int or Int64. If this is a -- performance penalty, we may need our own version.- return (EB.isolate len, Request+ return (len, Request { requestMethod = method , httpVersion = httpversion- , pathInfo = rpath- , queryString = gets+ , pathInfo = H.decodePathSegments rpath+ , rawPathInfo = rpath+ , rawQueryString = gets+ , queryString = H.parseQuery gets , serverName = serverName' , serverPort = port , requestHeaders = heads , isSecure = False- , errorHandler = System.IO.hPutStr System.IO.stderr , remoteHost = remoteHost' }) @@ -245,14 +241,18 @@ {-# INLINE takeUntil #-} parseFirst :: ByteString- -> E.Iteratee S.ByteString IO (ByteString, ByteString, ByteString, HttpVersion)+ -> E.Iteratee S.ByteString IO (ByteString, ByteString, ByteString, H.HttpVersion) parseFirst s = case S.split 32 s of -- ' ' [method, query, http'] -> do let (hfirst, hsecond) = B.splitAt 5 http' if hfirst == "HTTP/" then let (rpath, qstring) = S.breakByte 63 query -- '?'- in return (method, rpath, qstring, hsecond)+ hv =+ case hsecond of+ "1.1" -> H.http11+ _ -> H.http10+ in return (method, rpath, qstring, hv) else E.throwError NonHttp _ -> E.throwError $ BadFirstLine $ B.unpack s {-# INLINE parseFirst #-} -- FIXME is this inline necessary? the function is only called from one place and not exported@@ -265,14 +265,17 @@ transferEncodingBuilder = copyByteString "Transfer-Encoding: chunked\r\n\r\n" colonSpaceBuilder = copyByteString ": " -headers :: HttpVersion -> Status -> ResponseHeaders -> Bool -> Builder+headers :: H.HttpVersion -> H.Status -> H.ResponseHeaders -> Bool -> Builder headers !httpversion !status !responseHeaders !isChunked' = {-# SCC "headers" #-} let !start = httpBuilder- `mappend` copyByteString httpversion+ `mappend` (copyByteString $+ case httpversion of+ H.HttpVersion 1 1 -> "1.1"+ _ -> "1.0") `mappend` spaceBuilder- `mappend` fromShow (statusCode status)+ `mappend` fromShow (H.statusCode status) `mappend` spaceBuilder- `mappend` copyByteString (statusMessage status)+ `mappend` copyByteString (H.statusMessage status) `mappend` newlineBuilder !start' = foldl' responseHeaderToBuilder start responseHeaders !end = if isChunked'@@ -280,26 +283,31 @@ else newlineBuilder in start' `mappend` end -responseHeaderToBuilder :: Builder -> (CIByteString, ByteString) -> Builder+responseHeaderToBuilder :: Builder -> H.Header -> Builder responseHeaderToBuilder b (x, y) = b- `mappend` (copyByteString $ ciOriginal x)+ `mappend` copyByteString (CI.original x) `mappend` colonSpaceBuilder `mappend` copyByteString y `mappend` newlineBuilder -isChunked :: HttpVersion -> Bool-isChunked = (==) http11+isChunked :: H.HttpVersion -> Bool+isChunked = (==) H.http11 -hasBody :: Status -> Request -> Bool-hasBody s req = s /= (Status 204 "") && requestMethod req /= "HEAD"+hasBody :: H.Status -> Request -> Bool+hasBody s req = s /= (H.Status 204 "") && requestMethod req /= "HEAD" sendResponse :: T.Handle- -> Request -> HttpVersion -> Socket -> Response -> IO Bool-sendResponse th req hv socket (ResponseFile s hs fp) = do+ -> Request -> H.HttpVersion -> Socket -> Response -> IO Bool+sendResponse th req hv socket (ResponseFile s hs fp mpart) = do Sock.sendMany socket $ L.toChunks $ toLazyByteString $ headers hv s hs False if hasBody s req then do- sendFileIterWith tickler socket fp sendFileCount+ case mpart of+ Nothing -> sendFileIterWith tickler socket fp sendFileCount+ Just part ->+ sendFileIterWith' tickler socket fp sendFileCount+ (filePartOffset part)+ (filePartByteCount part) return $ lookup "content-length" hs /= Nothing else return True where@@ -362,7 +370,7 @@ 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 -> (CIByteString, ByteString)+parseHeaderNoAttr :: ByteString -> H.Header parseHeaderNoAttr s = let (k, rest) = S.breakByte 58 s -- ':' restLen = S.length rest@@ -370,7 +378,7 @@ rest' = if restLen > 1 && SU.unsafeTake 2 rest == ": " then SU.unsafeDrop 2 rest else rest- in (mkCIByteString k, rest')+ in (CI.mk k, rest') enumSocket :: T.Handle -> Int -> Socket -> E.Enumerator ByteString IO a enumSocket th len socket =@@ -404,19 +412,29 @@ liftIO $ T.pause th E.continue step +-- | Various Warp server settings. This is purposely kept as an abstract data+-- type so that new settings can be added without breaking backwards+-- compatibility. In order to create a 'Settings' value, use 'defaultSettings'+-- and record syntax to modify individual records. For example:+--+-- > defaultSettings { settingsTimeout = 20 } data Settings = Settings- { settingsPort :: Int- , settingsOnException :: SomeException -> IO ()- , settingsTimeout :: Int -- ^ seconds+ { settingsPort :: Int -- ^ Port to listen on. Default value: 3000+ , 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 } +-- | The default settings for the Warp server. See the individual settings for+-- the default value. defaultSettings :: Settings defaultSettings = Settings { settingsPort = 3000+ , settingsHost = "*" , settingsOnException = \e -> case fromException e of Just x -> go x- Nothing -> print e+ Nothing -> hPutStrLn stderr $ show e , settingsTimeout = 30 } where
warp.cabal view
@@ -1,5 +1,5 @@ Name: warp-Version: 0.3.3+Version: 0.4.0 Synopsis: A fast, light-weight web server for WAI applications. License: BSD3 License-file: LICENSE@@ -19,12 +19,14 @@ Library Build-Depends: base >= 3 && < 5 , bytestring >= 0.9 && < 0.10- , wai >= 0.3.0 && < 0.4+ , wai >= 0.4 && < 0.5 , blaze-builder-enumerator >= 0.2 && < 0.3 , transformers >= 0.2 && < 0.3 , enumerator >= 0.4.5 && < 0.5- , blaze-builder >= 0.2.1.4 && < 0.3+ , blaze-builder >= 0.2.1.4 && < 0.4 , sendfile >= 0.7.2 && < 0.8+ , http-types >= 0.6 && < 0.7+ , case-insensitive >= 0.2 && < 0.3 if flag(network-bytestring) build-depends: network >= 2.2.1 && < 2.2.3 , network-bytestring >= 0.1.3 && < 0.1.4