warp 1.3.10.2 → 2.0.0
raw patch · 31 files changed
+2064/−592 lines, 31 filesdep +arraydep +criteriondep +doctestdep ~basedep ~blaze-builderdep ~bytestring
Dependencies added: array, criterion, doctest, http-date, old-locale, time
Dependency ranges changed: base, blaze-builder, bytestring, http-types, network, wai
Files
- Network/Wai/Handler/Warp.hs +26/−33
- Network/Wai/Handler/Warp/Buffer.hs +24/−0
- Network/Wai/Handler/Warp/Conduit.hs +3/−3
- Network/Wai/Handler/Warp/Date.hs +59/−0
- Network/Wai/Handler/Warp/FdCache.hs +65/−36
- Network/Wai/Handler/Warp/Header.hs +77/−0
- Network/Wai/Handler/Warp/IORef.hs +22/−0
- Network/Wai/Handler/Warp/Recv.hs +58/−0
- Network/Wai/Handler/Warp/Request.hs +116/−130
- Network/Wai/Handler/Warp/RequestHeader.hs +151/−0
- Network/Wai/Handler/Warp/Response.hs +266/−147
- Network/Wai/Handler/Warp/ResponseHeader.hs +1/−1
- Network/Wai/Handler/Warp/Run.hs +90/−117
- Network/Wai/Handler/Warp/SendFile.hs +29/−0
- Network/Wai/Handler/Warp/Settings.hs +4/−18
- Network/Wai/Handler/Warp/Thread.hs +28/−0
- Network/Wai/Handler/Warp/Timeout.hs +42/−40
- Network/Wai/Handler/Warp/Types.hs +36/−56
- bench/Parser.hs +215/−0
- test/ConduitSpec.hs +32/−0
- test/ExceptionSpec.hs +72/−0
- test/FdCacheSpec.hs +20/−0
- test/MultiMapSpec.hs +30/−0
- test/ReadIntSpec.hs +26/−0
- test/RequestSpec.hs +31/−0
- test/ResponseHeaderSpec.hs +28/−0
- test/ResponseSpec.hs +124/−0
- test/RunSpec.hs +295/−0
- test/ThreadSpec.hs +26/−0
- test/doctests.hs +11/−0
- warp.cabal +57/−11
Network/Wai/Handler/Warp.hs view
@@ -20,9 +20,12 @@ run , runSettings , runSettingsSocket+ , runSettingsConnection+ , runSettingsConnectionMaker -- * Settings , Settings , defaultSettings+ -- ** Accessors , settingsPort , settingsHost , settingsOnException@@ -32,51 +35,41 @@ , settingsIntercept , settingsManager , settingsFdCacheDuration- , settingsResourceTPerRequest , settingsBeforeMainLoop- , settingsServerName- -- ** Data types+ -- * Data types , HostPreference (..)- -- * Connection- , Connection (..)- , runSettingsConnection- , runSettingsConnectionMaker- -- * Datatypes , Port , InvalidRequest (..)+ , ConnSendFileOverride (..)+ -- * Connection+ , Connection (..)+ , socketConnection -- * Internal+ -- ** Version+ , warpVersion+ -- ** Data types+ , InternalInfo (..)+ , HeaderValue+ , IndexedHeader+ , requestMaxIndex -- ** Time out manager- , Manager- , Handle- , TimeoutAction- , initialize- , withManager- , register- , registerKillThread- , tickle- , cancel- , resume- , pause- -- ** Cleaner- , Cleaner- , dummyCleaner+ , module Network.Wai.Handler.Warp.Timeout+ -- ** File descriptor cache+ , module Network.Wai.Handler.Warp.FdCache+ -- ** Date+ , module Network.Wai.Handler.Warp.Date -- ** Request and response- , parseRequest+ , recvRequest , sendResponse- , socketConnection-#if TEST- , takeHeaders- , parseFirst- , readInt-#endif- -- ** Version- , warpVersion ) where +import Data.Conduit.Network (HostPreference(..))+import Network.Wai.Handler.Warp.Date+import Network.Wai.Handler.Warp.FdCache+import Network.Wai.Handler.Warp.Header import Network.Wai.Handler.Warp.Request import Network.Wai.Handler.Warp.Response import Network.Wai.Handler.Warp.Run import Network.Wai.Handler.Warp.Settings-import Network.Wai.Handler.Warp.Types import Network.Wai.Handler.Warp.Timeout-import Data.Conduit.Network (HostPreference(..))+import Network.Wai.Handler.Warp.Types
+ Network/Wai/Handler/Warp/Buffer.hs view
@@ -0,0 +1,24 @@+module Network.Wai.Handler.Warp.Buffer where++import qualified Blaze.ByteString.Builder.Internal.Buffer as B (Buffer (..))+import Data.Word (Word8)+import Foreign.ForeignPtr (newForeignPtr_)+import Foreign.Marshal.Alloc (mallocBytes, free)+import Foreign.Ptr (Ptr, plusPtr)++type Buffer = Ptr Word8++-- FIXME come up with good values here+bufferSize :: Int+bufferSize = 4096++allocateBuffer :: Int -> IO Buffer+allocateBuffer = mallocBytes++freeBuffer :: Buffer -> IO ()+freeBuffer = free++toBlazeBuffer :: Buffer -> Int -> IO B.Buffer+toBlazeBuffer ptr size = do+ fptr <- newForeignPtr_ ptr+ return $ B.Buffer fptr ptr ptr (ptr `plusPtr` size)
Network/Wai/Handler/Warp/Conduit.hs view
@@ -20,13 +20,13 @@ ---------------------------------------------------------------- -- | Contains a @Source@ and a byte count that is still to be read in.-newtype IsolatedBSSource = IsolatedBSSource (I.IORef (Int, ResumableSource (ResourceT IO) ByteString))+newtype IsolatedBSSource = IsolatedBSSource (I.IORef (Int, ResumableSource IO ByteString)) -- | Given an @IsolatedBSSource@ provide a @Source@ that only allows up to the -- specified number of bytes to be passed downstream. All leftovers should be -- retained within the @Source@. If there are not enough bytes available, -- throws a @ConnectionClosedByPeer@ exception.-ibsIsolate :: IsolatedBSSource -> Source (ResourceT IO) ByteString+ibsIsolate :: IsolatedBSSource -> Source IO ByteString ibsIsolate ibs@(IsolatedBSSource ref) = do (count, src) <- liftIO $ I.readIORef ref unless (count == 0) $ do@@ -70,7 +70,7 @@ -- | Extract the underlying @Source@ from an @IsolatedBSSource@, which will not -- perform any more isolation.-ibsDone :: IsolatedBSSource -> IO (ResumableSource (ResourceT IO) ByteString)+ibsDone :: IsolatedBSSource -> IO (ResumableSource IO ByteString) ibsDone (IsolatedBSSource ref) = snd <$> I.readIORef ref ----------------------------------------------------------------
+ Network/Wai/Handler/Warp/Date.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE CPP #-}++module Network.Wai.Handler.Warp.Date (+ withDateCache+ , getDate+ , DateCache+ , GMTDate+ ) where++import Control.Applicative+import Control.Concurrent+import Control.Exception+import Control.Monad+import Data.ByteString.Char8+import Data.IORef++#if WINDOWS+import Data.Time+import System.Locale+#else+import Network.HTTP.Date+import System.Posix (epochTime)+#endif++-- | The type of the Date header value.+type GMTDate = ByteString++-- | The type of the cache of the Date header value.+data DateCache = DateCache (IORef GMTDate)++-- | Creating 'DateCache' and executing the action.+withDateCache :: (DateCache -> IO a) -> IO a+withDateCache action = bracket initialize+ (\(t,_) -> killThread t)+ (\(_,dc) -> action dc)++initialize :: IO (ThreadId, DateCache)+initialize = do+ dc <- DateCache <$> (getCurrentGMTDate >>= newIORef)+ t <- forkIO $ forever $ do+ threadDelay 1000000+ update dc+ return (t, dc)++-- | Getting 'GMTDate' based on 'DateCache'.+getDate :: DateCache -> IO GMTDate+getDate (DateCache ref) = readIORef ref++update :: DateCache -> IO ()+update (DateCache ref) = getCurrentGMTDate >>= writeIORef ref++getCurrentGMTDate :: IO GMTDate+#ifdef WINDOWS+getCurrentGMTDate = formatDate <$> getCurrentTime+ where+ formatDate = pack . formatTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S GMT"+#else+getCurrentGMTDate = formatHTTPDate . epochTimeToHTTPDate <$> epochTime+#endif
Network/Wai/Handler/Warp/FdCache.hs view
@@ -1,18 +1,35 @@-{-# LANGUAGE BangPatterns, FlexibleInstances #-}+{-# LANGUAGE BangPatterns, FlexibleInstances, CPP #-} +-- | File descriptor cache to avoid locks in kernel.++#ifndef SENDFILEFD module Network.Wai.Handler.Warp.FdCache (- initialize+ withFdCache+ , MutableFdCache+ , Refresh+ ) where++type Refresh = IO ()+data MutableFdCache = MutableFdCache++withFdCache :: Int -> (Maybe MutableFdCache -> IO a) -> IO a+withFdCache _ f = f Nothing+#else+module Network.Wai.Handler.Warp.FdCache (+ withFdCache , getFd , MutableFdCache+ , Refresh ) where import Control.Applicative ((<$>), (<*>))-import Control.Concurrent (forkIO, threadDelay, ThreadId, killThread)-import Control.Exception (mask_)+import Control.Concurrent (threadDelay)+import Control.Exception (bracket, mask_) import Data.Hashable (hash)-import Data.IORef (IORef, newIORef, readIORef, writeIORef, atomicModifyIORef, mkWeakIORef)+import Network.Wai.Handler.Warp.IORef import Network.Wai.Handler.Warp.MultiMap-import System.Posix.IO (openFd, defaultFileFlags, OpenMode(ReadOnly), closeFd)+import Network.Wai.Handler.Warp.Thread+import System.Posix.IO (openFd, OpenFileFlags(..), defaultFileFlags, OpenMode(ReadOnly), closeFd) import System.Posix.Types (Fd) ----------------------------------------------------------------@@ -21,6 +38,7 @@ newtype MutableStatus = MutableStatus (IORef Status) +-- | An action to activate a Fd cache entry. type Refresh = IO () status :: MutableStatus -> IO Status@@ -41,29 +59,29 @@ newFdEntry :: FilePath -> IO FdEntry newFdEntry path = FdEntry path- <$> openFd path ReadOnly Nothing defaultFileFlags+ <$> openFd path ReadOnly Nothing defaultFileFlags{nonBlock=True} <*> newActiveStatus ---------------------------------------------------------------- type Hash = Int type FdCache = MMap Hash FdEntry-newtype MutableFdCache = MutableFdCache { unMutableFdCache :: IORef FdCache } -newMutableFdCache :: IO MutableFdCache-newMutableFdCache = MutableFdCache <$> newIORef empty+-- | Mutable Fd cacher.+newtype MutableFdCache = MutableFdCache (IORef FdCache) fdCache :: MutableFdCache -> IO FdCache fdCache (MutableFdCache ref) = readIORef ref -swapWithNew :: MutableFdCache -> IO FdCache-swapWithNew (MutableFdCache ref) = atomicModifyIORef ref (\t -> (empty, t))+swapWithNew :: IORef FdCache -> IO FdCache+swapWithNew ref = atomicModifyIORef' ref $ \t -> (empty, t) update :: MutableFdCache -> (FdCache -> FdCache) -> IO ()-update (MutableFdCache ref) f = do- !_ <- atomicModifyIORef ref $ \t -> let !new = f t in (new, ())- return ()+update (MutableFdCache ref) = update' ref +update' :: IORef FdCache -> (FdCache -> FdCache) -> IO ()+update' ref f = atomicModifyIORef' ref $ \t -> (f t, ())+ look :: MutableFdCache -> FilePath -> Hash -> IO (Maybe FdEntry) look mfc path key = searchWith key check <$> fdCache mfc where@@ -76,30 +94,29 @@ ---------------------------------------------------------------- -initialize :: Int -> IO MutableFdCache+-- | Creating 'MutableFdCache' and executing the action in the second+-- argument. The first argument is a cache duration in second.+withFdCache :: Int -> (Maybe MutableFdCache -> IO a) -> IO a+withFdCache duration action = bracket (initialize duration)+ terminate+ action++----------------------------------------------------------------++-- The first argument is a cache duration in second.+initialize :: Int -> IO (Maybe MutableFdCache)+initialize 0 = return Nothing initialize duration = do- mfc <- newMutableFdCache- tid <- forkIO $ loop mfc- -- Registering finalizer to this IORef.- -- When Warp is finished in GHCi, this IORef is GCed.- -- At that time, we should close all opened file descriptors.- _ <- mkWeakIORef (unMutableFdCache mfc) $ terminate mfc tid- return mfc- where- loop mfc = do- mask_ $ do- old <- swapWithNew mfc- new <- pruneWith old prune- update mfc (merge new)+ ref' <- forkIOwithBreakableForever empty $ \ref -> do threadDelay duration- loop mfc+ clean ref+ return (Just (MutableFdCache ref')) -terminate :: MutableFdCache -> ThreadId -> IO ()-terminate (MutableFdCache icache) tid = do- killThread tid- readIORef icache >>= mapM_ go . toList- where- go (_, FdEntry _ fd _) = closeFd fd+clean :: IORef FdCache -> IO ()+clean ref = do+ old <- swapWithNew ref+ new <- pruneWith old prune+ update' ref (merge new) prune :: t -> Some FdEntry -> IO [(t, Some FdEntry)] prune k v@(One (FdEntry _ fd mst)) = status mst >>= prune'@@ -119,6 +136,17 @@ ---------------------------------------------------------------- +terminate :: Maybe MutableFdCache -> IO ()+terminate Nothing = return ()+terminate (Just (MutableFdCache ref)) = mask_ $ do+ !t <- breakForever ref+ mapM_ closeIt $ toList t+ where+ closeIt (_, FdEntry _ fd _) = closeFd fd++----------------------------------------------------------------++-- | Getting 'Fd' and 'Refresh' from the mutable Fd cacher. getFd :: MutableFdCache -> FilePath -> IO (Fd, Refresh) getFd mfc path = look mfc path key >>= getFd' where@@ -130,3 +158,4 @@ getFd' (Just (FdEntry _ fd mst)) = do refresh mst return (fd, refresh mst)+#endif
+ Network/Wai/Handler/Warp/Header.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.Wai.Handler.Warp.Header where++import Data.Array+import Data.Array.ST+import Network.HTTP.Types+import Network.Wai.Handler.Warp.Types++----------------------------------------------------------------++-- | Array for a set of HTTP headers.+type IndexedHeader = Array Int (Maybe HeaderValue)++----------------------------------------------------------------++indexRequestHeader :: RequestHeaders -> IndexedHeader+indexRequestHeader hdr = traverseHeader hdr requestMaxIndex requestKeyIndex++idxContentLength,idxTransferEncoding,idxExpect :: Int+idxConnection,idxRange,idxHost :: Int+idxContentLength = 0+idxTransferEncoding = 1+idxExpect = 2+idxConnection = 3+idxRange = 4+idxHost = 5++-- | The size for 'IndexedHeader' for HTTP Request.+-- From 0 to this corresponds to \"Content-Length\", \"Transfer-Encoding\",+-- \"Expect\", \"Connection\", \"Range\", and \"Host\".+requestMaxIndex :: Int+requestMaxIndex = 5++requestKeyIndex :: HeaderName -> Int+requestKeyIndex "content-length" = idxContentLength+requestKeyIndex "transfer-encoding" = idxTransferEncoding+requestKeyIndex "expect" = idxExpect+requestKeyIndex "connection" = idxConnection+requestKeyIndex "range" = idxRange+requestKeyIndex "host" = idxHost+requestKeyIndex _ = -1++defaultIndexRequestHeader :: IndexedHeader+defaultIndexRequestHeader = array (0,requestMaxIndex) [(i,Nothing)|i<-[0..requestMaxIndex]]++----------------------------------------------------------------++indexResponseHeader :: ResponseHeaders -> IndexedHeader+indexResponseHeader hdr = traverseHeader hdr responseMaxIndex responseKeyIndex++idxServer :: Int+--idxContentLength = 0+idxServer = 1++-- | The size for 'IndexedHeader' for HTTP Response.+responseMaxIndex :: Int+responseMaxIndex = 1++responseKeyIndex :: HeaderName -> Int+responseKeyIndex "content-length" = idxContentLength+responseKeyIndex "server" = idxServer+responseKeyIndex _ = -1++----------------------------------------------------------------++traverseHeader :: [Header] -> Int -> (HeaderName -> Int) -> IndexedHeader+traverseHeader hdr maxidx getIndex = runSTArray $ do+ arr <- newArray (0,maxidx) Nothing+ mapM_ (insert arr) hdr+ return arr+ where+ insert arr (key,val)+ | idx == -1 = return ()+ | otherwise = writeArray arr idx (Just val)+ where+ idx = getIndex key
+ Network/Wai/Handler/Warp/IORef.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE CPP #-}++module Network.Wai.Handler.Warp.IORef (+ module Data.IORef+#if !MIN_VERSION_base(4,6,0)+ , atomicModifyIORef'+#endif+ ) where++import Data.IORef++#if !MIN_VERSION_base(4,6,0)+-- | Strict version of 'atomicModifyIORef'. This forces both the value stored+-- in the 'IORef' as well as the value returned.+atomicModifyIORef' :: IORef a -> (a -> (a,b)) -> IO b+atomicModifyIORef' ref f = do+ c <- atomicModifyIORef ref+ (\x -> let (a, b) = f x -- Lazy application of "f"+ in (a, a `seq` b)) -- Lazy application of "seq"+ -- The following forces "a `seq` b", so it also forces "f x".+ c `seq` return c+#endif
+ Network/Wai/Handler/Warp/Recv.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE ForeignFunctionInterface #-}++-- fixme: windows support++module Network.Wai.Handler.Warp.Recv (+ receive+ ) where++import Control.Applicative ((<$>))+import Control.Monad (void)+import qualified Data.ByteString as BS (empty)+import Data.ByteString.Internal (ByteString(..), mallocByteString)+import Data.Word (Word8)+import Foreign.C.Error (eAGAIN, getErrno, throwErrno)+import Foreign.C.Types+import Foreign.ForeignPtr (withForeignPtr)+import Foreign.Ptr (Ptr, castPtr)+import GHC.Conc (threadWaitRead)+import Network.Socket (Socket, fdSocket)+import System.Posix.Types (Fd(..))+import Network.Wai.Handler.Warp.Buffer++----------------------------------------------------------------++receive :: Socket -> Buffer -> Int -> IO ByteString+receive sock buf size = do+ bytes <- fromIntegral <$> receiveloop sock' buf' size'+ if bytes == 0 then+ return BS.empty+ else do+ fptr <- mallocByteString bytes+ void $ withForeignPtr fptr $ \ptr ->+ c_memcpy ptr buf (fromIntegral bytes)+ return $! PS fptr 0 bytes+ where+ sock' = fdSocket sock+ buf' = castPtr buf+ size' = fromIntegral size++receiveloop :: CInt -> Ptr CChar -> CSize -> IO CInt+receiveloop sock buf size = do+ bytes <- c_recv sock buf size 0+ if bytes == -1 then do+ errno <- getErrno+ if errno == eAGAIN then do+ threadWaitRead (Fd sock)+ receiveloop sock buf size+ else+ throwErrno "receiveloop"+ else+ return bytes++-- fixme: the type of the return value+foreign import ccall unsafe "recv"+ c_recv :: CInt -> Ptr CChar -> CSize -> CInt -> IO CInt++foreign import ccall unsafe "string.h memcpy"+ c_memcpy :: Ptr Word8 -> Ptr Word8 -> CSize -> IO (Ptr Word8)
Network/Wai/Handler/Warp/Request.hs view
@@ -2,161 +2,150 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} -module Network.Wai.Handler.Warp.Request where+module Network.Wai.Handler.Warp.Request (+ recvRequest+ , headerLines+ ) where import Control.Applicative+import qualified Control.Concurrent as Conc (yield) import Control.Exception.Lifted (throwIO)-import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.IO.Class (liftIO)+import Data.Array ((!)) import Data.ByteString (ByteString) import qualified Data.ByteString as S-import qualified Data.ByteString.Char8 as B (unpack) import qualified Data.ByteString.Unsafe as SU import qualified Data.CaseInsensitive as CI import Data.Conduit import qualified Data.IORef as I-import Data.Maybe (fromMaybe) import Data.Monoid (mempty)-import Data.Word (Word8) import qualified Network.HTTP.Types as H import Network.Socket (SockAddr) import Network.Wai import Network.Wai.Handler.Warp.Conduit+import Network.Wai.Handler.Warp.Header import Network.Wai.Handler.Warp.ReadInt+import Network.Wai.Handler.Warp.RequestHeader+import qualified Network.Wai.Handler.Warp.Timeout as Timeout import Network.Wai.Handler.Warp.Types+import Network.Wai.Internal import Prelude hiding (lines)-import qualified Network.Wai.Handler.Warp.Timeout as Timeout +----------------------------------------------------------------+ -- FIXME come up with good values here maxTotalHeaderLength :: Int maxTotalHeaderLength = 50 * 1024 -parseRequest :: Connection- -> Port -> SockAddr- -> Source (ResourceT IO) ByteString- -> ResourceT IO (Request, IO (ResumableSource (ResourceT IO) ByteString))-parseRequest conn = parseRequestInternal conn Timeout.dummyHandle+---------------------------------------------------------------- -parseRequestInternal- :: Connection- -> Timeout.Handle- -> Port -> SockAddr- -> Source (ResourceT IO) ByteString- -> ResourceT IO (Request, IO (ResumableSource (ResourceT IO) ByteString))-parseRequestInternal conn timeoutHandle port remoteHost' src1 = do- (src2, headers') <- src1 $$+ takeHeaders- parseRequest' conn timeoutHandle port headers' remoteHost' src2+-- | Receiving a HTTP request from 'Connection' and parsing its header+-- to create 'Request'.+recvRequest :: Connection+ -> InternalInfo+ -> SockAddr -- ^ Peer's address.+ -> Source IO ByteString -- ^ Where HTTP request comes from.+ -> IO (Request+ ,IndexedHeader+ ,IO (ResumableSource IO ByteString)) -- ^+ -- 'Request' passed to 'Application',+ -- 'IndexedHeader' of HTTP request for internal use, and+ -- leftover source (i.e. body and other HTTP reqeusts in HTTP pipelining). +recvRequest conn ii addr src0 = do+ (src, hdrlines) <- src0 $$+ headerLines+ (method, path, query, httpversion, hdr) <- parseHeaderLines hdrlines+ let idxhdr = indexRequestHeader hdr+ expect = idxhdr ! idxExpect+ cl = idxhdr ! idxContentLength+ te = idxhdr ! idxTransferEncoding+ liftIO $ handleExpect conn httpversion expect+ (rbody, bodyLength, getSource) <- bodyAndSource src cl te+ let req = Request {+ requestMethod = method+ , httpVersion = httpversion+ , pathInfo = H.decodePathSegments path+ , rawPathInfo = path+ , rawQueryString = query+ , queryString = H.parseQuery query+ , requestHeaders = hdr+ , isSecure = False+ , remoteHost = addr+ , requestBody = timeoutBody th rbody+ , vault = mempty+ , requestBodyLength = bodyLength+ , requestHeaderHost = idxhdr ! idxHost+ , requestHeaderRange = idxhdr ! idxRange+ }+ return (req, idxhdr, getSource)+ where+ th = threadHandle ii++----------------------------------------------------------------++headerLines :: Sink ByteString IO [ByteString]+headerLines =+ await >>= maybe (throwIO ConnectionClosedByPeer) (push (THStatus 0 id id))++----------------------------------------------------------------+ handleExpect :: Connection -> H.HttpVersion- -> ([H.Header] -> [H.Header])- -> [H.Header]- -> IO [H.Header]-handleExpect _ _ front [] = return $ front []-handleExpect conn hv front (("expect", "100-continue"):rest) = do- connSendAll conn $- if hv == H.http11- then "HTTP/1.1 100 Continue\r\n\r\n"- else "HTTP/1.0 100 Continue\r\n\r\n"- return $ front rest-handleExpect conn hv front (x:xs) = handleExpect conn hv (front . (x:)) xs+ -> Maybe HeaderValue+ -> IO ()+handleExpect conn ver (Just "100-continue") = do+ connSendAll conn continue+ Conc.yield+ where+ continue+ | ver == H.http11 = "HTTP/1.1 100 Continue\r\n\r\n"+ | otherwise = "HTTP/1.0 100 Continue\r\n\r\n"+handleExpect _ _ _ = return () --- | Parse a set of header lines and body into a 'Request'.-parseRequest' :: Connection- -> Timeout.Handle- -> Port- -> [ByteString]- -> SockAddr- -> ResumableSource (ResourceT IO) ByteString -- FIXME was buffered- -> ResourceT IO (Request, IO (ResumableSource (ResourceT IO) ByteString))-parseRequest' _ _ _ [] _ _ = throwIO $ NotEnoughLines []-parseRequest' conn timeoutHandle port (firstLine:otherLines) remoteHost' src = do- (method, rpath', gets, httpversion) <- parseFirst firstLine- let (host',rpath)- | S.null rpath' = ("", "/")- | "http://" `S.isPrefixOf` rpath' = S.breakByte 47 $ S.drop 7 rpath'- | otherwise = ("", rpath')- heads <- liftIO- $ handleExpect conn httpversion id- (map parseHeaderNoAttr otherLines)- let host = fromMaybe host' $ lookup hHost heads- let len0 =- case lookup H.hContentLength heads of- Nothing -> 0- Just bs -> readInt bs- let serverName' = takeUntil 58 host -- ':'- let chunked = maybe False ((== "chunked") . CI.foldCase)- $ lookup hTransferEncoding heads- (rbody, getSource) <- liftIO $- if chunked- then do- ref <- I.newIORef (src, NeedLen)- return (chunkedSource ref, fst <$> I.readIORef ref)- else do- ibs <- IsolatedBSSource <$> I.newIORef (len0, src)- return (ibsIsolate ibs, ibsDone ibs)+---------------------------------------------------------------- - return (Request- { requestMethod = method- , httpVersion = httpversion- , pathInfo = H.decodePathSegments rpath- , rawPathInfo = rpath- , rawQueryString = gets- , queryString = H.parseQuery gets- , serverName = serverName'- , serverPort = port- , requestHeaders = heads- , isSecure = False- , remoteHost = remoteHost'- , requestBody = do- -- Timeout handling was paused after receiving the full request- -- headers. Now we need to resume it to avoid a slowloris- -- attack during request body sending.- liftIO $ Timeout.resume timeoutHandle- -- As soon as we finish receiving the request body, whether- -- because the application is not interested in more bytes, or- -- because there is no more data available, pause the timeout- -- handler again.- addCleanup (const $ liftIO $ Timeout.pause timeoutHandle) rbody- , vault = mempty-#if MIN_VERSION_wai(1, 4, 0)- , requestBodyLength =- if chunked- then ChunkedBody- else KnownLength $ fromIntegral len0-#endif- }, getSource)+bodyAndSource :: ResumableSource IO ByteString+ -> Maybe HeaderValue+ -> Maybe HeaderValue+ -> IO (Source IO ByteString+ ,RequestBodyLength+ ,IO (ResumableSource IO ByteString))+bodyAndSource src cl te+ | chunked = do+ ref <- I.newIORef (src, NeedLen)+ return (chunkedSource ref, ChunkedBody, fst <$> I.readIORef ref)+ | otherwise = do+ ibs <- IsolatedBSSource <$> I.newIORef (len, src)+ return (ibsIsolate ibs, bodyLen, ibsDone ibs)+ where+ len = toLength cl+ bodyLen = KnownLength $ fromIntegral len+ chunked = isChunked te -{-# INLINE takeUntil #-}-takeUntil :: Word8 -> ByteString -> ByteString-takeUntil c bs =- case S.elemIndex c bs of- Just !idx -> SU.unsafeTake idx bs- Nothing -> bs+toLength :: Maybe HeaderValue -> Int+toLength Nothing = 0+toLength (Just bs) = readInt bs -{-# INLINE parseFirst #-} -- FIXME is this inline necessary? the function is only called from one place and not exported-parseFirst :: ByteString- -> ResourceT IO (ByteString, ByteString, ByteString, H.HttpVersion)-parseFirst s =- case filter (not . S.null) $ S.splitWith (\c -> c == 32 || c == 9) s of -- ' '- (method:query:http'') -> do- let http' = S.concat http''- (hfirst, hsecond) = S.splitAt 5 http'- if hfirst == "HTTP/"- then let (rpath, qstring) = S.breakByte 63 query -- '?'- hv =- case hsecond of- "1.1" -> H.http11- _ -> H.http10- in return (method, rpath, qstring, hv)- else throwIO NonHttp- _ -> throwIO $ BadFirstLine $ B.unpack s+isChunked :: Maybe HeaderValue -> Bool+isChunked (Just bs) = CI.foldCase bs == "chunked"+isChunked _ = False -parseHeaderNoAttr :: ByteString -> H.Header-parseHeaderNoAttr s =- let (k, rest) = S.breakByte 58 s -- ':'- rest' = S.dropWhile (\c -> c == 32 || c == 9) $ S.drop 1 rest- in (CI.mk k, rest')+---------------------------------------------------------------- +timeoutBody :: Timeout.Handle -> Source IO ByteString -> Source IO ByteString+timeoutBody timeoutHandle rbody = do+ -- Timeout handling was paused after receiving the full request+ -- headers. Now we need to resume it to avoid a slowloris+ -- attack during request body sending.+ liftIO $ Timeout.resume timeoutHandle+ -- As soon as we finish receiving the request body, whether+ -- because the application is not interested in more bytes, or+ -- because there is no more data available, pause the timeout+ -- handler again.+ addCleanup (const $ liftIO $ Timeout.pause timeoutHandle) rbody++----------------------------------------------------------------+ type BSEndo = ByteString -> ByteString type BSEndoList = [ByteString] -> [ByteString] @@ -165,15 +154,12 @@ BSEndoList -- previously parsed lines BSEndo -- bytestrings to be prepended -{-# INLINE takeHeaders #-}-takeHeaders :: Sink ByteString (ResourceT IO) [ByteString]-takeHeaders =- await >>= maybe (throwIO ConnectionClosedByPeer) (push (THStatus 0 id id))+---------------------------------------------------------------- -close :: Sink ByteString (ResourceT IO) a+close :: Sink ByteString IO a close = throwIO IncompleteHeaders -push :: THStatus -> ByteString -> Sink ByteString (ResourceT IO) [ByteString]+push :: THStatus -> ByteString -> Sink ByteString IO [ByteString] push (THStatus len lines prepend) bs -- Too many bytes | len > maxTotalHeaderLength = throwIO OverLargeHeader@@ -190,7 +176,7 @@ 0 -> True 1 -> S.index bs 0 == 13 _ -> False- in Just (nl, (not b) && (c == 32 || c == 9))+ in Just (nl, not b && (c == 32 || c == 9)) else Just (nl, False)
+ Network/Wai/Handler/Warp/RequestHeader.hs view
@@ -0,0 +1,151 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE BangPatterns #-}++module Network.Wai.Handler.Warp.RequestHeader (parseHeaderLines) where++import Control.Exception (throwIO)+import Control.Monad (when)+import qualified Data.ByteString as S+import qualified Data.ByteString.Char8 as B (unpack)+import Data.ByteString.Internal (ByteString(..), memchr)+import qualified Data.CaseInsensitive as CI+import Data.Word (Word8)+import Foreign.ForeignPtr (withForeignPtr)+import Foreign.Ptr (Ptr, plusPtr, minusPtr, nullPtr)+import Foreign.Storable (peek)+import qualified Network.HTTP.Types as H+import Network.Wai.Handler.Warp.Types++-- $setup+-- >>> :set -XOverloadedStrings++----------------------------------------------------------------++parseHeaderLines :: [ByteString]+ -> IO (H.Method+ ,ByteString -- Path+ ,ByteString -- Query+ ,H.HttpVersion+ ,H.RequestHeaders+ )+parseHeaderLines [] = throwIO $ NotEnoughLines []+parseHeaderLines (firstLine:otherLines) = do+ (method, path', query, httpversion) <- parseRequestLine firstLine+ let path = parsePath path'+ hdr = map parseHeader otherLines+ return (method, path, query, httpversion, hdr)++----------------------------------------------------------------++-- |+--+-- >>> parseRequestLine "GET / HTTP/1.1"+-- ("GET","/","",HTTP/1.1)+-- >>> parseRequestLine "POST /cgi/search.cgi?key=foo HTTP/1.0"+-- ("POST","/cgi/search.cgi","?key=foo",HTTP/1.0)+-- >>> parseRequestLine "GET "+-- *** Exception: BadFirstLine "GET "+-- >>> parseRequestLine "GET /NotHTTP UNKNOWN/1.1"+-- *** Exception: NonHttp+parseRequestLine :: ByteString+ -> IO (H.Method+ ,ByteString -- Path+ ,ByteString -- Query+ ,H.HttpVersion)+parseRequestLine requestLine@(PS fptr off len) = withForeignPtr fptr $ \ptr -> do+ when (len < 14) $ throwIO baderr+ let methodptr = ptr `plusPtr` off+ limptr = methodptr `plusPtr` len+ lim0 = fromIntegral len++ pathptr0 <- memchr methodptr 32 lim0 -- ' '+ when (pathptr0 == nullPtr || (limptr `minusPtr` pathptr0) < 11) $+ throwIO baderr+ let pathptr = pathptr0 `plusPtr` 1+ lim1 = fromIntegral (limptr `minusPtr` pathptr0)++ httpptr0 <- memchr pathptr 32 lim1 -- ' '+ when (httpptr0 == nullPtr || (limptr `minusPtr` httpptr0) < 9) $+ throwIO baderr+ let httpptr = httpptr0 `plusPtr` 1+ lim2 = fromIntegral (httpptr0 `minusPtr` pathptr)++ checkHTTP httpptr+ !hv <- httpVersion httpptr+ queryptr <- memchr pathptr 63 lim2 -- '?'++ let !method = bs ptr methodptr pathptr0+ !path+ | queryptr == nullPtr = bs ptr pathptr httpptr0+ | otherwise = bs ptr pathptr queryptr+ !query+ | queryptr == nullPtr = S.empty+ | otherwise = bs ptr queryptr httpptr0++ return (method,path,query,hv)+ where+ baderr = BadFirstLine $ B.unpack requestLine+ check :: Ptr Word8 -> Int -> Word8 -> IO ()+ check p n w = do+ w0 <- peek $ p `plusPtr` n+ when (w0 /= w) $ throwIO NonHttp+ checkHTTP httpptr = do+ check httpptr 0 72 -- 'H'+ check httpptr 1 84 -- 'T'+ check httpptr 2 84 -- 'T'+ check httpptr 3 80 -- 'P'+ check httpptr 4 47 -- '/'+ check httpptr 6 46 -- '.'+ httpVersion httpptr = do+ major <- peek $ httpptr `plusPtr` 5+ minor <- peek $ httpptr `plusPtr` 7+ if major == (49 :: Word8) && minor == (49 :: Word8) then+ return H.http11+ else+ return H.http10+ bs ptr p0 p1 = PS fptr o l+ where+ o = p0 `minusPtr` ptr+ l = p1 `minusPtr` p0++----------------------------------------------------------------++-- |+--+-- >>> parsePath ""+-- "/"+-- >>> parsePath "http://example.com:8080/path"+-- "/path"+-- >>> parsePath "http://example.com"+-- "/"+-- >>> parsePath "/path"+-- "/path"++-- FIXME: parsePath "http://example.com" should be "/"?+parsePath :: ByteString -> ByteString+parsePath path+ | "http://" `S.isPrefixOf` path = ensureNonEmpty $ extractPath path+ | otherwise = ensureNonEmpty path+ where+ extractPath = snd . S.breakByte 47 . S.drop 7 -- 47 is '/'.+ ensureNonEmpty "" = "/"+ ensureNonEmpty p = p++----------------------------------------------------------------++-- |+--+-- >>> parseHeader "Content-Length:47"+-- ("Content-Length","47")+-- >>> parseHeader "Accept-Ranges: bytes"+-- ("Accept-Ranges","bytes")+-- >>> parseHeader "Host: example.com:8080"+-- ("Host","example.com:8080")+-- >>> parseHeader "NoSemiColon"+-- ("NoSemiColon","")++parseHeader :: ByteString -> H.Header+parseHeader s =+ let (k, rest) = S.breakByte 58 s -- ':'+ rest' = S.dropWhile (\c -> c == 32 || c == 9) $ S.drop 1 rest+ in (CI.mk k, rest')
Network/Wai/Handler/Warp/Response.hs view
@@ -1,161 +1,249 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-}+{-# LANGUAGE RankNTypes #-} module Network.Wai.Handler.Warp.Response ( sendResponse+ , fileRange -- for testing+ , warpVersion+ , defaultServerValue ) where import Blaze.ByteString.Builder (fromByteString, Builder, toByteStringIO, flush) import Blaze.ByteString.Builder.HTTP (chunkedTransferEncoding, chunkedTransferTerminator) import Control.Applicative import Control.Exception-import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.IO.Class (liftIO)+import Data.Array ((!)) import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as B (pack) import qualified Data.CaseInsensitive as CI import Data.Conduit-import Data.Conduit.Blaze (builderToByteString)-import qualified Data.Conduit.List as CL+import Data.Conduit.Blaze (unsafeBuilderToByteString)+import Data.Function (on)+import Data.List (deleteBy) import Data.Maybe (isJust, listToMaybe) import Data.Monoid (mappend)+import Data.Version (showVersion)+import Network.HTTP.Attoparsec (parseByteRanges) import qualified Network.HTTP.Types as H import Network.Wai-import Network.Wai.Handler.Warp.ReadInt-import Network.Wai.Handler.Warp.Settings-import qualified Network.Wai.Handler.Warp.ResponseHeader as RH+import qualified Network.Wai.Handler.Warp.Date as D+import Network.Wai.Handler.Warp.Header+import Network.Wai.Handler.Warp.ResponseHeader import qualified Network.Wai.Handler.Warp.Timeout as T import Network.Wai.Handler.Warp.Types-import qualified System.PosixCompat.Files as P-import Network.HTTP.Attoparsec (parseByteRanges)+import Network.Wai.Internal import Numeric (showInt)+import qualified Paths_warp+import qualified System.PosixCompat.Files as P -----------------------------------------------------------------+-- $setup+-- >>> :set -XOverloadedStrings+ ---------------------------------------------------------------- -sendResponse :: Settings- -> Cleaner -> Request -> Connection -> Response- -> ResourceT IO Bool+fileRange :: H.Status -> H.ResponseHeaders -> FilePath+ -> Maybe FilePart -> Maybe HeaderValue+ -> IO (Either SomeException+ (H.Status, H.ResponseHeaders, Integer, Integer))+fileRange s0 hs0 path mPart mRange = try $ do+ fileSize <- checkFileSize mPart+ let (beg, end, len, isEntire) = checkPartRange fileSize mPart mRange+ let hs1 = addContentLength len hs0+ hs | isEntire = hs1+ | otherwise = addContentRange beg end fileSize hs1+ s | isEntire = s0+ | otherwise = H.status206+ return (s, hs, beg, len)+ where+ checkFileSize Nothing = fromIntegral . P.fileSize <$> P.getFileStatus path+ checkFileSize (Just part) = return $ filePartFileSize part +checkPartRange :: Integer -> Maybe FilePart -> Maybe HeaderValue+ -> (Integer, Integer, Integer, Bool)+checkPartRange fileSize mPart mRange = checkPart mPart mRange+ where+ checkPart Nothing Nothing = (0, fileSize - 1, fileSize, True)+ checkPart Nothing (Just range) = case parseByteRanges range >>= listToMaybe of+ -- Range is broken+ Nothing -> (0, fileSize - 1, fileSize, True)+ Just hrange -> checkRange hrange+ -- Ignore Range if FilePart is specified.+ -- We assume that an application handled Range and specified+ -- FilePart.+ checkPart (Just part) _ = (beg, end, len, isEntire)+ where+ beg = filePartOffset part+ len = filePartByteCount part+ end = beg + len - 1+ isEntire = beg == 0 && len == fileSize++ checkRange (H.ByteRangeFrom beg) = fromRange beg (fileSize - 1)+ checkRange (H.ByteRangeFromTo beg end) = fromRange beg end+ checkRange (H.ByteRangeSuffix count) = fromRange (fileSize - count) (fileSize - 1)++ fromRange beg end = (beg, end, len, isEntire)+ where+ len = end - beg + 1+ isEntire = beg == 0 && len == fileSize+ ---------------------------------------------------------------- -sendResponse settings cleaner req conn (ResponseFile s0 hs0 path mpart0) =- headerAndLength >>= sendResponse'+-- | Sending a HTTP response to 'Connection' according to 'Response'.+--+-- Applications/middlewares MUST specify a proper 'H.ResponseHeaders'.+-- so that inconsistency does not happen.+-- No header is deleted by this function.+--+-- Especially, Applications/middlewares MUST take care of+-- Content-Length, Content-Range, and Transfer-Encoding+-- because they are inserted, when necessary,+-- regardless they alredy exist.+-- This function does not insert Content-Encoding. It's middleware's+-- responsibility.+--+-- The Server header is added if not exist in HTTP response header.+--+-- There are three basic APIs to create 'Response':+--+-- ['responseFile' :: 'H.Status' -> 'H.ResponseHeaders' -> 'FilePath' -> 'Maybe' 'FilePart' -> 'Response']+-- HTTP response body is sent by sendfile().+-- Applications are categorized into simple and sophisticated.+-- Simple applications should specify 'Nothing' to+-- 'Maybe' 'FilePart'. The size of the specified file is obtained+-- by disk access. Then Range is handled.+-- Sophisticated applications should specify 'Just' to+-- 'Maybe' 'FilePart'. They should treat Range (and If-Range) by+-- thierselves. In both cases,+-- Content-Length and Content-Range (if necessary) are automatically+-- added into the HTTP response header.+-- If Content-Length and Content-Range exist in the HTTP response header,+-- they would cause inconsistency.+-- Status is also changed to 206 if necessary.+--+-- ['responseBuilder' :: 'H.Status' -> 'H.ResponseHeaders' -> 'Builder' -> 'Response']+-- HTTP response body is created from 'Source'.+-- Typically, Transfer-Encoding: chunked is used.+-- If Content-Length is specified, Transfer-Encoding: chunked is not used.+--+-- ['responseSource' :: 'H.Status' -> 'H.ResponseHeaders' -> 'Source' 'IO' ('Flush' 'Builder') -> 'Response']+-- HTTP response body is created from 'Builder'.+-- Typically, Transfer-Encoding: chunked is used.+-- If Content-Length is specified, Transfer-Encoding: chunked is not used.++sendResponse :: Connection+ -> InternalInfo+ -> (forall a. IO a -> IO a) -- ^ Restore masking state.+ -> Request -- ^ HTTP request.+ -> IndexedHeader -- ^ Indexed header of HTTP request.+ -> Response -- ^ HTTP response including status code and response header.+ -> IO Bool -- ^ Returing True if the connection is persistent.+sendResponse conn ii restore req reqidxhdr response = restore $ do+ hs <- addServerAndDate hs0+ if hasBody s req then do+ sendRsp conn ver s hs rsp+ T.tickle th+ return ret+ else do+ sendResponseNoBody conn ver s hs response+ T.tickle th+ return isPersist where- hs = addAccept hs0- th = threadHandle cleaner- headerAndLength = liftIO . try $ do- (hadLength, cl) <-- case readInt <$> checkLength hs of- Just cl -> return (True, cl)- Nothing ->- case mpart0 of- Just part -> return (False, fromIntegral $ filePartByteCount part)- Nothing -> (False, ) . fromIntegral . P.fileSize- <$> P.getFileStatus path- let (s, addRange, beg, end) =- case mpart0 of- Just part -> (s0, id, filePartOffset part, filePartByteCount part)- Nothing ->- case lookup H.hRange (requestHeaders req) >>= parseByteRanges >>= listToMaybe of- Just range | s0 == H.status200 ->- case range of- H.ByteRangeFrom from -> rangeRes cl from (cl - 1)- H.ByteRangeFromTo from to -> rangeRes cl from to- H.ByteRangeSuffix count -> rangeRes cl (cl - count) (cl - 1)- _ -> (s0, id, 0, cl)- hs'- | hadLength = hs- | otherwise = addLength end hs- return (s, addRange hs', beg, end)+ ver = httpVersion req+ s = responseStatus response+ hs0 = responseHeaders response+ rspidxhdr = indexResponseHeader hs0+ th = threadHandle ii+ dc = dateCacher ii+ addServerAndDate = addDate dc . addServer rspidxhdr+ mRange = reqidxhdr ! idxRange+ reqinfo@(isPersist,_) = infoFromRequest req reqidxhdr+ (isKeepAlive, needsChunked) = infoFromResponse rspidxhdr reqinfo+ rsp = case response of+ ResponseFile _ _ path mPart -> RspFile path mPart mRange (T.tickle th)+ ResponseBuilder _ _ b -> RspBuilder b needsChunked+ ResponseSource _ _ fb -> RspSource fb needsChunked th+ ret = case response of+ ResponseFile _ _ _ _ -> isPersist+ ResponseBuilder _ _ _ -> isKeepAlive+ ResponseSource _ _ _ -> isKeepAlive - rangeRes cl from to = (H.status206, (("Content-Range", rangeHeader cl from to):), from, to - from + 1)+---------------------------------------------------------------- - rangeHeader total from to = B.pack- $ 'b' : 'y': 't' : 'e' : 's' : ' '- : showInt from- ( '-'- : showInt to- ( '/'- : showInt total ""))+data Rsp = RspFile FilePath (Maybe FilePart) (Maybe HeaderValue) (IO ())+ | RspBuilder Builder Bool+ | RspSource (forall b. WithSource IO (Flush Builder) b) Bool T.Handle - sendResponse' (Right (s, lengthyHeaders, beg, end))- | hasBody s req = liftIO $ do- lheader <- composeHeader settings version s lengthyHeaders- connSendFile conn path beg end (T.tickle th) [lheader] cleaner- T.tickle th- return isPersist- | otherwise = liftIO $ do- composeHeader settings version s hs >>= connSendAll conn- T.tickle th- return isPersist -- FIXME isKeepAlive?- where- version = httpVersion req- (isPersist,_) = infoFromRequest req+---------------------------------------------------------------- - sendResponse' (Left (_ :: SomeException)) =- sendResponse settings cleaner req conn notFound- where- notFound = responseLBS H.status404 [(H.hContentType, "text/plain")] "File not found"+sendRsp :: Connection+ -> H.HttpVersion+ -> H.Status+ -> H.ResponseHeaders+ -> Rsp+ -> IO ()+sendRsp conn ver s0 hs0 (RspFile path mPart mRange hook) = do+ ex <- fileRange s0 hs path mPart mRange+ case ex of+ Left _ -> sendRsp conn ver s2 hs2 (RspBuilder body True)+ Right (s, hs1, beg, len) -> do+ lheader <- composeHeader ver s hs1+ connSendFile conn path beg len hook [lheader]+ where+ hs = addAcceptRanges hs0+ s2 = H.status404+ hs2 = replaceHeader H.hContentType "text/plain" hs0+ body = fromByteString "File not found" ---------------------------------------------------------------- -sendResponse settings cleaner req conn (ResponseBuilder s hs b)- | hasBody s req = liftIO $ do- header <- composeHeaderBuilder settings version s hs needsChunked- let body- | needsChunked = header `mappend` chunkedTransferEncoding b- `mappend` chunkedTransferTerminator- | otherwise = header `mappend` b- flip toByteStringIO body $ \bs -> do- connSendAll conn bs- T.tickle th- return isKeepAlive- | otherwise = liftIO $ do- composeHeader settings version s hs >>= connSendAll conn- T.tickle th- return isPersist- where- th = threadHandle cleaner- version = httpVersion req- reqinfo@(isPersist,_) = infoFromRequest req- (isKeepAlive, needsChunked) = infoFromResponse hs reqinfo+sendRsp conn ver s hs (RspBuilder b needsChunked) = do+ header <- composeHeaderBuilder ver s hs needsChunked+ let body+ | needsChunked = header `mappend` chunkedTransferEncoding b+ `mappend` chunkedTransferTerminator+ | otherwise = header `mappend` b+ flip toByteStringIO body $ \bs -> connSendAll conn bs ---------------------------------------------------------------- -sendResponse settings cleaner req conn (ResponseSource s hs bodyFlush)- | hasBody s req = do- header <- liftIO $ composeHeaderBuilder settings version s hs needsChunked- let src = CL.sourceList [header] `mappend` cbody- src $$ builderToByteString =$ connSink conn th- return isKeepAlive- | otherwise = liftIO $ do- composeHeader settings version s hs >>= connSendAll conn- T.tickle th- return isPersist+sendRsp conn ver s hs (RspSource withBodyFlush needsChunked th) = withBodyFlush $ \bodyFlush -> do+ header <- composeHeaderBuilder ver s hs needsChunked+ let src = yield header >> cbody bodyFlush+ buffer = connBuffer conn+ src $$ unsafeBuilderToByteString (return buffer) =$ connSink conn th where- th = threadHandle cleaner- body =- mapOutput (\x -> case x of- Flush -> flush- Chunk builder -> builder)- bodyFlush- cbody = if needsChunked then body $= chunk else body- -- FIXME perhaps alloca a buffer per thread and reuse that in all- -- functions below. Should lessen greatly the GC burden (I hope)- chunk :: Conduit Builder (ResourceT IO) Builder+ cbody bodyFlush = if needsChunked then body $= chunk else body+ where+ body = mapOutput (\x -> case x of+ Flush -> flush+ Chunk builder -> builder)+ bodyFlush+ chunk :: Conduit Builder IO Builder chunk = await >>= maybe (yield chunkedTransferTerminator) (\x -> yield (chunkedTransferEncoding x) >> chunk)- version = httpVersion req- reqinfo@(isPersist,_) = infoFromRequest req- (isKeepAlive, needsChunked) = infoFromResponse hs reqinfo ----------------------------------------------------------------++sendResponseNoBody :: Connection+ -> H.HttpVersion+ -> H.Status+ -> H.ResponseHeaders+ -> Response+ -> IO ()+sendResponseNoBody conn ver s hs (ResponseSource _ _ withBodyFlush) =+ withBodyFlush $ \_bodyFlush ->+ composeHeader ver s hs >>= connSendAll conn+sendResponseNoBody conn ver s hs _ =+ composeHeader ver s hs >>= connSendAll conn+ ----------------------------------------------------------------+---------------------------------------------------------------- -- | Use 'connSendAll' to send this data while respecting timeout rules.-connSink :: Connection -> T.Handle -> Sink ByteString (ResourceT IO) ()-connSink Connection { connSendAll = send } th =- sink+connSink :: Connection -> T.Handle -> Sink ByteString IO ()+connSink Connection { connSendAll = send } th = sink where sink = await >>= maybe close push close = liftIO (T.resume th)@@ -171,16 +259,17 @@ ---------------------------------------------------------------- -infoFromRequest :: Request -> (Bool,Bool)-infoFromRequest req = (checkPersist req, checkChunk req)+infoFromRequest :: Request -> IndexedHeader -> (Bool -- isPersist+ ,Bool) -- isChunked+infoFromRequest req reqidxhdr = (checkPersist req reqidxhdr, checkChunk req) -checkPersist :: Request -> Bool-checkPersist req+checkPersist :: Request -> IndexedHeader -> Bool+checkPersist req reqidxhdr | ver == H.http11 = checkPersist11 conn | otherwise = checkPersist10 conn where ver = httpVersion req- conn = lookup H.hConnection $ requestHeaders req+ conn = reqidxhdr ! idxConnection checkPersist11 (Just x) | CI.foldCase x == "close" = False checkPersist11 _ = True@@ -193,15 +282,19 @@ ---------------------------------------------------------------- -infoFromResponse :: H.ResponseHeaders -> (Bool,Bool) -> (Bool,Bool)-infoFromResponse hs (isPersist,isChunked) = (isKeepAlive, needsChunked)+-- Used for ResponseBuilder and ResponseSource.+-- Don't use this for ResponseFile since this logic does not fit+-- for ResponseFile. For instance, isKeepAlive should be True in some cases+-- even if the response header does not have Content-Length.+--+-- Content-Length is specified by a reverse proxy.+-- Note that CGI does not specify Content-Length.+infoFromResponse :: IndexedHeader -> (Bool,Bool) -> (Bool,Bool)+infoFromResponse rspidxhdr (isPersist,isChunked) = (isKeepAlive, needsChunked) where needsChunked = isChunked && not hasLength isKeepAlive = isPersist && (isChunked || hasLength)- hasLength = isJust $ checkLength hs--checkLength :: H.ResponseHeaders -> Maybe ByteString-checkLength = lookup H.hContentLength+ hasLength = isJust $ rspidxhdr ! idxContentLength ---------------------------------------------------------------- @@ -216,36 +309,62 @@ ---------------------------------------------------------------- -addLength :: Integer -> H.ResponseHeaders -> H.ResponseHeaders-addLength cl hdrs = (H.hContentLength, B.pack $ show cl) : hdrs+addAcceptRanges :: H.ResponseHeaders -> H.ResponseHeaders+addAcceptRanges hdrs = (hAcceptRanges, "bytes") : hdrs -addAccept :: H.ResponseHeaders -> H.ResponseHeaders-addAccept = (("Accept-Ranges", "bytes"):)+addTransferEncoding :: H.ResponseHeaders -> H.ResponseHeaders+addTransferEncoding hdrs = (hTransferEncoding, "chunked") : hdrs -addEncodingHeader :: H.ResponseHeaders -> H.ResponseHeaders-addEncodingHeader hdrs = (hTransferEncoding, "chunked") : hdrs+addContentLength :: Integer -> H.ResponseHeaders -> H.ResponseHeaders+addContentLength cl hdrs = (H.hContentLength, len) : hdrs+ where+ len = B.pack $ show cl -addServerHeader :: Settings -> H.ResponseHeaders -> H.ResponseHeaders-addServerHeader settings hdrs = case lookup hServer hdrs of- Nothing -> warpVersionHeader settings : hdrs- Just _ -> hdrs+addContentRange :: Integer -> Integer -> Integer+ -> H.ResponseHeaders -> H.ResponseHeaders+addContentRange beg end total hdrs = (hContentRange, range) : hdrs+ where+ range = B.pack+ -- building with ShowS+ $ 'b' : 'y': 't' : 'e' : 's' : ' '+ : showInt beg+ ( '-'+ : showInt end+ ( '/'+ : showInt total "")) -warpVersionHeader :: Settings -> H.Header-warpVersionHeader settings = (hServer, settingsServerName settings)+addDate :: D.DateCache -> H.ResponseHeaders -> IO H.ResponseHeaders+addDate dc hdrs = do+ gmtdate <- D.getDate dc+ return $ (H.hDate, gmtdate) : hdrs ---------------------------------------------------------------- -composeHeader :: Settings- -> H.HttpVersion- -> H.Status- -> H.ResponseHeaders- -> IO ByteString-composeHeader settings version s hs =- RH.composeHeader version s- $ addServerHeader settings hs+-- | The version of Warp.+warpVersion :: String+warpVersion = showVersion Paths_warp.version -composeHeaderBuilder :: Settings -> H.HttpVersion -> H.Status -> H.ResponseHeaders -> Bool -> IO Builder-composeHeaderBuilder settings ver s hs True =- fromByteString <$> composeHeader settings ver s (addEncodingHeader hs)-composeHeaderBuilder settings ver s hs False =- fromByteString <$> composeHeader settings ver s hs+defaultServerValue :: HeaderValue+defaultServerValue = B.pack $ "Warp/" ++ warpVersion++addServer :: IndexedHeader -> H.ResponseHeaders -> H.ResponseHeaders+addServer rspidxhdr hdrs = case rspidxhdr ! idxServer of+ Nothing -> (hServer, defaultServerValue) : hdrs+ _ -> hdrs++----------------------------------------------------------------++-- |+--+-- >>> replaceHeader "Content-Type" "new" [("content-type","old")]+-- [("Content-Type","new")]+replaceHeader :: H.HeaderName -> HeaderValue -> H.ResponseHeaders -> H.ResponseHeaders+replaceHeader k v hdrs = (k,v) : deleteBy ((==) `on` fst) (k,v) hdrs++----------------------------------------------------------------++composeHeaderBuilder :: H.HttpVersion -> H.Status -> H.ResponseHeaders -> Bool -> IO Builder+composeHeaderBuilder ver s hs True =+ fromByteString <$> composeHeader ver s (addTransferEncoding hs)+composeHeaderBuilder ver s hs False =+ fromByteString <$> composeHeader ver s hs
Network/Wai/Handler/Warp/ResponseHeader.hs view
@@ -29,7 +29,7 @@ {-# INLINE copy #-} copy :: Ptr Word8 -> ByteString -> IO (Ptr Word8)-copy !ptr !(PS fp o l) = withForeignPtr fp $ \p -> do+copy !ptr (PS fp o l) = withForeignPtr fp $ \p -> do memcpy ptr (p `plusPtr` o) (fromIntegral l) return $! ptr `plusPtr` l
Network/Wai/Handler/Warp/Run.hs view
@@ -5,10 +5,10 @@ module Network.Wai.Handler.Warp.Run where import Control.Concurrent (threadDelay, forkIOWithUnmask)+import qualified Control.Concurrent as Conc (yield) import Control.Exception as E import Control.Monad (forever, when, unless, void)-import Control.Monad.IO.Class (MonadIO, liftIO)-import Control.Monad.Trans.Class (lift)+import Control.Monad.IO.Class (liftIO) import Data.ByteString (ByteString) import qualified Data.ByteString as S import Data.Conduit@@ -16,23 +16,22 @@ import qualified Data.Conduit.List as CL import Data.Conduit.Network (bindPort) import Network (sClose, Socket)-import Network.Sendfile+import qualified Network.HTTP.Types as H import Network.Socket (accept, SockAddr) import qualified Network.Socket.ByteString as Sock-import Data.Monoid (mempty)-import qualified Network.HTTP.Types as H import Network.Wai+import qualified Network.Wai.Handler.Warp.Date as D+import qualified Network.Wai.Handler.Warp.FdCache as F+import Network.Wai.Handler.Warp.Buffer+import Network.Wai.Handler.Warp.Header+import Network.Wai.Handler.Warp.Recv import Network.Wai.Handler.Warp.Request import Network.Wai.Handler.Warp.Response+import Network.Wai.Handler.Warp.SendFile import Network.Wai.Handler.Warp.Settings import qualified Network.Wai.Handler.Warp.Timeout as T import Network.Wai.Handler.Warp.Types-import Data.IORef (IORef, newIORef, readIORef, writeIORef) --- Sock.recv first tries to call recvfrom() optimistically.--- If EAGAIN returns, it polls incoming data with epoll/kqueue.--- This code first polls incoming data with epoll/kqueue.- #if WINDOWS import qualified Control.Concurrent.MVar as MV import Network.Socket (withSocketsDo)@@ -42,36 +41,20 @@ import Network.Socket (fdSocket) #endif -#if SENDFILEFD-import Control.Applicative-import qualified Network.Wai.Handler.Warp.FdCache as F-#endif---- FIXME come up with good values here-bytesPerRead :: Int-bytesPerRead = 4096---- | Default action value for 'Connection'-socketConnection :: Socket -> Connection-socketConnection s = Connection- { connSendMany = Sock.sendMany s- , connSendAll = Sock.sendAll s- , connSendFile = sendFile s- , connClose = sClose s- , connRecv = Sock.recv s bytesPerRead- }--sendFile :: Socket -> FilePath -> Integer -> Integer -> IO () -> [ByteString] -> Cleaner -> IO ()-#if SENDFILEFD-sendFile s path off len act hdr cleaner = case fdCacher cleaner of- Nothing -> sendfileWithHeader s path (PartOfFile off len) act hdr- Just fdc -> do- (fd, fresher) <- F.getFd fdc path- sendfileFdWithHeader s fd (PartOfFile off len) (act>>fresher) hdr-#else-sendFile s path off len act hdr _ =- sendfileWithHeader s path (PartOfFile off len) act hdr-#endif+-- | Default action value for 'Connection'.+socketConnection :: Socket -> IO Connection+socketConnection s = do+ buf <- allocateBuffer bufferSize+ blazeBuf <- toBlazeBuffer buf bufferSize+ return Connection {+ connSendMany = Sock.sendMany s+ , connSendAll = Sock.sendAll s+ , connSendFile = defaultSendFile s+ , connClose = sClose s >> freeBuffer buf+ , connRecv = receive s buf bufferSize+ , connBuffer = blazeBuf+ , connSendFileOverride = Override s+ } #if __GLASGOW_HASKELL__ < 702 allowInterrupt :: IO ()@@ -83,7 +66,7 @@ run :: Port -> Application -> IO () run p = runSettings defaultSettings { settingsPort = p } --- | Run a Warp server with the given settings.+-- | Run an 'Applicatoin' with the given 'Settings'. runSettings :: Settings -> Application -> IO () #if WINDOWS runSettings set app = withSocketsDo $ do@@ -114,13 +97,20 @@ -- 'serverPort' record. runSettingsSocket :: Settings -> Socket -> Application -> IO () runSettingsSocket set socket app =- runSettingsConnection set getter app+ runSettingsConnection set getConn app where- getter = do- (conn, sa) <- accept socket- setSocketCloseOnExec conn- return (socketConnection conn, sa)+ getConn = do+ (s, sa) <- accept socket+ setSocketCloseOnExec s+ conn <- socketConnection s+ return (conn, sa) +-- | Allows you to provide a function which will return a 'Connection'. In+-- cases where creating the @Connection@ can be expensive, this allows the+-- expensive computations to be performed in a separate thread instead of the+-- main server loop.+--+-- Since 1.3.5 runSettingsConnection :: Settings -> IO (Connection, SockAddr) -> Application -> IO () runSettingsConnection set getConn app = runSettingsConnectionMaker set getConnMaker app where@@ -128,20 +118,10 @@ (conn, sa) <- getConn return (return conn, sa) --- | Allows you to provide a function which will return a @Connection@. In--- cases where creating the @Connection@ can be expensive, this allows the--- expensive computations to be performed in a separate thread instead of the--- main server loop.------ Since 1.3.5+-- | Allows you to provide a function which will return a function+-- which will return 'Connection'. runSettingsConnectionMaker :: Settings -> IO (IO Connection, SockAddr) -> Application -> IO ()-runSettingsConnectionMaker set getConn app = do-#if SENDFILEFD- let duration = settingsFdCacheDuration set- fc <- case duration of- 0 -> return Nothing- _ -> Just <$> F.initialize (duration * 1000000)-#endif+runSettingsConnectionMaker set getConnMaker app = do settingsBeforeMainLoop set -- Note that there is a thorough discussion of the exception safety of the@@ -160,6 +140,8 @@ -- First mask all exceptions in the main loop. This is necessary to ensure -- that no async exception is throw between the call to getConnLoop and the -- registering of connClose.+ D.withDateCache $ \dc -> do+ F.withFdCache (settingsFdCacheDuration set * 1000000) $ \fc -> do withTimeoutManager $ \tm -> mask_ . forever $ do -- Allow async exceptions before receiving the next connection maker. allowInterrupt@@ -187,39 +169,35 @@ -- We grab the connection before registering timeouts since the -- timeouts will be useless during connection creation, due to the -- fact that async exceptions are still masked.- bracket mkConn connClose $ \conn ->+ bracket mkConn connClose $ \conn' -> -- We need to register a timeout handler for this thread, and -- cancel that handler as soon as we exit. bracket (T.registerKillThread tm) T.cancel $ \th ->-#if SENDFILEFD- let cleaner = Cleaner th fc-#else- let cleaner = Cleaner th-#endif+ let ii = InternalInfo th fc dc+ conn = setSendFile conn' fc -- We now have fully registered a connection close handler -- in the case of all exceptions, so it is safe to one -- again allow async exceptions. in unmask . -- Call the user-supplied on exception code if any -- exceptions are thrown.- handle onE .+ handle (onE Nothing) . -- Call the user-supplied code for connection open and close events bracket_ onOpen onClose $ -- Actually serve this connection.- serveConnection th set cleaner port app conn addr+ serveConnection conn ii addr set app where -- FIXME: only IOEception is caught. What about other exceptions?- getConnLoop = getConn `E.catch` \(e :: IOException) -> do- onE (toException e)+ getConnLoop = getConnMaker `E.catch` \(e :: IOException) -> do+ onE Nothing (toException e) -- "resource exhausted (Too many open files)" may happen by accept(). -- Wait a second hoping that resource will be available. threadDelay 1000000 getConnLoop onE = settingsOnException set- port = settingsPort set onOpen = settingsOnOpen set onClose = settingsOnClose set @@ -231,70 +209,65 @@ f Just tm -> f tm -serveConnection :: T.Handle+serveConnection :: Connection+ -> InternalInfo+ -> SockAddr -> Settings- -> Cleaner- -> Port -> Application -> Connection -> SockAddr-> IO ()-serveConnection timeoutHandle settings cleaner port app conn remoteHost' = do- istatus <- newIORef False- respondOnException istatus settings cleaner conn remoteHost' $- runResourceT (serveConnection' istatus)+ -> Application+ -> IO ()+serveConnection conn ii addr settings app =+ recvSendLoop (connSource conn th) `onException` send500 where- innerRunResourceT- | settingsResourceTPerRequest settings = lift . runResourceT- | otherwise = id- th = threadHandle cleaner+ th = threadHandle ii - serveConnection' :: IORef Bool -> ResourceT IO ()- serveConnection' istatus = serveConnection'' istatus $ connSource conn th istatus+ send500 = void $ mask $ \restore ->+ sendResponse conn ii restore dummyreq defaultIndexRequestHeader internalError - serveConnection'' istatus fromClient = do- (env, getSource) <- parseRequestInternal conn timeoutHandle port remoteHost' fromClient- case settingsIntercept settings env of+ dummyreq = defaultRequest { remoteHost = addr }++ internalError = responseLBS H.internalServerError500 [(H.hContentType, "text/plain")] "Something went wrong"++ recvSendLoop fromClient = do+ (req, idxhdr, getSource) <- recvRequest conn ii addr fromClient+ case settingsIntercept settings req of Nothing -> do -- Let the application run for as long as it wants- liftIO $ T.pause th- keepAlive <- innerRunResourceT $ do- res <- app env+ T.pause th - liftIO $ do- T.resume th- -- FIXME consider forcing evaluation of the res here to- -- send more meaningful error messages to the user.- -- However, it may affect performance.- writeIORef istatus False- sendResponse settings cleaner env conn res+ -- In the event that some scarce resource was acquired during+ -- creating the request, we need to make sure that we don't get+ -- an async exception before calling the ResponseSource.+ keepAlive <- mask $ \restore -> do+ res <- restore $ app req+ T.resume th+ sendResponse conn ii restore req idxhdr res + -- We just send a Response and it takes a time to+ -- receive a Request again. If we immediately call recv,+ -- it is likely to fail and the IO manager works.+ -- It is very costy. So, we yield to another Haskell+ -- thread hoping that the next Request will arraive+ -- when this Haskell thread will be re-scheduled.+ -- This improves performance at least when+ -- the number of cores is small.+ Conc.yield -- flush the rest of the request body- requestBody env $$ CL.sinkNull- ResumableSource fromClient' _ <- liftIO getSource+ requestBody req $$ CL.sinkNull+ ResumableSource fromClient' _ <- getSource - when keepAlive $ serveConnection'' istatus fromClient'+ when keepAlive $ recvSendLoop fromClient' Just intercept -> do- liftIO $ T.pause th- ResumableSource fromClient' _ <- liftIO getSource+ T.pause th+ ResumableSource fromClient' _ <- getSource intercept fromClient' conn -respondOnException :: IORef Bool -> Settings -> Cleaner -> Connection -> SockAddr -> IO () -> IO ()-respondOnException istatus settings cleaner conn remoteHost' io = io `E.catch` \e@(SomeException _) -> do- status <- readIORef istatus- when status $ do- _ <- runResourceT $ sendResponse settings cleaner blankRequest conn internalError- return ()- throwIO e- where- blankRequest = Request H.methodGet H.http10 mempty mempty mempty 0 [] False remoteHost' [] [] (return mempty) mempty (KnownLength 0)- internalError = responseLBS H.internalServerError500 [(H.hContentType, "text/plain")] "Something went wrong"--connSource :: Connection -> T.Handle -> IORef Bool -> Source (ResourceT IO) ByteString-connSource Connection { connRecv = recv } th istatus = src+connSource :: Connection -> T.Handle -> Source IO ByteString+connSource Connection { connRecv = recv } th = src where src = do bs <- liftIO recv unless (S.null bs) $ do- liftIO $ do- writeIORef istatus True- when (S.length bs >= 2048) $ T.tickle th+ when (S.length bs >= 2048) $ liftIO $ T.tickle th yield bs src
+ Network/Wai/Handler/Warp/SendFile.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE CPP #-}++module Network.Wai.Handler.Warp.SendFile where++import Data.ByteString (ByteString)+import Network.Sendfile+import Network.Socket (Socket)+import qualified Network.Wai.Handler.Warp.FdCache as F+import Network.Wai.Handler.Warp.Types++defaultSendFile :: Socket -> FilePath -> Integer -> Integer -> IO () -> [ByteString] -> IO ()+defaultSendFile s path off len act hdr = sendfileWithHeader s path (PartOfFile off len) act hdr+++#if SENDFILEFD+setSendFile :: Connection -> Maybe F.MutableFdCache -> Connection+setSendFile conn Nothing = conn+setSendFile conn (Just fdcs) = case connSendFileOverride conn of+ NotOverride -> conn+ Override s -> conn { connSendFile = sendFile fdcs s }++sendFile :: F.MutableFdCache -> Socket -> FilePath -> Integer -> Integer -> IO () -> [ByteString] -> IO ()+sendFile fdcs s path off len act hdr = do+ (fd, fresher) <- F.getFd fdcs path+ sendfileFdWithHeader s fd (PartOfFile off len) (act>>fresher) hdr+#else+setSendFile :: Connection -> Maybe F.MutableFdCache -> Connection+setSendFile conn _ = conn+#endif
Network/Wai/Handler/Warp/Settings.hs view
@@ -2,7 +2,6 @@ import Control.Exception import qualified Data.ByteString as S-import qualified Data.ByteString.Char8 as S8 import Data.Conduit import Data.Conduit.Network (HostPreference (HostIPv4)) import GHC.IO.Exception (IOErrorType(..))@@ -21,18 +20,13 @@ data Settings = Settings { settingsPort :: Int -- ^ Port to listen on. Default value: 3000 , settingsHost :: HostPreference -- ^ Default value: HostIPv4- , 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.+ , settingsOnException :: Maybe Request -> 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. , settingsOnOpen :: IO () -- ^ What to do when a connection is open. Default: do nothing. , settingsOnClose :: IO () -- ^ What to do when a connection is close. Default: do nothing. , settingsTimeout :: Int -- ^ Timeout value in seconds. Default value: 30- , settingsIntercept :: Request -> Maybe (Source (ResourceT IO) S.ByteString -> Connection -> ResourceT IO ())+ , settingsIntercept :: Request -> Maybe (Source IO S.ByteString -> Connection -> IO ()) , settingsManager :: Maybe Manager -- ^ Use an existing timeout manager instead of spawning a new one. If used, 'settingsTimeout' is ignored. Default is 'Nothing' , settingsFdCacheDuration :: Int -- ^ Cache duratoin time of file descriptors in seconds. 0 means that the cache mechanism is not used. Default value: 10- , settingsResourceTPerRequest :: Bool- -- ^ If @True@, each request\/response pair will run in a separate- -- @ResourceT@. This provides more intuitive behavior for dynamic code,- -- but can hinder performance in high-throughput cases. File servers can- -- safely set to @False@ for increased performance. Default is @True@. , settingsBeforeMainLoop :: IO () -- ^ Code to run after the listening socket is ready but before entering -- the main event loop. Useful for signaling to tests that they can start@@ -41,12 +35,6 @@ -- Default: do nothing. -- -- Since 1.3.6- , settingsServerName :: S.ByteString- -- ^ Server name to be sent in the Server header.- --- -- Default: Warp\//version/- --- -- Since 1.3.8 } -- | The default settings for the Warp server. See the individual settings for@@ -62,13 +50,11 @@ , settingsIntercept = const Nothing , settingsManager = Nothing , settingsFdCacheDuration = 10- , settingsResourceTPerRequest = True , settingsBeforeMainLoop = return ()- , settingsServerName = S8.pack $ "Warp/" ++ warpVersion } -defaultExceptionHandler :: SomeException -> IO ()-defaultExceptionHandler e = throwIO e `catches` handlers+defaultExceptionHandler :: Maybe Request -> SomeException -> IO ()+defaultExceptionHandler _ e = throwIO e `catches` handlers where handlers = [Handler ah, Handler ih, Handler oh, Handler sh]
+ Network/Wai/Handler/Warp/Thread.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE DeriveDataTypeable #-}++module Network.Wai.Handler.Warp.Thread (+ forkIOwithBreakableForever+ , breakForever+ ) where++import Control.Concurrent (forkIO)+import Control.Exception (handle, throw, mask_, Exception)+import Control.Monad (void, forever)+import Data.IORef+import Data.Typeable++data BreakForever = BreakForever deriving (Show, Typeable)++instance Exception BreakForever++forkIOwithBreakableForever :: a -> (IORef a -> IO ()) -> IO (IORef a)+forkIOwithBreakableForever ini action = do+ ref <- newIORef ini+ void . forkIO . handle stopPropagation . forever . mask_ $ action ref+ return ref++stopPropagation :: BreakForever -> IO ()+stopPropagation _ = return ()++breakForever :: IORef a -> IO a+breakForever ref = atomicModifyIORef ref $ \x -> (throw BreakForever, x)
Network/Wai/Handler/Warp/Timeout.hs view
@@ -1,21 +1,42 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE UnboxedTuples, MagicHash #-}++-- |+--+-- In order to provide slowloris protection, Warp provides timeout handlers. We+-- follow these rules:+--+-- * A timeout is created when a connection is opened.+--+-- * When all request headers are read, the timeout is tickled.+--+-- * Every time at least 2048 bytes of the request body are read, the timeout+-- is tickled.+--+-- * The timeout is paused while executing user code. This will apply to both+-- the application itself, and a ResponseSource response. The timeout is+-- resumed as soon as we return from user code.+--+-- * Every time data is successfully sent to the client, the timeout is tickled.+ module Network.Wai.Handler.Warp.Timeout (+ -- * Types Manager- , Handle , TimeoutAction+ , Handle+ -- * Manager , initialize , stopManager+ , withManager+ -- * Registration , register , registerKillThread+ -- * Control , tickle+ , cancel , pause , resume- , cancel- , withManager- , dummyHandle ) where #if MIN_VERSION_base(4,6,0)@@ -25,14 +46,12 @@ import GHC.Exts (mkWeak#) import GHC.IO (IO (IO)) #endif-import GHC.Weak (Weak (..))-import Control.Concurrent (forkIO, threadDelay, myThreadId, killThread)+import Control.Concurrent (threadDelay, myThreadId, killThread) import qualified Control.Exception as E-import Control.Monad (forever, void)-import Data.IORef (IORef)-import qualified Data.IORef as I-import Data.Typeable (Typeable)-import System.IO.Unsafe (unsafePerformIO)+import GHC.Weak (Weak (..))+import Network.Wai.Handler.Warp.IORef (IORef)+import qualified Network.Wai.Handler.Warp.IORef as I+import Network.Wai.Handler.Warp.Thread import System.Mem.Weak (deRefWeak) ----------------------------------------------------------------@@ -53,36 +72,20 @@ ---------------------------------------------------------------- --- | A dummy @Handle@.-dummyHandle :: Handle-dummyHandle = Handle (return ()) (unsafePerformIO $ I.newIORef Active)--------------------------------------------------------------------data TimeoutManagerStopped = TimeoutManagerStopped- deriving (Show, Typeable)-instance E.Exception TimeoutManagerStopped------------------------------------------------------------------- -- | Creating timeout manager which works every N micro seconds -- where N is the first argument. initialize :: Int -> IO Manager initialize timeout = do- ref <- I.newIORef []- void . forkIO $ E.handle ignoreStop $ forever $ do+ ref' <- forkIOwithBreakableForever [] $ \ref -> do threadDelay timeout- -- FIXME: isn't mask_ necessary?- old <- I.atomicModifyIORef ref (\x -> ([], x))+ old <- I.atomicModifyIORef' ref (\x -> ([], x)) merge <- prune old id- I.atomicModifyIORef ref (\new -> (merge new, ()))- return $ Manager ref+ I.atomicModifyIORef' ref (\new -> (merge new, ()))+ return $ Manager ref' where- ignoreStop TimeoutManagerStopped = return ()- prune [] front = return front prune (m@(Handle onTimeout iactive):rest) front = do- state <- I.atomicModifyIORef iactive (\x -> (inactivate x, x))+ state <- I.atomicModifyIORef' iactive (\x -> (inactivate x, x)) case state of Inactive -> do onTimeout `E.catch` ignoreAll@@ -94,11 +97,10 @@ ---------------------------------------------------------------- +-- | Stopping timeout manager. stopManager :: Manager -> IO ()-stopManager (Manager ihandles) = E.mask_ $ do- -- Put an undefined value in the IORef to kill the worker thread (yes, it's- -- a bit of a hack)- !handles <- I.atomicModifyIORef ihandles $ \h -> (E.throw TimeoutManagerStopped, h)+stopManager (Manager ref) = E.mask_ $ do+ !handles <- breakForever ref mapM_ fire handles where fire (Handle onTimeout _) = onTimeout `E.catch` ignoreAll@@ -113,7 +115,7 @@ register (Manager ref) onTimeout = do iactive <- I.newIORef Active let h = Handle onTimeout iactive- I.atomicModifyIORef ref (\x -> (h : x, ()))+ I.atomicModifyIORef' ref (\x -> (h : x, ())) return h -- | Registering a timeout action of killing this thread.@@ -154,8 +156,8 @@ pause :: Handle -> IO () pause (Handle _ iactive) = I.writeIORef iactive Paused --- | Setting the state to active.--- This is an alias to 'ticle'.+-- | Setting the paused state to active.+-- This is an alias to 'tickle'. resume :: Handle -> IO () resume = tickle
Network/Wai/Handler/Warp/Types.hs view
@@ -7,94 +7,74 @@ import Control.Exception import Data.ByteString (ByteString) import Data.Typeable (Typeable)-import Data.Version (showVersion) import Network.HTTP.Types.Header-import qualified Paths_warp-import qualified Network.Wai.Handler.Warp.Timeout as T-#if SENDFILEFD+import Network.Socket (Socket)+import qualified Blaze.ByteString.Builder.Internal.Buffer as B (Buffer)+import qualified Network.Wai.Handler.Warp.Date as D import qualified Network.Wai.Handler.Warp.FdCache as F-#endif--------------------------------------------------------------------warpVersion :: String-warpVersion = showVersion Paths_warp.version+import qualified Network.Wai.Handler.Warp.Timeout as T ---------------------------------------------------------------- --- | TCP port number+-- | TCP port number. type Port = Int ---------------------------------------------------------------- +-- | The type for header value used with 'HeaderName'.+type HeaderValue = ByteString+ hTransferEncoding :: HeaderName hTransferEncoding = "Transfer-Encoding" -hHost :: HeaderName-hHost = "Host"+hContentRange :: HeaderName+hContentRange = "Content-Range" +hAcceptRanges :: HeaderName+hAcceptRanges = "Accept-Ranges"+ hServer :: HeaderName hServer = "Server" ---------------------------------------------------------------- -data InvalidRequest =- NotEnoughLines [String]- | BadFirstLine String- | NonHttp- | IncompleteHeaders- | ConnectionClosedByPeer- | OverLargeHeader- deriving (Eq, Show, Typeable)+-- | Error types for bad 'Request'.+data InvalidRequest = NotEnoughLines [String]+ | BadFirstLine String+ | NonHttp+ | IncompleteHeaders+ | ConnectionClosedByPeer+ | OverLargeHeader+ deriving (Eq, Show, Typeable) instance Exception InvalidRequest ---------------------------------------------------------------- --- |------ In order to provide slowloris protection, Warp provides timeout handlers. We--- follow these rules:------ * A timeout is created when a connection is opened.------ * When all request headers are read, the timeout is tickled.------ * Every time at least 2048 bytes of the request body are read, the timeout--- is tickled.------ * The timeout is paused while executing user code. This will apply to both--- the application itself, and a ResponseSource response. The timeout is--- resumed as soon as we return from user code.------ * Every time data is successfully sent to the client, the timeout is tickled.+-- | Whether or not 'ConnSendFileOverride' in 'Connection' can be+-- overridden. This is a kind of hack to keep the signature of+-- 'Connection' clean.+data ConnSendFileOverride = NotOverride -- ^ Don't override+ | Override Socket -- ^ Override with this 'Socket'++----------------------------------------------------------------++-- | Data type to manipulate IO actions for connections. data Connection = Connection { connSendMany :: [ByteString] -> IO () , connSendAll :: ByteString -> IO ()- , connSendFile :: FilePath -> Integer -> Integer -> IO () -> [ByteString] -> Cleaner -> IO () -- ^ offset, length+ , connSendFile :: FilePath -> Integer -> Integer -> IO () -> [ByteString] -> IO () -- ^ filepath, offset, length, hook action, HTTP headers , connClose :: IO () , connRecv :: IO ByteString+ , connBuffer :: B.Buffer+ , connSendFileOverride :: ConnSendFileOverride } ---------------------------------------------------------------- --- | A dummy @Cleaner@, intended for applications making use of the low-level--- request parsing and rendering functions.------ Since 1.3.4-dummyCleaner :: Cleaner--#if SENDFILEFD-dummyCleaner = Cleaner T.dummyHandle Nothing---- | A type used to clean up file descriptor caches.-data Cleaner = Cleaner {+-- | Internal information.+data InternalInfo = InternalInfo { threadHandle :: T.Handle , fdCacher :: Maybe F.MutableFdCache+ , dateCacher :: D.DateCache }--#else-dummyCleaner = Cleaner T.dummyHandle--newtype Cleaner = Cleaner { threadHandle :: T.Handle }-#endif
+ bench/Parser.hs view
@@ -0,0 +1,215 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE BangPatterns #-}++module Main where++import Control.Exception (throwIO, throw)+import Control.Monad+import qualified Data.ByteString as S+--import Data.ByteString.Char8 (ByteString)+import qualified Data.ByteString.Char8 as B (unpack)+import qualified Network.HTTP.Types as H+import Network.Wai.Handler.Warp.Types+import Prelude hiding (lines)++import Data.ByteString.Internal+import Data.Word+import Foreign.ForeignPtr+import Foreign.Ptr+import Foreign.Storable++import Criterion.Main++-- $setup+-- >>> :set -XOverloadedStrings++----------------------------------------------------------------++main :: IO ()+main = do+ let requestLine1 = "GET http://www.example.com HTTP/1.1"+ let requestLine2 = "GET http://www.example.com/cgi-path/search.cgi?key=parser HTTP/1.0"+ defaultMain [+ bgroup "requestLine1" [+ bench "parseRequestLine3" $ whnf parseRequestLine3 requestLine1+ , bench "parseRequestLine2" $ parseRequestLine2 requestLine1+ , bench "parseRequestLine1" $ parseRequestLine1 requestLine1+ , bench "parseRequestLine0" $ parseRequestLine0 requestLine1+ ]+ , bgroup "requestLine2" [+ bench "parseRequestLine3" $ whnf parseRequestLine3 requestLine2+ , bench "parseRequestLine2" $ parseRequestLine2 requestLine2+ , bench "parseRequestLine1" $ parseRequestLine1 requestLine2+ , bench "parseRequestLine0" $ parseRequestLine0 requestLine2+ ]+ ]++----------------------------------------------------------------++-- |+--+-- >>> parseRequestLine3 "GET / HTTP/1.1"+-- ("GET","/","",HTTP/1.1)+-- >>> parseRequestLine3 "POST /cgi/search.cgi?key=foo HTTP/1.0"+-- ("POST","/cgi/search.cgi","?key=foo",HTTP/1.0)+-- >>> parseRequestLine3 "GET "+-- *** Exception: BadFirstLine "GET "+-- >>> parseRequestLine3 "GET /NotHTTP UNKNOWN/1.1"+-- *** Exception: NonHttp+parseRequestLine3 :: ByteString+ -> (H.Method+ ,ByteString -- Path+ ,ByteString -- Query+ ,H.HttpVersion)+parseRequestLine3 requestLine = ret+ where+ (!method,!rest) = S.breakByte 32 requestLine -- ' '+ (!pathQuery,!httpVer')+ | rest == "" = throw badmsg+ | otherwise = S.breakByte 32 (S.drop 1 rest) -- ' '+ (!path,!query) = S.breakByte 63 pathQuery -- '?'+ !httpVer = S.drop 1 httpVer'+ (!http,!ver)+ | httpVer == "" = throw badmsg+ | otherwise = S.breakByte 47 httpVer -- '/'+ !hv | http /= "HTTP" = throw NonHttp+ | ver == "/1.1" = H.http11+ | otherwise = H.http10+ !ret = (method,path,query,hv)+ badmsg = BadFirstLine $ B.unpack requestLine++----------------------------------------------------------------++-- |+--+-- >>> parseRequestLine2 "GET / HTTP/1.1"+-- ("GET","/","",HTTP/1.1)+-- >>> parseRequestLine2 "POST /cgi/search.cgi?key=foo HTTP/1.0"+-- ("POST","/cgi/search.cgi","?key=foo",HTTP/1.0)+-- >>> parseRequestLine2 "GET "+-- *** Exception: BadFirstLine "GET "+-- >>> parseRequestLine2 "GET /NotHTTP UNKNOWN/1.1"+-- *** Exception: NonHttp+parseRequestLine2 :: ByteString+ -> IO (H.Method+ ,ByteString -- Path+ ,ByteString -- Query+ ,H.HttpVersion)+parseRequestLine2 requestLine@(PS fptr off len) = withForeignPtr fptr $ \ptr -> do+ when (len < 14) $ throwIO baderr+ let methodptr = ptr `plusPtr` off+ limptr = methodptr `plusPtr` len+ lim0 = fromIntegral len++ pathptr0 <- memchr methodptr 32 lim0 -- ' '+ when (pathptr0 == nullPtr || (limptr `minusPtr` pathptr0) < 11) $+ throwIO baderr+ let pathptr = pathptr0 `plusPtr` 1+ lim1 = fromIntegral (limptr `minusPtr` pathptr0)++ httpptr0 <- memchr pathptr 32 lim1 -- ' '+ when (httpptr0 == nullPtr || (limptr `minusPtr` httpptr0) < 9) $+ throwIO baderr+ let httpptr = httpptr0 `plusPtr` 1+ lim2 = fromIntegral (httpptr0 `minusPtr` pathptr)++ checkHTTP httpptr+ !hv <- httpVersion httpptr+ queryptr <- memchr pathptr 63 lim2 -- '?'++ let !method = bs ptr methodptr pathptr0+ !path+ | queryptr == nullPtr = bs ptr pathptr httpptr0+ | otherwise = bs ptr pathptr queryptr+ !query+ | queryptr == nullPtr = S.empty+ | otherwise = bs ptr queryptr httpptr0++ return (method,path,query,hv)+ where+ baderr = BadFirstLine $ B.unpack requestLine+ check :: Ptr Word8 -> Int -> Word8 -> IO ()+ check p n w = do+ w0 <- peek $ p `plusPtr` n+ when (w0 /= w) $ throwIO NonHttp+ checkHTTP httpptr = do+ check httpptr 0 72 -- 'H'+ check httpptr 1 84 -- 'T'+ check httpptr 2 84 -- 'T'+ check httpptr 3 80 -- 'P'+ check httpptr 4 47 -- '/'+ check httpptr 6 46 -- '.'+ httpVersion httpptr = do+ major <- peek $ httpptr `plusPtr` 5+ minor <- peek $ httpptr `plusPtr` 7+ if major == (49 :: Word8) && minor == (49 :: Word8) then+ return H.http11+ else+ return H.http10+ bs ptr p0 p1 = PS fptr o l+ where+ o = p0 `minusPtr` ptr+ l = p1 `minusPtr` p0++----------------------------------------------------------------++-- |+--+-- >>> parseRequestLine1 "GET / HTTP/1.1"+-- ("GET","/","",HTTP/1.1)+-- >>> parseRequestLine1 "POST /cgi/search.cgi?key=foo HTTP/1.0"+-- ("POST","/cgi/search.cgi","?key=foo",HTTP/1.0)+-- >>> parseRequestLine1 "GET "+-- *** Exception: BadFirstLine "GET "+-- >>> parseRequestLine1 "GET /NotHTTP UNKNOWN/1.1"+-- *** Exception: NonHttp+parseRequestLine1 :: ByteString+ -> IO (H.Method+ ,ByteString -- Path+ ,ByteString -- Query+ ,H.HttpVersion)+parseRequestLine1 requestLine = do+ let (!method,!rest) = S.breakByte 32 requestLine -- ' '+ (!pathQuery,!httpVer') = S.breakByte 32 (S.drop 1 rest) -- ' '+ !httpVer = S.drop 1 httpVer'+ when (rest == "" || httpVer == "") $+ throwIO $ BadFirstLine $ B.unpack requestLine+ let (!path,!query) = S.breakByte 63 pathQuery -- '?'+ (!http,!ver) = S.breakByte 47 httpVer -- '/'+ when (http /= "HTTP") $ throwIO NonHttp+ let !hv | ver == "/1.1" = H.http11+ | otherwise = H.http10+ return $! (method,path,query,hv)++----------------------------------------------------------------++-- |+--+-- >>> parseRequestLine0 "GET / HTTP/1.1"+-- ("GET","/","",HTTP/1.1)+-- >>> parseRequestLine0 "POST /cgi/search.cgi?key=foo HTTP/1.0"+-- ("POST","/cgi/search.cgi","?key=foo",HTTP/1.0)+-- >>> parseRequestLine0 "GET "+-- *** Exception: BadFirstLine "GET "+-- >>> parseRequestLine0 "GET /NotHTTP UNKNOWN/1.1"+-- *** Exception: NonHttp+parseRequestLine0 :: ByteString+ -> IO (H.Method+ ,ByteString -- Path+ ,ByteString -- Query+ ,H.HttpVersion)+parseRequestLine0 s =+ case filter (not . S.null) $ S.splitWith (\c -> c == 32 || c == 9) s of -- '+ (method':query:http'') -> do+ let !method = method'+ !http' = S.concat http''+ (!hfirst, !hsecond) = S.splitAt 5 http'+ if hfirst == "HTTP/"+ then let (!rpath, !qstring) = S.breakByte 63 query -- '?'+ !hv =+ case hsecond of+ "1.1" -> H.http11+ _ -> H.http10+ in return $! (method, rpath, qstring, hv)+ else throwIO NonHttp+ _ -> throwIO $ BadFirstLine $ B.unpack s
+ test/ConduitSpec.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE OverloadedStrings #-}+module ConduitSpec (main, spec) where++import Network.Wai.Handler.Warp.Conduit+import Data.Conduit+import qualified Data.Conduit.List as CL+import Test.Hspec+import qualified Data.IORef as I+import qualified Data.ByteString as S++main :: IO ()+main = hspec spec++spec :: Spec+spec = describe "conduit" $ do+ it "IsolatedBSSource" $ do+ (rsrc, ()) <- mapM_ yield (map S.singleton [1..50]) $$+ return ()+ ibs <- fmap IsolatedBSSource $ I.newIORef (40, rsrc)+ x <- ibsIsolate ibs $$ CL.take 20+ S.concat x `shouldBe` S.pack [1..20]++ y <- ibsIsolate ibs $$ CL.consume+ S.concat y `shouldBe` S.pack [21..40]++ rsrc' <- ibsDone ibs+ z <- rsrc' $$+- CL.consume+ S.concat z `shouldBe` S.pack [41..50]+ it "chunkedSource" $ do+ (rsrc, ()) <- yield "5\r\n12345\r\n3\r\n678\r\n0\r\nBLAH" $$+ return ()+ ref <- I.newIORef (rsrc, NeedLen)+ x <- chunkedSource ref $$ CL.consume+ S.concat x `shouldBe` "12345678"
+ test/ExceptionSpec.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE OverloadedStrings #-}++module ExceptionSpec (main, spec) where++import Control.Applicative+import Control.Monad+import Control.Concurrent (forkIO, threadDelay)+import Network.HTTP+import Network.Stream+import Network.HTTP.Types hiding (Header)+import Network.Wai hiding (Response)+import Network.Wai.Internal (Request(..))+import Network.Wai.Handler.Warp+import System.IO.Unsafe (unsafePerformIO)+import Test.Hspec++main :: IO ()+main = hspec spec++testServer :: IO ()+testServer =+ run 2345 testApp++testApp :: Application+testApp (Network.Wai.Internal.Request {pathInfo = [x]})+ | x == "statusError" =+ return $ responseLBS undefined [] "foo"+ | x == "headersError" =+ return $ responseLBS ok200 undefined "foo"+ | x == "headerError" =+ return $ responseLBS ok200 [undefined] "foo"+ | x == "bodyError" =+ return $ responseLBS ok200 [] undefined+ | x == "ioException" = do+ void $ fail "ioException"+ return $ responseLBS ok200 [] "foo"+testApp _ =+ return $ responseLBS ok200 [] "foo"++spec :: Spec+spec = unsafePerformIO $ (forkIO testServer >> threadDelay 100000 >>) $ return $+ describe "responds even if there is an exception" $ do+ it "statusError" $ do+ sc <- rspCode <$> sendGET "http://localhost:2345/statusError"+ sc `shouldBe` (5,0,0)+ it "headersError" $ do+ sc <- rspCode <$> sendGET "http://localhost:2345/headersError"+ sc `shouldBe` (5,0,0)+ it "headerError" $ do+ sc <- rspCode <$> sendGET "http://localhost:2345/headerError"+ sc `shouldBe` (5,0,0)+ it "bodyError" $ do+ sc <- rspCode <$> sendGET "http://localhost:2345/bodyError"+ sc `shouldBe` (5,0,0)+ it "ioException" $ do+ sc <- rspCode <$> sendGET "http://localhost:2345/ioException"+ sc `shouldBe` (5,0,0)++----------------------------------------------------------------++sendGET :: String -> IO (Response String)+sendGET url = sendGETwH url []++sendGETwH :: String -> [Header] -> IO (Response String)+sendGETwH url hdr = unResult $ simpleHTTP $ (getRequest url) { rqHeaders = hdr }++unResult :: IO (Result (Response String)) -> IO (Response String)+unResult action = do+ res <- action+ case res of+ Right rsp -> return rsp+ Left _ -> error "Connection error"
+ test/FdCacheSpec.hs view
@@ -0,0 +1,20 @@+module FdCacheSpec where++import Data.IORef+import Network.Wai.Handler.Warp.FdCache+import System.Posix.IO (fdRead)+import System.Posix.Types (Fd(..))+import Test.Hspec++main :: IO ()+main = hspec spec++spec :: Spec+spec = describe "withFdCache" $ do+ it "clean up Fd" $ do+ ref <- newIORef (Fd (-1))+ withFdCache 30000000 $ \(Just mfc) -> do+ (fd,_) <- getFd mfc "warp.cabal"+ writeIORef ref fd+ nfd <- readIORef ref+ fdRead nfd 1 `shouldThrow` anyIOException
+ test/MultiMapSpec.hs view
@@ -0,0 +1,30 @@+module MultiMapSpec where++import Network.Wai.Handler.Warp.MultiMap+import Test.Hspec+import Test.QuickCheck (property)++type Alist = [(Int,Char)]++spec :: Spec+spec = do+ describe "fromList" $ do+ it "generates a valid tree" $ property $ \xs ->+ valid $ fromList (xs :: Alist)+ describe "toSortedList" $ do+ it "generated a sorted list" $ property $ \xs ->+ ordered $ toSortedList $ fromList (xs :: Alist)+ describe "search" $ do+ it "acts as the list model" $ property $ \x xs ->+ search x (fromList xs) == lookup x (xs :: Alist)+ describe "fromSortedList" $ do+ it "generates a valid tree" $ property $ \xs ->+ valid . fromSortedList . toSortedList . fromList $ (xs :: Alist)+ it "maintains the tree with toSortedList" $ property $ \xs ->+ let t1 = fromList (xs :: Alist)+ t2 = fromSortedList $ toSortedList t1+ in t1 == t2++ordered :: Ord a => [(a, b)] -> Bool+ordered (x:y:xys) = fst x <= fst y && ordered (y:xys)+ordered _ = True
+ test/ReadIntSpec.hs view
@@ -0,0 +1,26 @@+module ReadIntSpec (main, spec) where++import Data.ByteString (ByteString)+import Test.Hspec+import Network.Wai.Handler.Warp.ReadInt+import qualified Data.ByteString.Char8 as B+import qualified Test.QuickCheck as QC++main :: IO ()+main = hspec spec++spec :: Spec+spec = describe "readInt64" $ do+ it "converts ByteString to Int" $ QC.property (prop_read_show_idempotent readInt64)++-- A QuickCheck property. Test that for a number >= 0, converting it to+-- a string using show and then reading the value back with the function+-- under test returns the original value.+-- The functions under test only work on Natural numbers (the Conent-Length+-- field in a HTTP header is always >= 0) so we check the absolute value of+-- the value that QuickCheck generates for us.+prop_read_show_idempotent :: (Integral a, Show a) => (ByteString -> a) -> a -> Bool+prop_read_show_idempotent freader x = px == freader (toByteString px)+ where+ px = abs x+ toByteString = B.pack . show
+ test/RequestSpec.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE OverloadedStrings #-}++module RequestSpec (main, spec) where++import Data.Conduit+import Data.Conduit.List+import Network.Wai.Handler.Warp.Request+import Network.Wai.Handler.Warp.Types+import Test.Hspec++main :: IO ()+main = hspec spec++spec :: Spec+spec = describe "headerLines" $ do+ it "takes until blank" $+ blankSafe >>= (`shouldBe` ["foo", "bar", "baz"])+ it "ignored leading whitespace in bodies" $+ whiteSafe >>= (`shouldBe` ["foo", "bar", "baz"])+ it "throws OverLargeHeader when too many" $+ tooMany `shouldThrow` overLargeHeader+ it "throws OverLargeHeader when too large" $+ tooLarge `shouldThrow` overLargeHeader+ where+ blankSafe = (sourceList ["f", "oo\n", "bar\nbaz\n\r\n"]) $$ headerLines+ whiteSafe = (sourceList ["foo\r\nbar\r\nbaz\r\n\r\n hi there"]) $$ headerLines+ tooMany = (sourceList $ repeat "f\n") $$ headerLines+ tooLarge = (sourceList $ repeat "f") $$ headerLines++overLargeHeader :: Selector InvalidRequest+overLargeHeader e = e == OverLargeHeader
+ test/ResponseHeaderSpec.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE OverloadedStrings #-}++module ResponseHeaderSpec (main, spec) where++import Data.ByteString+import qualified Network.HTTP.Types as H+import Network.Wai.Handler.Warp.ResponseHeader+import Test.Hspec++main :: IO ()+main = hspec spec++spec :: Spec+spec = describe "composeHeader" $ do+ it "composes a HTTP header" $+ composeHeader H.http11 H.ok200 headers `shouldReturn` composedHeader++headers :: H.ResponseHeaders+headers = [+ ("Date", "Mon, 13 Aug 2012 04:22:55 GMT")+ , ("Content-Lenght", "151")+ , ("Server", "Mighttpd/2.5.8")+ , ("Last-Modified", "Fri, 22 Jun 2012 01:18:08 GMT")+ , ("Content-Type", "text/html")+ ]++composedHeader :: ByteString+composedHeader = "HTTP/1.1 200 OK\r\nDate: Mon, 13 Aug 2012 04:22:55 GMT\r\nContent-Lenght: 151\r\nServer: Mighttpd/2.5.8\r\nLast-Modified: Fri, 22 Jun 2012 01:18:08 GMT\r\nContent-Type: text/html\r\n\r\n"
+ test/ResponseSpec.hs view
@@ -0,0 +1,124 @@+{-# LANGUAGE OverloadedStrings #-}+module ResponseSpec (main, spec) where++import Control.Concurrent (threadDelay)+import qualified Data.ByteString as S+import qualified Data.ByteString.Char8 as S8+import Data.Maybe (mapMaybe)+import Network (connectTo, PortID (PortNumber))+import Network.HTTP.Types+import Network.Wai+import Network.Wai.Handler.Warp+import Network.Wai.Handler.Warp.Response+import RunSpec (withApp)+import System.IO (hClose, hFlush)+import Test.Hspec++main :: IO ()+main = hspec spec++testRange :: S.ByteString -- ^ range value+ -> String -- ^ expected output+ -> String -- ^ expected content-range value+ -> Spec+testRange range out crange = it title $ withApp defaultSettings app $ \port -> do+ handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port+ S.hPutStr handle "GET / HTTP/1.0\r\n"+ S.hPutStr handle "Range: bytes="+ S.hPutStr handle range+ S.hPutStr handle "\r\n\r\n"+ hFlush handle+ threadDelay 10000+ bss <- fmap (lines . filter (/= '\r') . S8.unpack) $ S.hGetSome handle 1024+ hClose handle+ out `shouldBe` last bss+ let hs = mapMaybe toHeader bss+ lookup "Content-Range" hs `shouldBe` Just ("bytes " ++ crange)+ lookup "Content-Length" hs `shouldBe` Just (show $ length $ last bss)+ where+ app _ = return $ responseFile status200 [] "attic/hex" Nothing+ title = show (range, out, crange)+ toHeader s =+ case break (== ':') s of+ (x, ':':y) -> Just (x, dropWhile (== ' ') y)+ _ -> Nothing++testPartial :: Integer -- ^ file size+ -> Integer -- ^ offset+ -> Integer -- ^ byte count+ -> String -- ^ expected output+ -> Spec+testPartial size offset count out = it title $ withApp defaultSettings app $ \port -> do+ handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port+ S.hPutStr handle "GET / HTTP/1.0\r\n\r\n"+ hFlush handle+ threadDelay 10000+ bss <- fmap (lines . filter (/= '\r') . S8.unpack) $ S.hGetSome handle 1024+ hClose handle+ out `shouldBe` last bss+ let hs = mapMaybe toHeader bss+ lookup "Content-Length" hs `shouldBe` Just (show $ length $ last bss)+ lookup "Content-Range" hs `shouldBe` Just range+ where+ app _ = return $ responseFile status200 [] "attic/hex" $ Just $ FilePart offset count size+ title = show (offset, count, out)+ toHeader s =+ case break (== ':') s of+ (x, ':':y) -> Just (x, dropWhile (== ' ') y)+ _ -> Nothing+ range = "bytes " ++ show offset ++ "-" ++ show (offset + count - 1) ++ "/" ++ show size++testFileRange :: String+ -> Status -> ResponseHeaders -> FilePath+ -> Maybe FilePart -> Maybe HeaderValue+ -> Either String (Status, ResponseHeaders, Integer, Integer)+ -> Spec+testFileRange desc s rsphdr file mPart mRange ans = it desc $ do+ eres <- fileRange s rsphdr file mPart mRange+ let res = case eres of+ Left e -> Left $ show e+ Right r -> Right r+ res `shouldBe` ans++spec :: Spec+spec = do+ describe "range requests" $ do+ testRange "2-3" "23" "2-3/16"+ testRange "5-" "56789abcdef" "5-15/16"+ testRange "5-8" "5678" "5-8/16"+ testRange "-3" "def" "13-15/16"++ describe "partial files" $ do+ testPartial 16 2 2 "23"+ testPartial 16 0 2 "01"+ testPartial 16 3 8 "3456789a"++ describe "fileRange" $ do+ testFileRange+ "gets a file size from file system"+ status200 [] "attic/hex" Nothing Nothing+ $ Right (status200,[("Content-Length","16")],0,16)+ testFileRange+ "gets an error if a file does not exist"+ status200 [] "attic/nonexist" Nothing Nothing+ $ Left "attic/nonexist: getFileStatus: does not exist (No such file or directory)"+ testFileRange+ "changes status if FileParts is specified"+ status200 [] "attic/hex" (Just (FilePart 2 10 16)) Nothing+ $ Right (status206,[("Content-Range", "bytes 2-11/16"),("Content-Length","10")],2,10)+ testFileRange+ "does not change status and does not add Content-Range if FileParts means the entire"+ status200 [] "attic/hex" (Just (FilePart 0 16 16)) Nothing+ $ Right (status200,[("Content-Length","16")],0,16)+ testFileRange+ "gets a file size from file system and handles Range and returns Partical Content"+ status200 [] "attic/hex" Nothing (Just "bytes=2-14")+ $ Right (status206,[("Content-Range","bytes 2-14/16"),("Content-Length","13")],2,13)+ testFileRange+ "gets a file size from file system and handles Range and returns OK if Range means the entire"+ status200 [] "attic/hex" Nothing (Just "bytes=0-15")+ $ Right (status200,[("Content-Length","16")],0,16)+ testFileRange+ "igores Range if FilePart is specified"+ status200 [] "attic/hex" (Just (FilePart 2 10 16)) (Just "bytes=8-9")+ $ Right (status206,[("Content-Range", "bytes 2-11/16"),("Content-Length","10")],2,10)
+ test/RunSpec.hs view
@@ -0,0 +1,295 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++module RunSpec (main, spec, withApp) where++import Control.Concurrent (forkIO, killThread, threadDelay)+import Control.Monad (forM_, replicateM_)+import System.Timeout (timeout)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.ByteString (ByteString, hPutStr, hGetSome)+import qualified Data.ByteString as S+import qualified Data.ByteString.Char8 as S8+import qualified Data.ByteString.Lazy as L+import Data.Conduit (($$))+import qualified Data.Conduit.List+import qualified Data.IORef as I+import Network (connectTo, PortID (PortNumber))+import Network.HTTP.Types+import Network.Wai+import Network.Wai.Handler.Warp+import System.IO (hFlush, hClose)+import System.IO.Unsafe (unsafePerformIO)+import Test.Hspec+import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar)+import Control.Exception.Lifted (bracket, try, IOException, onException)+import Data.Conduit.Network (bindPort)+import Network.Socket (sClose)++main :: IO ()+main = hspec spec++type Counter = I.IORef (Either String Int)+type CounterApplication = Counter -> Application++incr :: MonadIO m => Counter -> m ()+incr icount = liftIO $ I.atomicModifyIORef icount $ \ecount ->+ ((case ecount of+ Left s -> Left s+ Right i -> Right $ i + 1), ())++err :: (MonadIO m, Show a) => Counter -> a -> m ()+err icount msg = liftIO $ I.writeIORef icount $ Left $ show msg++readBody :: CounterApplication+readBody icount req = do+ body <- requestBody req $$ Data.Conduit.List.consume+ case () of+ ()+ | pathInfo req == ["hello"] && L.fromChunks body /= "Hello"+ -> err icount ("Invalid hello" :: String, body)+ | requestMethod req == "GET" && L.fromChunks body /= ""+ -> err icount ("Invalid GET" :: String, body)+ | not $ requestMethod req `elem` ["GET", "POST"]+ -> err icount ("Invalid request method (readBody)" :: String, requestMethod req)+ | otherwise -> incr icount+ return $ responseLBS status200 [] "Read the body"++ignoreBody :: CounterApplication+ignoreBody icount req = do+ if (requestMethod req `elem` ["GET", "POST"])+ then incr icount+ else err icount ("Invalid request method" :: String, requestMethod req)+ return $ responseLBS status200 [] "Ignored the body"++doubleConnect :: CounterApplication+doubleConnect icount req = do+ _ <- requestBody req $$ Data.Conduit.List.consume+ _ <- requestBody req $$ Data.Conduit.List.consume+ incr icount+ return $ responseLBS status200 [] "double connect"++nextPort :: I.IORef Int+nextPort = unsafePerformIO $ I.newIORef 5000++getPort :: IO Int+getPort = do+ port <- I.atomicModifyIORef nextPort $ \p -> (p + 1, p)+ esocket <- try $ bindPort port HostIPv4+ case esocket of+ Left (_ :: IOException) -> getPort+ Right socket -> do+ sClose socket+ return port++withApp :: Settings -> Application -> (Int -> IO a) -> IO a+withApp settings app f = do+ port <- getPort+ baton <- newEmptyMVar+ bracket+ (forkIO $ runSettings settings+ { settingsPort = port+ , settingsBeforeMainLoop = putMVar baton ()+ } app `onException` putMVar baton ())+ killThread+ (const $ takeMVar baton >> f port)++runTest :: Int -- ^ expected number of requests+ -> CounterApplication+ -> [ByteString] -- ^ chunks to send+ -> IO ()+runTest expected app chunks = do+ ref <- I.newIORef (Right 0)+ withApp defaultSettings (app ref) $ \port -> do+ handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port+ forM_ chunks $ \chunk -> hPutStr handle chunk >> hFlush handle+ _ <- timeout 100000 $ replicateM_ expected $ hGetSome handle 4096+ res <- I.readIORef ref+ case res of+ Left s -> error s+ Right i -> i `shouldBe` expected++dummyApp :: Application+dummyApp _ = return $ responseLBS status200 [] "foo"++runTerminateTest :: InvalidRequest+ -> ByteString+ -> IO ()+runTerminateTest expected input = do+ ref <- I.newIORef Nothing+ withApp defaultSettings+ { settingsOnException = \_ e -> I.writeIORef ref $ Just e+ } dummyApp $ \port -> do+ handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port+ hPutStr handle input+ hFlush handle+ hClose handle+ threadDelay 1000+ res <- I.readIORef ref+ show res `shouldBe` show (Just expected)++singleGet :: ByteString+singleGet = "GET / HTTP/1.1\r\nHost: localhost\r\n\r\n"++singlePostHello :: ByteString+singlePostHello = "POST /hello HTTP/1.1\r\nHost: localhost\r\nContent-length: 5\r\n\r\nHello"++spec :: Spec+spec = do+ describe "non-pipelining" $ do+ it "no body, read" $ runTest 5 readBody $ replicate 5 singleGet+ it "no body, ignore" $ runTest 5 ignoreBody $ replicate 5 singleGet+ it "has body, read" $ runTest 2 readBody+ [ singlePostHello+ , singleGet+ ]+ it "has body, ignore" $ runTest 2 ignoreBody+ [ singlePostHello+ , singleGet+ ]+ describe "pipelining" $ do+ it "no body, read" $ runTest 5 readBody [S.concat $ replicate 5 singleGet]+ it "no body, ignore" $ runTest 5 ignoreBody [S.concat $ replicate 5 singleGet]+ it "has body, read" $ runTest 2 readBody $ return $ S.concat+ [ singlePostHello+ , singleGet+ ]+ it "has body, ignore" $ runTest 2 ignoreBody $ return $ S.concat+ [ singlePostHello+ , singleGet+ ]+ describe "no hanging" $ do+ it "has body, read" $ runTest 1 readBody $ map S.singleton $ S.unpack singlePostHello+ it "double connect" $ runTest 1 doubleConnect [singlePostHello]++ describe "connection termination" $ do+-- it "ConnectionClosedByPeer" $ runTerminateTest ConnectionClosedByPeer "GET / HTTP/1.1\r\ncontent-length: 10\r\n\r\nhello"+ it "IncompleteHeaders" $ runTerminateTest IncompleteHeaders "GET / HTTP/1.1\r\ncontent-length: 10\r\n"++ describe "special input" $ do+ it "multiline headers" $ do+ iheaders <- I.newIORef []+ let app req = do+ liftIO $ I.writeIORef iheaders $ requestHeaders req+ return $ responseLBS status200 [] ""+ withApp defaultSettings app $ \port -> do+ handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port+ let input = S.concat+ [ "GET / HTTP/1.1\r\nfoo: bar\r\n baz\r\n\tbin\r\n\r\n"+ ]+ hPutStr handle input+ hFlush handle+ hClose handle+ threadDelay 1000+ headers <- I.readIORef iheaders+ headers `shouldBe`+ [ ("foo", "bar baz\tbin")+ ]+ it "no space between colon and value" $ do+ iheaders <- I.newIORef []+ let app req = do+ liftIO $ I.writeIORef iheaders $ requestHeaders req+ return $ responseLBS status200 [] ""+ withApp defaultSettings app $ \port -> do+ handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port+ let input = S.concat+ [ "GET / HTTP/1.1\r\nfoo:bar\r\n\r\n"+ ]+ hPutStr handle input+ hFlush handle+ hClose handle+ threadDelay 1000+ headers <- I.readIORef iheaders+ headers `shouldBe`+ [ ("foo", "bar")+ ]++ describe "chunked bodies" $ do+ it "works" $ do+ ifront <- I.newIORef id+ let app req = do+ bss <- requestBody req $$ Data.Conduit.List.consume+ liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())+ return $ responseLBS status200 [] ""+ withApp defaultSettings app $ \port -> do+ handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port+ let input = S.concat+ [ "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"+ , "c\r\nHello World\n\r\n3\r\nBye\r\n0\r\n\r\n"+ , "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"+ , "b\r\nHello World\r\n0\r\n\r\n"+ ]+ hPutStr handle input+ hFlush handle+ hClose handle+ threadDelay 1000+ front <- I.readIORef ifront+ front [] `shouldBe`+ [ "Hello World\nBye"+ , "Hello World"+ ]+ it "lots of chunks" $ do+ ifront <- I.newIORef id+ let app req = do+ bss <- requestBody req $$ Data.Conduit.List.consume+ liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())+ return $ responseLBS status200 [] ""+ withApp defaultSettings app $ \port -> do+ handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port+ let input = concat $ replicate 2 $+ ["POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"] +++ (replicate 50 "5\r\n12345\r\n") +++ ["0\r\n\r\n"]+ mapM_ (\bs -> hPutStr handle bs >> hFlush handle) input+ hClose handle+ threadDelay 1000+ front <- I.readIORef ifront+ front [] `shouldBe` replicate 2 (S.concat $ replicate 50 "12345")+ it "in chunks" $ do+ ifront <- I.newIORef id+ let app req = do+ bss <- requestBody req $$ Data.Conduit.List.consume+ liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())+ return $ responseLBS status200 [] ""+ withApp defaultSettings app $ \port -> do+ handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port+ let input = S.concat+ [ "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"+ , "c\r\nHello World\n\r\n3\r\nBye\r\n0\r\n"+ , "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"+ , "b\r\nHello World\r\n0\r\n\r\n"+ ]+ mapM_ (\bs -> hPutStr handle bs >> hFlush handle) $ map S.singleton $ S.unpack input+ hClose handle+ threadDelay 1000+ front <- I.readIORef ifront+ front [] `shouldBe`+ [ "Hello World\nBye"+ , "Hello World"+ ]+ it "timeout in request body" $ do+ ifront <- I.newIORef id+ let app req = do+ bss <- (requestBody req $$ Data.Conduit.List.consume) `onException`+ liftIO (I.atomicModifyIORef ifront (\front -> (front . ("consume interrupted":), ())))+ liftIO $ threadDelay 4000000 `onException`+ I.atomicModifyIORef ifront (\front -> (front . ("threadDelay interrupted":), ()))+ liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())+ return $ responseLBS status200 [] ""+ withApp defaultSettings { settingsTimeout = 1 } app $ \port -> do+ let bs1 = S.replicate 2048 88+ bs2 = "This is short"+ bs = S.append bs1 bs2+ handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port+ hPutStr handle "POST / HTTP/1.1\r\n"+ hPutStr handle "content-length: "+ hPutStr handle $ S8.pack $ show $ S.length bs+ hPutStr handle "\r\n\r\n"+ threadDelay 100000+ hPutStr handle bs1+ threadDelay 100000+ hPutStr handle bs2+ hClose handle+ threadDelay 5000000+ front <- I.readIORef ifront+ S.concat (front []) `shouldBe` bs
+ test/ThreadSpec.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE BangPatterns #-}++module ThreadSpec where++import Control.Concurrent (threadDelay)+import Data.IORef (readIORef, writeIORef, atomicModifyIORef)+import Network.Wai.Handler.Warp.Thread+import Test.Hspec++main :: IO ()+main = hspec spec++spec :: Spec+spec = describe "forkIOwithBreakableForever" $ do+ it "can be breakable" $ do+ ref' <- forkIOwithBreakableForever True $ \ref -> do+ threadDelay 1000+ !_ <- atomicModifyIORef ref (\x -> (False, x))+ return ()+ threadDelay 100000+ readIORef ref' `shouldReturn` False+ _ <- breakForever ref'+ threadDelay 100000+ writeIORef ref' True+ threadDelay 100000+ readIORef ref' `shouldReturn` True
+ test/doctests.hs view
@@ -0,0 +1,11 @@+module Main where++import Test.DocTest++main :: IO ()+main = doctest [+ "-idist/build/autogen/"+ , "-optP-include"+ , "-optPdist/build/autogen/cabal_macros.h"+ , "Network/Wai/Handler/Warp.hs"+ ]
warp.cabal view
@@ -1,5 +1,5 @@ Name: warp-Version: 1.3.10.2+Version: 2.0.0 Synopsis: A fast, light-weight web server for WAI applications. License: MIT License-file: LICENSE@@ -15,9 +15,11 @@ . Changelog .+ [2.0.0] ResourceT is not used anymore. Request and Response is now abstract data types. To use their constructors, Internal module should be imported.+ . [1.3.9] Support for byte range requests. .- [1.3.7] Sockets now have FD_CLOEXEC set on them. This behavior is more secure, and the change should not affect the vast majority of use cases.+ [1.3.7] Sockets now have FD_CLOEXEC set on them. This behavior is more secure, and the change should not affect the vast majority of use cases. However, it appeared that this is buggy and is fixed in 2.0.0. extra-source-files: attic/hex Flag network-bytestring@@ -29,7 +31,8 @@ Library Build-Depends: base >= 3 && < 5- , blaze-builder >= 0.2.1.4 && < 0.4+ , array+ , blaze-builder >= 0.3.3 && < 0.4 , blaze-builder-conduit >= 0.5 && < 1.1 , bytestring >= 0.9.1.4 , case-insensitive >= 0.2@@ -42,7 +45,7 @@ , transformers >= 0.2.2 && < 0.4 , unix-compat >= 0.2 , void- , wai >= 1.3 && < 1.5+ , wai >= 2.0 && < 2.1 , http-attoparsec if flag(network-bytestring) Build-Depends: network >= 2.2.1.5 && < 2.2.3@@ -50,35 +53,65 @@ else Build-Depends: network >= 2.3 Exposed-modules: Network.Wai.Handler.Warp+ Network.Wai.Handler.Warp.Buffer+ Network.Wai.Handler.Warp.Timeout Other-modules: Network.Wai.Handler.Warp.Conduit+ Network.Wai.Handler.Warp.Date+ Network.Wai.Handler.Warp.FdCache+ Network.Wai.Handler.Warp.Header+ Network.Wai.Handler.Warp.IORef Network.Wai.Handler.Warp.ReadInt+ Network.Wai.Handler.Warp.Recv Network.Wai.Handler.Warp.Request+ Network.Wai.Handler.Warp.RequestHeader Network.Wai.Handler.Warp.Response Network.Wai.Handler.Warp.ResponseHeader Network.Wai.Handler.Warp.Run+ Network.Wai.Handler.Warp.SendFile Network.Wai.Handler.Warp.Settings- Network.Wai.Handler.Warp.Timeout+ Network.Wai.Handler.Warp.Thread Network.Wai.Handler.Warp.Types Paths_warp Ghc-Options: -Wall if (os(linux) || os(freebsd) || os(darwin)) && flag(allow-sendfilefd) Cpp-Options: -DSENDFILEFD Build-Depends: hashable- Other-modules: Network.Wai.Handler.Warp.FdCache- Network.Wai.Handler.Warp.MultiMap+ Other-modules: Network.Wai.Handler.Warp.MultiMap if os(windows) Cpp-Options: -DWINDOWS+ Build-Depends: time+ , old-locale else Build-Depends: unix+ , http-date +Test-Suite doctest+ Type: exitcode-stdio-1.0+ HS-Source-Dirs: test+ Ghc-Options: -threaded -Wall+ Main-Is: doctests.hs+ Build-Depends: base+ , doctest >= 0.9.3+ Test-Suite spec Main-Is: Spec.hs+ Other-modules: ConduitSpec+ ExceptionSpec+ FdCacheSpec+ MultiMapSpec+ ReadIntSpec+ RequestSpec+ ResponseHeaderSpec+ ResponseSpec+ RunSpec+ ThreadSpec Hs-Source-Dirs: test, . Type: exitcode-stdio-1.0 Ghc-Options: -Wall Build-Depends: base >= 4 && < 5- , blaze-builder >= 0.2.1.4 && < 0.4+ , array+ , blaze-builder >= 0.3.3 && < 0.4 , blaze-builder-conduit >= 0.5 , bytestring >= 0.9.1.4 , case-insensitive >= 0.2@@ -92,12 +125,14 @@ , transformers >= 0.2.2 && < 0.4 , unix-compat >= 0.2 , void- , wai+ , wai >= 2.0 && < 2.1 , http-attoparsec , network , HUnit , QuickCheck- , hspec >= 1.3+ , hspec >= 1.3+ , time+ , old-locale -- Yes, this means that the test suite will no longer work on Windows. -- Unfortunately there is a bug in older versions of cabal, and this conditional@@ -105,9 +140,20 @@ --if (os(linux) || os(freebsd) || os(darwin)) && flag(allow-sendfilefd) Cpp-Options: -DSENDFILEFD Build-Depends: unix- , hashable+ , hashable+ , http-date --if os(windows) -- Cpp-Options: -DWINDOWS++Benchmark parser+ Type: exitcode-stdio-1.0+ Main-Is: Parser.hs+ HS-Source-Dirs: bench .+ Build-Depends: base+ , bytestring+ , criterion+ , http-types+ , network Source-Repository head Type: git