warp (empty) → 0.3.0
raw patch · 4 files changed
+419/−0 lines, 4 filesdep +basedep +blaze-builderdep +blaze-builder-enumeratorsetup-changed
Dependencies added: base, blaze-builder, blaze-builder-enumerator, bytestring, enumerator, network, network-bytestring, network-enumerator, sendfile, transformers, wai
Files
- LICENSE +25/−0
- Network/Wai/Handler/Warp.hs +346/−0
- Setup.lhs +7/−0
- warp.cabal +41/−0
+ LICENSE view
@@ -0,0 +1,25 @@+The following license covers this documentation, and the source code, except+where otherwise indicated.++Copyright 2010, Suite Solutions. All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++* Redistributions of source code must retain the above copyright notice, this+ list of conditions and the following disclaimer.++* Redistributions in binary form must reproduce the above copyright notice,+ this list of conditions and the following disclaimer in the documentation+ and/or other materials provided with the distribution.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO+EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT+NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,+OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE+OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF+ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Network/Wai/Handler/Warp.hs view
@@ -0,0 +1,346 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}+---------------------------------------------------------+-- |+-- Module : Network.Wai.Handler.Warp+-- Copyright : Michael Snoyman+-- License : BSD3+--+-- Maintainer : Michael Snoyman <michael@snoyman.com>+-- Stability : Stable+-- Portability : portable+--+-- A fast, light-weight HTTP server handler for WAI.+--+---------------------------------------------------------+module Network.Wai.Handler.Warp+ ( run+ , sendResponse+ , parseRequest+#if TEST+ , takeLineMax+ , takeHeaders+ , InvalidRequest (..)+#endif+ ) where++import Prelude hiding (catch)+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+ , withSocketsDo)+import Network.Socket+ ( accept, SockAddr+ )+import qualified Network.Socket.ByteString as Sock+import Control.Exception (bracket, finally, Exception, SomeException, catch)+import Control.Concurrent (forkIO)+import Data.Maybe (fromMaybe)++import Data.Typeable (Typeable)++import Data.Enumerator (($$), (>>==))+import qualified Data.Enumerator as E+import qualified Data.Enumerator.List as EL+import qualified Data.Enumerator.Binary as EB+import Blaze.ByteString.Builder.Enumerator (builderToByteString)+import Blaze.ByteString.Builder.HTTP+ (chunkedTransferEncoding, chunkedTransferTerminator)+import Blaze.ByteString.Builder+ (copyByteString, Builder, toLazyByteString, toByteStringIO)+import Blaze.ByteString.Builder.Char8 (fromChar, fromShow)+import Data.Monoid (mappend, mconcat)+import Network.Socket.SendFile (sendFile)+import Network.Socket.Enumerator (iterSocket)++import Control.Monad.IO.Class (liftIO)+import System.Timeout (timeout)+import Data.Word (Word8)+import Data.List (foldl')++run :: Port -> Application -> IO ()+run port = withSocketsDo . -- FIXME should this be called by client user instead?+ bracket+ (listenOn $ PortNumber $ fromIntegral port)+ sClose .+ serveConnections port+type Port = Int++serveConnections :: Port -> Application -> Socket -> IO ()+serveConnections port app socket = do+ (conn, sa) <- accept socket+ _ <- forkIO $ serveConnection port app conn sa+ serveConnections port app socket++serveConnection :: Port -> Application -> Socket -> SockAddr -> IO ()+serveConnection port app conn remoteHost' = do+ catch+ (finally+ (E.run_ $ fromClient $$ serveConnection')+ (sClose conn))+ ignoreAll+ where+ ignoreAll :: SomeException -> IO ()+ ignoreAll _ = return ()+ fromClient = enumSocket bytesPerRead conn+ serveConnection' = do+ (enumeratee, env) <- parseRequest port remoteHost'+ res <- E.joinI $ enumeratee $$ app env+ keepAlive <- liftIO $ sendResponse 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 remoteHost' = do+ headers' <- takeHeaders+ parseRequest' port headers' remoteHost'++-- FIXME come up with good values here+maxHeaders, maxHeaderLength, bytesPerRead, readTimeout :: Int+maxHeaders = 30+maxHeaderLength = 1024+bytesPerRead = 4096+readTimeout = 3000000++data InvalidRequest =+ NotEnoughLines [String]+ | BadFirstLine String+ | NonHttp+ | TooManyHeaders+ | IncompleteHeaders+ | OverLargeHeader+ | SocketTimeout+ deriving (Show, Typeable, Eq)+instance Exception InvalidRequest++-- | Parse a set of header lines and body into a 'Request'.+parseRequest' :: Port+ -> [ByteString]+ -> SockAddr+ -> E.Iteratee S.ByteString IO (E.Enumeratee S.ByteString S.ByteString IO a, Request)+parseRequest' _ [] _ = E.throwError $ NotEnoughLines []+parseRequest' port (firstLine:otherLines) remoteHost' = do+ (method, rpath', gets, httpversion) <- parseFirst firstLine+ let rpath =+ if S.null rpath'+ then "/"+ else rpath'+ let heads = map parseHeaderNoAttr otherLines+ let host = fromMaybe "" $ lookup "host" heads+ let len =+ case lookup "content-length" heads of+ Nothing -> 0+ Just bs ->+ case reads $ B.unpack bs of -- FIXME could probably be optimized+ (x, _):_ -> x+ [] -> 0+ 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+ { requestMethod = method+ , httpVersion = httpversion+ , pathInfo = rpath+ , queryString = gets+ , serverName = serverName'+ , serverPort = port+ , requestHeaders = heads+ , isSecure = False+ , errorHandler = System.IO.hPutStr System.IO.stderr+ , remoteHost = remoteHost'+ })+++takeUntil :: Word8 -> ByteString -> ByteString+takeUntil c bs =+ case S.elemIndex c bs of+ Just !idx -> SU.unsafeTake idx bs+ Nothing -> bs+{-# INLINE takeUntil #-}++parseFirst :: ByteString+ -> E.Iteratee S.ByteString IO (ByteString, ByteString, ByteString, HttpVersion)+parseFirst s = do+ let pieces = S.split 32 s -- ' '+ (method, query, http') <-+ case pieces of+ [x, y, z] -> return (x, y, z)+ _ -> E.throwError $ BadFirstLine $ B.unpack s+ let (hfirst, hsecond) = B.splitAt 5 http'+ if (hfirst == "HTTP/")+ then+ let (rpath, qstring) = B.break (== '?') query+ in return (method, rpath, qstring, hsecond)+ else E.throwError NonHttp+{-# INLINE parseFirst #-} -- FIXME is this inline necessary? the function is only called from one place and not exported++httpBuilder, spaceBuilder, newlineBuilder, transferEncodingBuilder+ , colonSpaceBuilder :: Builder+httpBuilder = copyByteString "HTTP/"+spaceBuilder = fromChar ' '+newlineBuilder = copyByteString "\r\n"+transferEncodingBuilder = copyByteString "Transfer-Encoding: chunked\r\n\r\n"+colonSpaceBuilder = copyByteString ": "++headers :: HttpVersion -> Status -> ResponseHeaders -> Bool -> Builder+headers !httpversion !status !responseHeaders !isChunked' = {-# SCC "headers" #-}+ let !start = httpBuilder+ `mappend` copyByteString httpversion+ `mappend` spaceBuilder+ `mappend` fromShow (statusCode status)+ `mappend` spaceBuilder+ `mappend` copyByteString (statusMessage status)+ `mappend` newlineBuilder+ !start' = foldl' responseHeaderToBuilder start responseHeaders+ !end = if isChunked'+ then transferEncodingBuilder+ else newlineBuilder+ in start' `mappend` end++responseHeaderToBuilder :: Builder -> (CIByteString, ByteString) -> Builder+responseHeaderToBuilder b (x, y) = b+ `mappend` (copyByteString $ ciOriginal x)+ `mappend` colonSpaceBuilder+ `mappend` copyByteString y+ `mappend` newlineBuilder++isChunked :: HttpVersion -> Bool+isChunked = (==) http11++hasBody :: Status -> Request -> Bool+hasBody s req = s /= (Status 204 "") && requestMethod req /= "HEAD"++sendResponse :: Request -> HttpVersion -> Socket -> Response -> IO Bool+sendResponse req hv socket (ResponseFile s hs fp) = do+ Sock.sendMany socket $ L.toChunks $ toLazyByteString $ headers hv s hs False+ if hasBody s req+ then do+ sendFile socket fp+ return $ lookup "content-length" hs /= Nothing+ else return True+sendResponse req hv socket (ResponseBuilder s hs b)+ | hasBody s req = do+ toByteStringIO (Sock.sendAll socket) b'+ return isKeepAlive+ | otherwise = do+ Sock.sendMany socket+ $ L.toChunks+ $ toLazyByteString+ $ headers hv s hs False+ return True+ where+ headers' = headers hv s hs isChunked'+ b' =+ if isChunked'+ then headers'+ `mappend` chunkedTransferEncoding b+ `mappend` chunkedTransferTerminator+ else headers hv s hs False `mappend` b+ hasLength = lookup "content-length" hs /= Nothing+ isChunked' = isChunked hv && not hasLength+ isKeepAlive = isChunked' || hasLength+sendResponse req hv 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 hv s hs False+ return True+ go s hs =+ chunk'+ $ E.enumList 1 [headers hv s hs isChunked']+ $$ E.joinI $ builderToByteString -- FIXME unsafeBuilderToByteString+ $$ (iterSocket socket >> return isKeepAlive)+ where+ hasLength = lookup "content-length" hs /= Nothing+ isChunked' = isChunked hv && not hasLength+ isKeepAlive = 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++parseHeaderNoAttr :: ByteString -> (CIByteString, ByteString)+parseHeaderNoAttr s =+ let (k, rest) = S.breakByte 58 s -- ':'+ restLen = S.length rest+ -- FIXME check for colon without following space?+ rest' = if restLen > 1 && SU.unsafeTake 2 rest == ": "+ then SU.unsafeDrop 2 rest+ else rest+ in (mkCIByteString k, rest')++-- FIXME when we switch to Jeremy's timeout code, we can probably start using+-- network-enumerator's enumSocket+enumSocket :: Int -> Socket -> E.Enumerator ByteString IO a+enumSocket len socket (E.Continue k) = do+#if NO_TIMEOUT_PROTECTION+ bs <- liftIO $ Sock.recv socket len+ go bs+#else+ mbs <- liftIO $ timeout readTimeout $ Sock.recv socket len+ case mbs of+ Nothing -> E.throwError SocketTimeout+ Just bs -> go bs+#endif+ where+ go bs+ | S.length bs == 0 = E.continue k+ | otherwise = k (E.Chunks [bs]) >>== enumSocket len socket+enumSocket _ _ step = E.returnI step++------ The functions below are not warp-specific and could be split out into a+--separate package.++takeHeaders :: E.Iteratee ByteString IO [ByteString]+takeHeaders = takeUntilBlank 0 id++takeUntilBlank :: Int+ -> ([ByteString] -> [ByteString])+ -> E.Iteratee S.ByteString IO [ByteString]+takeUntilBlank count _+ | count > maxHeaders = E.throwError TooManyHeaders+takeUntilBlank count front = do+ l <- takeLineMax 0 id+ if B.null l+ then return $ front []+ else takeUntilBlank (count + 1) $ front . (:) l++takeLineMax :: Int+ -> ([ByteString] -> [ByteString])+ -> E.Iteratee ByteString IO ByteString+takeLineMax len front = do+ mbs <- EL.head+ case mbs of+ Nothing -> E.throwError IncompleteHeaders+ Just bs -> do+ let (x, y) = S.breakByte 10 bs+ x' = if S.length x > 0 && S.last x == 13+ then S.init x+ else x+ let len' = len + B.length x+ case () of+ ()+ | len' > maxHeaderLength -> E.throwError OverLargeHeader+ | B.null y -> takeLineMax len' $ front . (:) x+ | otherwise -> do+ E.yield () $ E.Chunks [B.drop 1 y]+ return $ B.concat $ front [x']
+ Setup.lhs view
@@ -0,0 +1,7 @@+#!/usr/bin/env runhaskell++> module Main where+> import Distribution.Simple++> main :: IO ()+> main = defaultMain
+ warp.cabal view
@@ -0,0 +1,41 @@+Name: warp+Version: 0.3.0+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+Category: Web, Yesod+Build-Type: Simple+Cabal-Version: >=1.6+Stability: Stable++flag timeout-protection+ Description: Use timeouts (very performance-costly) to protect against DOS attacks.+ Default: True+flag network-bytestring++Library+ Build-Depends: base >= 3 && < 5+ , bytestring >= 0.9 && < 0.10+ , wai >= 0.3.0 && < 0.4+ , 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+ , sendfile >= 0.7.2 && < 0.8+ , network-enumerator >= 0.1.1 && < 0.2+ if flag(network-bytestring)+ build-depends: network >= 2.2.1 && < 2.2.3+ , network-bytestring >= 0.1.3 && < 0.1.4+ else+ build-depends: network >= 2.3 && < 2.4+ Exposed-modules: Network.Wai.Handler.Warp+ ghc-options: -Wall+ if !flag(timeout-protection)+ Cpp-options: -DNO_TIMEOUT_PROTECTION++source-repository head+ type: git+ location: git://github.com/snoyberg/warp.git