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 @@ -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 diff --git a/warp.cabal b/warp.cabal --- a/warp.cabal +++ b/warp.cabal @@ -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