warp 1.3.3.2 → 1.3.3.3
raw patch · 16 files changed
+1742/−1740 lines, 16 filessetup-changed
Files
- LICENSE +20/−20
- Network/Wai/Handler/Warp.hs +71/−71
- Network/Wai/Handler/Warp/Conduit.hs +160/−160
- Network/Wai/Handler/Warp/FdCache.hs +120/−120
- Network/Wai/Handler/Warp/MultiMap.hs +236/−236
- Network/Wai/Handler/Warp/ReadInt.hs +67/−67
- Network/Wai/Handler/Warp/Request.hs +214/−214
- Network/Wai/Handler/Warp/Response.hs +215/−215
- Network/Wai/Handler/Warp/ResponseHeader.hs +94/−94
- Network/Wai/Handler/Warp/Run.hs +215/−213
- Network/Wai/Handler/Warp/Settings.hs +60/−60
- Network/Wai/Handler/Warp/Timeout.hs +80/−80
- Network/Wai/Handler/Warp/Types.hs +88/−88
- Setup.lhs +7/−7
- test/Spec.hs +1/−1
- warp.cabal +94/−94
LICENSE view
@@ -1,20 +1,20 @@-Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/--Permission is hereby granted, free of charge, to any person obtaining-a copy of this software and associated documentation files (the-"Software"), to deal in the Software without restriction, including-without limitation the rights to use, copy, modify, merge, publish,-distribute, sublicense, and/or sell copies of the Software, and to-permit persons to whom the Software is furnished to do so, subject to-the following conditions:--The above copyright notice and this permission notice shall be-included in all copies or substantial portions of the Software.--THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,-EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF-MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND-NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE-LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION-OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION-WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.+Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/ + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
Network/Wai/Handler/Warp.hs view
@@ -1,71 +1,71 @@-{-# LANGUAGE CPP #-}----------------------------------------------------------------- Module : Network.Wai.Handler.Warp--- Copyright : Michael Snoyman--- License : BSD3------ Maintainer : Michael Snoyman <michael@snoyman.com>--- Stability : Stable--- Portability : portable------ A fast, light-weight HTTP server handler for WAI.----------------------------------------------------------------- | A fast, light-weight HTTP server handler for WAI.-module Network.Wai.Handler.Warp (- -- * Run a Warp server- run- , runSettings- , runSettingsSocket- -- * Settings- , Settings- , defaultSettings- , settingsPort- , settingsHost- , settingsOnException- , settingsOnOpen- , settingsOnClose- , settingsTimeout- , settingsIntercept- , settingsManager- , settingsFdCacheDuration- , settingsResourceTPerRequest- -- ** Data types- , HostPreference (..)- -- * Connection- , Connection (..)- , runSettingsConnection- -- * Datatypes- , Port- , InvalidRequest (..)- -- * Internal (Manager)- , Manager- , Handle- , initialize- , withManager- , register- , registerKillThread- , pause- , resume- , cancel- -- * Internal- , parseRequest- , sendResponse- , socketConnection-#if TEST- , takeHeaders- , parseFirst- , readInt-#endif- ) where--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(..))+{-# LANGUAGE CPP #-} + +--------------------------------------------------------- +-- +-- Module : Network.Wai.Handler.Warp +-- Copyright : Michael Snoyman +-- License : BSD3 +-- +-- Maintainer : Michael Snoyman <michael@snoyman.com> +-- Stability : Stable +-- Portability : portable +-- +-- A fast, light-weight HTTP server handler for WAI. +-- +--------------------------------------------------------- + +-- | A fast, light-weight HTTP server handler for WAI. +module Network.Wai.Handler.Warp ( + -- * Run a Warp server + run + , runSettings + , runSettingsSocket + -- * Settings + , Settings + , defaultSettings + , settingsPort + , settingsHost + , settingsOnException + , settingsOnOpen + , settingsOnClose + , settingsTimeout + , settingsIntercept + , settingsManager + , settingsFdCacheDuration + , settingsResourceTPerRequest + -- ** Data types + , HostPreference (..) + -- * Connection + , Connection (..) + , runSettingsConnection + -- * Datatypes + , Port + , InvalidRequest (..) + -- * Internal (Manager) + , Manager + , Handle + , initialize + , withManager + , register + , registerKillThread + , pause + , resume + , cancel + -- * Internal + , parseRequest + , sendResponse + , socketConnection +#if TEST + , takeHeaders + , parseFirst + , readInt +#endif + ) where + +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(..))
Network/Wai/Handler/Warp/Conduit.hs view
@@ -1,160 +1,160 @@-module Network.Wai.Handler.Warp.Conduit where--import Control.Applicative-import Control.Exception-import Control.Monad (unless)-import Control.Monad.IO.Class (MonadIO, liftIO)-import Control.Monad.Trans.Class (lift)-import Data.ByteString (ByteString)-import Data.ByteString.Lazy.Char8 (pack)-import qualified Data.ByteString as S-import qualified Data.ByteString.Lazy as L-import Data.Conduit-import qualified Data.Conduit.Binary as CB-import Data.Conduit.Internal (ResumableSource (..))-import qualified Data.Conduit.List as CL-import qualified Data.IORef as I-import Data.Word (Word, Word8)-import Network.Wai.Handler.Warp.Types---------------------------------------------------------------------- | Contains a @Source@ and a byte count that is still to be read in.-newtype IsolatedBSSource = IsolatedBSSource (I.IORef (Int, ResumableSource (ResourceT 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 ibs@(IsolatedBSSource ref) = do- (count, src) <- liftIO $ I.readIORef ref- unless (count == 0) $ do- -- Get the next chunk (if available) and the updated source- (src', mbs) <- lift $ src $$++ CL.head-- -- If no chunk available, then there aren't enough bytes in the- -- stream. Throw a ConnectionClosedByPeer- bs <- maybe (liftIO $ throwIO ConnectionClosedByPeer) return mbs-- let -- How many of the bytes in this chunk to send downstream- toSend = min count (S.length bs)- -- How many bytes will still remain to be sent downstream- count' = count - toSend- case () of- ()- -- The expected count is greater than the size of the- -- chunk we just read. Send the entire chunk- -- downstream, and then loop on this function for the- -- next chunk.- | count' > 0 -> do- liftIO $ I.writeIORef ref (count', src')- yield bs- ibsIsolate ibs-- -- The expected count is the total size of the chunk we- -- just read. Send this chunk downstream, and then- -- terminate the stream.- | count == S.length bs -> do- liftIO $ I.writeIORef ref (count', src')- yield bs-- -- Some of the bytes in this chunk should not be sent- -- downstream. Split up the chunk into the sent and- -- not-sent parts, add the not-sent parts onto the new- -- source, and send the rest of the chunk downstream.- | otherwise -> do- let (x, y) = S.splitAt toSend bs- liftIO $ I.writeIORef ref (count', fmapResume (yield y >>) src')- yield x---- | Extract the underlying @Source@ from an @IsolatedBSSource@, which will not--- perform any more isolation.-ibsDone :: IsolatedBSSource -> IO (ResumableSource (ResourceT IO) ByteString)-ibsDone (IsolatedBSSource ref) = snd <$> I.readIORef ref--------------------------------------------------------------------data ChunkState = NeedLen- | NeedLenNewline- | HaveLen Word--bsCRLF :: L.ByteString-bsCRLF = pack "\r\n"--chunkedSource :: MonadIO m- => I.IORef (ResumableSource m ByteString, ChunkState)- -> Source m ByteString-chunkedSource ipair = do- (src, mlen) <- liftIO $ I.readIORef ipair- go src mlen- where- go' src front = do- (src', (len, bs)) <- lift $ src $$++ front getLen- let src''- | S.null bs = src'- | otherwise = fmapResume (yield bs >>) src'- go src'' $ HaveLen len-- go src NeedLen = go' src id- go src NeedLenNewline = go' src (CB.take 2 >>)- go src (HaveLen 0) = do- -- Drop the final CRLF- (src', ()) <- lift $ src $$++ do- crlf <- CB.take 2- unless (crlf == bsCRLF) $ leftover $ S.concat $ L.toChunks crlf- liftIO $ I.writeIORef ipair (src', HaveLen 0)- go src (HaveLen len) = do- (src', mbs) <- lift $ src $$++ CL.head- case mbs of- Nothing -> liftIO $ I.writeIORef ipair (src', HaveLen 0)- Just bs ->- case S.length bs `compare` fromIntegral len of- EQ -> yield' src' NeedLenNewline bs- LT -> do- let mlen = HaveLen $ len - fromIntegral (S.length bs)- yield' src' mlen bs- GT -> do- let (x, y) = S.splitAt (fromIntegral len) bs- let src'' = fmapResume (yield y >>) src'- yield' src'' NeedLenNewline x-- yield' src mlen bs = do- liftIO $ I.writeIORef ipair (src, mlen)- yield bs- go src mlen-- getLen :: Monad m => Sink ByteString m (Word, ByteString)- getLen = do- mbs <- CL.head- case mbs of- Nothing -> return (0, S.empty)- Just bs -> do- (x, y) <-- case S.breakByte 10 bs of- (x, y)- | S.null y -> do- mbs2 <- CL.head- case mbs2 of- Nothing -> return (x, y)- Just bs2 -> return $ S.breakByte 10 $ bs `S.append` bs2- | otherwise -> return (x, y)- let w =- S.foldl' (\i c -> i * 16 + fromIntegral (hexToWord c)) 0- $ S.takeWhile isHexDigit x- return (w, S.drop 1 y)-- hexToWord w- | w < 58 = w - 48- | w < 71 = w - 55- | otherwise = w - 87--isHexDigit :: Word8 -> Bool-isHexDigit w = w >= 48 && w <= 57- || w >= 65 && w <= 70- || w >= 97 && w <= 102--------------------------------------------------------------------fmapResume :: (Source m o1 -> Source m o2) -> ResumableSource m o1 -> ResumableSource m o2-fmapResume f (ResumableSource src m) = ResumableSource (f src) m+module Network.Wai.Handler.Warp.Conduit where + +import Control.Applicative +import Control.Exception +import Control.Monad (unless) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Trans.Class (lift) +import Data.ByteString (ByteString) +import Data.ByteString.Lazy.Char8 (pack) +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import Data.Conduit +import qualified Data.Conduit.Binary as CB +import Data.Conduit.Internal (ResumableSource (..)) +import qualified Data.Conduit.List as CL +import qualified Data.IORef as I +import Data.Word (Word, Word8) +import Network.Wai.Handler.Warp.Types + +---------------------------------------------------------------- + +-- | Contains a @Source@ and a byte count that is still to be read in. +newtype IsolatedBSSource = IsolatedBSSource (I.IORef (Int, ResumableSource (ResourceT 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 ibs@(IsolatedBSSource ref) = do + (count, src) <- liftIO $ I.readIORef ref + unless (count == 0) $ do + -- Get the next chunk (if available) and the updated source + (src', mbs) <- lift $ src $$++ CL.head + + -- If no chunk available, then there aren't enough bytes in the + -- stream. Throw a ConnectionClosedByPeer + bs <- maybe (liftIO $ throwIO ConnectionClosedByPeer) return mbs + + let -- How many of the bytes in this chunk to send downstream + toSend = min count (S.length bs) + -- How many bytes will still remain to be sent downstream + count' = count - toSend + case () of + () + -- The expected count is greater than the size of the + -- chunk we just read. Send the entire chunk + -- downstream, and then loop on this function for the + -- next chunk. + | count' > 0 -> do + liftIO $ I.writeIORef ref (count', src') + yield bs + ibsIsolate ibs + + -- The expected count is the total size of the chunk we + -- just read. Send this chunk downstream, and then + -- terminate the stream. + | count == S.length bs -> do + liftIO $ I.writeIORef ref (count', src') + yield bs + + -- Some of the bytes in this chunk should not be sent + -- downstream. Split up the chunk into the sent and + -- not-sent parts, add the not-sent parts onto the new + -- source, and send the rest of the chunk downstream. + | otherwise -> do + let (x, y) = S.splitAt toSend bs + liftIO $ I.writeIORef ref (count', fmapResume (yield y >>) src') + yield x + +-- | Extract the underlying @Source@ from an @IsolatedBSSource@, which will not +-- perform any more isolation. +ibsDone :: IsolatedBSSource -> IO (ResumableSource (ResourceT IO) ByteString) +ibsDone (IsolatedBSSource ref) = snd <$> I.readIORef ref + +---------------------------------------------------------------- + +data ChunkState = NeedLen + | NeedLenNewline + | HaveLen Word + +bsCRLF :: L.ByteString +bsCRLF = pack "\r\n" + +chunkedSource :: MonadIO m + => I.IORef (ResumableSource m ByteString, ChunkState) + -> Source m ByteString +chunkedSource ipair = do + (src, mlen) <- liftIO $ I.readIORef ipair + go src mlen + where + go' src front = do + (src', (len, bs)) <- lift $ src $$++ front getLen + let src'' + | S.null bs = src' + | otherwise = fmapResume (yield bs >>) src' + go src'' $ HaveLen len + + go src NeedLen = go' src id + go src NeedLenNewline = go' src (CB.take 2 >>) + go src (HaveLen 0) = do + -- Drop the final CRLF + (src', ()) <- lift $ src $$++ do + crlf <- CB.take 2 + unless (crlf == bsCRLF) $ leftover $ S.concat $ L.toChunks crlf + liftIO $ I.writeIORef ipair (src', HaveLen 0) + go src (HaveLen len) = do + (src', mbs) <- lift $ src $$++ CL.head + case mbs of + Nothing -> liftIO $ I.writeIORef ipair (src', HaveLen 0) + Just bs -> + case S.length bs `compare` fromIntegral len of + EQ -> yield' src' NeedLenNewline bs + LT -> do + let mlen = HaveLen $ len - fromIntegral (S.length bs) + yield' src' mlen bs + GT -> do + let (x, y) = S.splitAt (fromIntegral len) bs + let src'' = fmapResume (yield y >>) src' + yield' src'' NeedLenNewline x + + yield' src mlen bs = do + liftIO $ I.writeIORef ipair (src, mlen) + yield bs + go src mlen + + getLen :: Monad m => Sink ByteString m (Word, ByteString) + getLen = do + mbs <- CL.head + case mbs of + Nothing -> return (0, S.empty) + Just bs -> do + (x, y) <- + case S.breakByte 10 bs of + (x, y) + | S.null y -> do + mbs2 <- CL.head + case mbs2 of + Nothing -> return (x, y) + Just bs2 -> return $ S.breakByte 10 $ bs `S.append` bs2 + | otherwise -> return (x, y) + let w = + S.foldl' (\i c -> i * 16 + fromIntegral (hexToWord c)) 0 + $ S.takeWhile isHexDigit x + return (w, S.drop 1 y) + + hexToWord w + | w < 58 = w - 48 + | w < 71 = w - 55 + | otherwise = w - 87 + +isHexDigit :: Word8 -> Bool +isHexDigit w = w >= 48 && w <= 57 + || w >= 65 && w <= 70 + || w >= 97 && w <= 102 + +---------------------------------------------------------------- + +fmapResume :: (Source m o1 -> Source m o2) -> ResumableSource m o1 -> ResumableSource m o2 +fmapResume f (ResumableSource src m) = ResumableSource (f src) m
Network/Wai/Handler/Warp/FdCache.hs view
@@ -1,120 +1,120 @@-{-# LANGUAGE BangPatterns, FlexibleInstances #-}--module Network.Wai.Handler.Warp.FdCache (- initialize- , getFd- , MutableFdCache- ) where--import Control.Applicative ((<$>), (<*>))-import Control.Concurrent-import Control.Monad-import Data.Hashable-import Data.IORef-import Network.Wai.Handler.Warp.MultiMap-import System.Posix.IO-import System.Posix.Types--------------------------------------------------------------------data Status = Active | Inactive--newtype MutableStatus = MutableStatus (IORef Status)--type Refresh = IO ()--status :: MutableStatus -> IO Status-status (MutableStatus ref) = readIORef ref--newActiveStatus :: IO MutableStatus-newActiveStatus = MutableStatus <$> newIORef Active--refresh :: MutableStatus -> Refresh-refresh (MutableStatus ref) = writeIORef ref Active--inactive :: MutableStatus -> IO ()-inactive (MutableStatus ref) = writeIORef ref Inactive--------------------------------------------------------------------data FdEntry = FdEntry !FilePath !Fd !MutableStatus--newFdEntry :: FilePath -> IO FdEntry-newFdEntry path = FdEntry path- <$> openFd path ReadOnly Nothing defaultFileFlags- <*> newActiveStatus--------------------------------------------------------------------type Hash = Int-type FdCache = MMap Hash FdEntry-newtype MutableFdCache = MutableFdCache (IORef FdCache)--newMutableFdCache :: IO MutableFdCache-newMutableFdCache = MutableFdCache <$> newIORef empty--fdCache :: MutableFdCache -> IO FdCache-fdCache (MutableFdCache ref) = readIORef ref--swapWithNew :: MutableFdCache -> IO FdCache-swapWithNew (MutableFdCache 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 ()--look :: MutableFdCache -> FilePath -> Hash -> IO (Maybe FdEntry)-look mfc path key = searchWith key check <$> fdCache mfc- where- check (One ent@(FdEntry path' _ _))- | path == path' = Just ent- | otherwise = Nothing- check (Tom ent@(FdEntry path' _ _) vs)- | path == path' = Just ent- | otherwise = check vs--------------------------------------------------------------------initialize :: Int -> IO MutableFdCache-initialize duration = do- mfc <- newMutableFdCache- void . forkIO $ loop mfc- return mfc- where- loop mfc = do- old <- swapWithNew mfc- new <- pruneWith old prune- update mfc (merge new)- threadDelay duration- loop mfc--prune :: t -> Some FdEntry -> IO [(t, Some FdEntry)]-prune k v@(One (FdEntry _ fd mst)) = status mst >>= prune'- where- prune' Active = inactive mst >> return [(k,v)]- prune' Inactive = closeFd fd >> return []-prune k (Tom ent@(FdEntry _ fd mst) vs) = status mst >>= prune'- where- prune' Active = do- inactive mst- zs <- prune k vs- case zs of- [] -> return [(k,One ent)]- [(_,zvs)] -> return [(k,Tom ent zvs)]- _ -> error "prune"- prune' Inactive = closeFd fd >> prune k vs--------------------------------------------------------------------getFd :: MutableFdCache -> FilePath -> IO (Fd, Refresh)-getFd mfc path = look mfc path key >>= getFd'- where- key = hash path- getFd' Nothing = do- ent@(FdEntry _ fd mst) <- newFdEntry path- update mfc (insert key ent)- return $ (fd, refresh mst)- getFd' (Just (FdEntry _ fd mst)) = do- refresh mst- return $ (fd, refresh mst)+{-# LANGUAGE BangPatterns, FlexibleInstances #-} + +module Network.Wai.Handler.Warp.FdCache ( + initialize + , getFd + , MutableFdCache + ) where + +import Control.Applicative ((<$>), (<*>)) +import Control.Concurrent +import Control.Monad +import Data.Hashable +import Data.IORef +import Network.Wai.Handler.Warp.MultiMap +import System.Posix.IO +import System.Posix.Types + +---------------------------------------------------------------- + +data Status = Active | Inactive + +newtype MutableStatus = MutableStatus (IORef Status) + +type Refresh = IO () + +status :: MutableStatus -> IO Status +status (MutableStatus ref) = readIORef ref + +newActiveStatus :: IO MutableStatus +newActiveStatus = MutableStatus <$> newIORef Active + +refresh :: MutableStatus -> Refresh +refresh (MutableStatus ref) = writeIORef ref Active + +inactive :: MutableStatus -> IO () +inactive (MutableStatus ref) = writeIORef ref Inactive + +---------------------------------------------------------------- + +data FdEntry = FdEntry !FilePath !Fd !MutableStatus + +newFdEntry :: FilePath -> IO FdEntry +newFdEntry path = FdEntry path + <$> openFd path ReadOnly Nothing defaultFileFlags + <*> newActiveStatus + +---------------------------------------------------------------- + +type Hash = Int +type FdCache = MMap Hash FdEntry +newtype MutableFdCache = MutableFdCache (IORef FdCache) + +newMutableFdCache :: IO MutableFdCache +newMutableFdCache = MutableFdCache <$> newIORef empty + +fdCache :: MutableFdCache -> IO FdCache +fdCache (MutableFdCache ref) = readIORef ref + +swapWithNew :: MutableFdCache -> IO FdCache +swapWithNew (MutableFdCache 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 () + +look :: MutableFdCache -> FilePath -> Hash -> IO (Maybe FdEntry) +look mfc path key = searchWith key check <$> fdCache mfc + where + check (One ent@(FdEntry path' _ _)) + | path == path' = Just ent + | otherwise = Nothing + check (Tom ent@(FdEntry path' _ _) vs) + | path == path' = Just ent + | otherwise = check vs + +---------------------------------------------------------------- + +initialize :: Int -> IO MutableFdCache +initialize duration = do + mfc <- newMutableFdCache + void . forkIO $ loop mfc + return mfc + where + loop mfc = do + old <- swapWithNew mfc + new <- pruneWith old prune + update mfc (merge new) + threadDelay duration + loop mfc + +prune :: t -> Some FdEntry -> IO [(t, Some FdEntry)] +prune k v@(One (FdEntry _ fd mst)) = status mst >>= prune' + where + prune' Active = inactive mst >> return [(k,v)] + prune' Inactive = closeFd fd >> return [] +prune k (Tom ent@(FdEntry _ fd mst) vs) = status mst >>= prune' + where + prune' Active = do + inactive mst + zs <- prune k vs + case zs of + [] -> return [(k,One ent)] + [(_,zvs)] -> return [(k,Tom ent zvs)] + _ -> error "prune" + prune' Inactive = closeFd fd >> prune k vs + +---------------------------------------------------------------- + +getFd :: MutableFdCache -> FilePath -> IO (Fd, Refresh) +getFd mfc path = look mfc path key >>= getFd' + where + key = hash path + getFd' Nothing = do + ent@(FdEntry _ fd mst) <- newFdEntry path + update mfc (insert key ent) + return $ (fd, refresh mst) + getFd' (Just (FdEntry _ fd mst)) = do + refresh mst + return $ (fd, refresh mst)
Network/Wai/Handler/Warp/MultiMap.hs view
@@ -1,236 +1,236 @@-module Network.Wai.Handler.Warp.MultiMap (- MMap- , Some(..)- , empty- , singleton- , insert- , search- , searchWith- , isEmpty- , valid- , pruneWith- , fromList- , toList- , fromSortedList- , toSortedList- , merge- ) where--import Control.Applicative ((<$>))-import Data.List (foldl')---------------------------------------------------------------------- | One ore more list to implement multimap.-data Some a = One !a- | Tom !a !(Some a) -- Two or more- deriving (Eq,Show)---- This is slow but assuming rarely used.-snoc :: Some a -> a -> Some a-snoc (One x) y = Tom x (One y)-snoc (Tom x xs) y = Tom x (snoc xs y)--top :: Some a -> a-top (One x) = x-top (Tom x _) = x---------------------------------------------------------------------- | Red black tree as multimap.-data MMap k v = Leaf -- color is Black- | Node Color !(MMap k v) !k !(Some v) !(MMap k v)- deriving (Show)--data Color = B -- ^ Black- | R -- ^ Red- deriving (Eq, Show)--------------------------------------------------------------------instance (Eq k, Eq v) => Eq (MMap k v) where- t1 == t2 = toSortedList t1 == toSortedList t2---------------------------------------------------------------------- | O(log N)-search :: Ord k => k -> MMap k v -> Maybe v-search _ Leaf = Nothing-search xk (Node _ l k v r) = case compare xk k of- LT -> search xk l- GT -> search xk r- EQ -> Just $ top v---- | O(log N)-searchWith :: Ord k => k -> (Some v -> Maybe v) -> MMap k v -> Maybe v-searchWith _ _ Leaf = Nothing-searchWith xk f (Node _ l k v r) = case compare xk k of- LT -> searchWith xk f l- GT -> searchWith xk f r- EQ -> f v---------------------------------------------------------------------- | O(1)-isEmpty :: (Eq k, Eq v) => MMap k v -> Bool-isEmpty Leaf = True-isEmpty _ = False---- | O(1)-empty :: MMap k v-empty = Leaf---------------------------------------------------------------------- | O(1)-singleton :: Ord k => k -> v -> MMap k v-singleton k v = Node B Leaf k (One v) Leaf---------------------------------------------------------------------- | O(log N)-insert :: Ord k => k -> v -> MMap k v -> MMap k v-insert kx kv t = turnB (insert' kx kv t)--insert' :: Ord k => k -> v -> MMap k v -> MMap k v-insert' xk xv Leaf = Node R Leaf xk (One xv) Leaf-insert' xk xv (Node B l k v r) = case compare xk k of- LT -> balanceL' (insert' xk xv l) k v r- GT -> balanceR' l k v (insert' xk xv r)- EQ -> Node B l k (snoc v xv) r-insert' xk xv (Node R l k v r) = case compare xk k of- LT -> Node R (insert' xk xv l) k v r- GT -> Node R l k v (insert' xk xv r)- EQ -> Node R l k (snoc v xv) r--balanceL' :: MMap k v -> k -> Some v -> MMap k v -> MMap k v-balanceL' (Node R (Node R a xk xv b) yk yv c) zk zv d =- Node R (Node B a xk xv b) yk yv (Node B c zk zv d)-balanceL' (Node R a xk xv (Node R b yk yv c)) zk zv d =- Node R (Node B a xk xv b) yk yv (Node B c zk zv d)-balanceL' l k v r = Node B l k v r--balanceR' :: MMap k v -> k -> Some v -> MMap k v -> MMap k v-balanceR' a xk xv (Node R b yk yv (Node R c zk zv d)) =- Node R (Node B a xk xv b) yk yv (Node B c zk zv d)-balanceR' a xk xv (Node R (Node R b yk yv c) zk zv d) =- Node R (Node B a xk xv b) yk yv (Node B c zk zv d)-balanceR' l xk xv r = Node B l xk xv r--turnB :: MMap k v -> MMap k v-turnB Leaf = error "turnB"-turnB (Node _ l k v r) = Node B l k v r---------------------------------------------------------------------- | O(N log N)-fromList :: Ord k => [(k,v)] -> MMap k v-fromList = foldl' (\t (k,v) -> insert k v t) empty---- | O(N)-toList :: MMap k v -> [(k,v)]-toList t = inorder t []- where- inorder Leaf xs = xs- inorder (Node _ l k v r) xs = inorder l (pairs k v ++ inorder r xs)- pairs k (One v) = [(k,v)]- pairs k (Tom v vs) = (k,v) : pairs k vs---------------------------------------------------------------------- | O(N)--- "Constructing Red-Black Trees" by Ralf Hinze-fromSortedList :: Ord k => [(k,Some v)] -> MMap k v-fromSortedList = linkAll . foldr add []--data Digit k v = Uno k (Some v) (MMap k v)- | Due k (Some v) (MMap k v) k (Some v) (MMap k v)- deriving (Eq,Show)--incr :: Digit k v -> [Digit k v] -> [Digit k v]-incr (Uno k v t) [] = [Uno k v t]-incr (Uno k1 v1 t1) (Uno k2 v2 t2 : ps) = Due k1 v1 t1 k2 v2 t2 : ps-incr (Uno k1 v1 t1) (Due k2 v2 t2 k3 v3 t3 : ps) = Uno k1 v1 t1 : incr (Uno k2 v2 (Node B t2 k3 v3 t3)) ps-incr _ _ = error "incr"--add :: (k,Some v) -> [Digit k v] -> [Digit k v]-add (k,v) ps = incr (Uno k v Leaf) ps--linkAll :: [Digit k v] -> MMap k v-linkAll = foldl' link Leaf--link :: MMap k v -> Digit k v -> MMap k v-link l (Uno k v t) = Node B l k v t---link l (Due k1 v1 t1 k2 v2 t2) = Node B (Node R l k1 v1 t1) k2 v2 t2-link l (Due k1 v1 t1 k2 v2 t2) = Node B l k1 v1 (Node R t1 k2 v2 t2)---------------------------------------------------------------------- | O(N)-toSortedList :: MMap k v -> [(k,Some v)]-toSortedList t = inorder t []- where- inorder Leaf xs = xs- inorder (Node _ l k v r) xs = inorder l ((k,v) : inorder r xs)---------------------------------------------------------------------- | O(N)-pruneWith :: Ord k =>- MMap k v- -> (k -> Some v -> IO [(k, Some v)])- -> IO (MMap k v)-pruneWith t run = fromSortedList <$> inorder t []- where- inorder Leaf xs = return xs- inorder (Node _ l k v r) xs = do- ys <- run k v- zs <- inorder r xs- inorder l (ys ++ zs)---------------------------------------------------------------------- O(N log N) where N is the size of the second argument-merge :: Ord k => MMap k v -> MMap k v -> MMap k v-merge base m = foldl' ins base xs- where- ins t (k,v) = insert k v t- xs = toList m--------------------------------------------------------------------- for testing--valid :: Ord k => MMap k v -> Bool-valid t = isBalanced t && isOrdered t--isBalanced :: MMap k v -> Bool-isBalanced t = isBlackSame t && isRedSeparate t--isBlackSame :: MMap k v -> Bool-isBlackSame t = all (n==) ns- where- n:ns = blacks t--blacks :: MMap k v -> [Int]-blacks = blacks' 0- where- blacks' n Leaf = [n+1]- blacks' n (Node R l _ _ r) = blacks' n l ++ blacks' n r- blacks' n (Node B l _ _ r) = blacks' n' l ++ blacks' n' r- where- n' = n + 1--isRedSeparate :: MMap k v -> Bool-isRedSeparate = reds B--reds :: Color -> MMap k v -> Bool-reds _ Leaf = True-reds R (Node R _ _ _ _) = False-reds _ (Node c l _ _ r) = reds c l && reds c r--isOrdered :: Ord k => MMap k v -> Bool-isOrdered t = ordered $ toSortedList t- where- ordered [] = True- ordered [_] = True- ordered (x:y:xys) = fst x <= fst y && ordered (y:xys)+module Network.Wai.Handler.Warp.MultiMap ( + MMap + , Some(..) + , empty + , singleton + , insert + , search + , searchWith + , isEmpty + , valid + , pruneWith + , fromList + , toList + , fromSortedList + , toSortedList + , merge + ) where + +import Control.Applicative ((<$>)) +import Data.List (foldl') + +---------------------------------------------------------------- + +-- | One ore more list to implement multimap. +data Some a = One !a + | Tom !a !(Some a) -- Two or more + deriving (Eq,Show) + +-- This is slow but assuming rarely used. +snoc :: Some a -> a -> Some a +snoc (One x) y = Tom x (One y) +snoc (Tom x xs) y = Tom x (snoc xs y) + +top :: Some a -> a +top (One x) = x +top (Tom x _) = x + +---------------------------------------------------------------- + +-- | Red black tree as multimap. +data MMap k v = Leaf -- color is Black + | Node Color !(MMap k v) !k !(Some v) !(MMap k v) + deriving (Show) + +data Color = B -- ^ Black + | R -- ^ Red + deriving (Eq, Show) + +---------------------------------------------------------------- + +instance (Eq k, Eq v) => Eq (MMap k v) where + t1 == t2 = toSortedList t1 == toSortedList t2 + +---------------------------------------------------------------- + +-- | O(log N) +search :: Ord k => k -> MMap k v -> Maybe v +search _ Leaf = Nothing +search xk (Node _ l k v r) = case compare xk k of + LT -> search xk l + GT -> search xk r + EQ -> Just $ top v + +-- | O(log N) +searchWith :: Ord k => k -> (Some v -> Maybe v) -> MMap k v -> Maybe v +searchWith _ _ Leaf = Nothing +searchWith xk f (Node _ l k v r) = case compare xk k of + LT -> searchWith xk f l + GT -> searchWith xk f r + EQ -> f v + +---------------------------------------------------------------- + +-- | O(1) +isEmpty :: (Eq k, Eq v) => MMap k v -> Bool +isEmpty Leaf = True +isEmpty _ = False + +-- | O(1) +empty :: MMap k v +empty = Leaf + +---------------------------------------------------------------- + +-- | O(1) +singleton :: Ord k => k -> v -> MMap k v +singleton k v = Node B Leaf k (One v) Leaf + +---------------------------------------------------------------- + +-- | O(log N) +insert :: Ord k => k -> v -> MMap k v -> MMap k v +insert kx kv t = turnB (insert' kx kv t) + +insert' :: Ord k => k -> v -> MMap k v -> MMap k v +insert' xk xv Leaf = Node R Leaf xk (One xv) Leaf +insert' xk xv (Node B l k v r) = case compare xk k of + LT -> balanceL' (insert' xk xv l) k v r + GT -> balanceR' l k v (insert' xk xv r) + EQ -> Node B l k (snoc v xv) r +insert' xk xv (Node R l k v r) = case compare xk k of + LT -> Node R (insert' xk xv l) k v r + GT -> Node R l k v (insert' xk xv r) + EQ -> Node R l k (snoc v xv) r + +balanceL' :: MMap k v -> k -> Some v -> MMap k v -> MMap k v +balanceL' (Node R (Node R a xk xv b) yk yv c) zk zv d = + Node R (Node B a xk xv b) yk yv (Node B c zk zv d) +balanceL' (Node R a xk xv (Node R b yk yv c)) zk zv d = + Node R (Node B a xk xv b) yk yv (Node B c zk zv d) +balanceL' l k v r = Node B l k v r + +balanceR' :: MMap k v -> k -> Some v -> MMap k v -> MMap k v +balanceR' a xk xv (Node R b yk yv (Node R c zk zv d)) = + Node R (Node B a xk xv b) yk yv (Node B c zk zv d) +balanceR' a xk xv (Node R (Node R b yk yv c) zk zv d) = + Node R (Node B a xk xv b) yk yv (Node B c zk zv d) +balanceR' l xk xv r = Node B l xk xv r + +turnB :: MMap k v -> MMap k v +turnB Leaf = error "turnB" +turnB (Node _ l k v r) = Node B l k v r + +---------------------------------------------------------------- + +-- | O(N log N) +fromList :: Ord k => [(k,v)] -> MMap k v +fromList = foldl' (\t (k,v) -> insert k v t) empty + +-- | O(N) +toList :: MMap k v -> [(k,v)] +toList t = inorder t [] + where + inorder Leaf xs = xs + inorder (Node _ l k v r) xs = inorder l (pairs k v ++ inorder r xs) + pairs k (One v) = [(k,v)] + pairs k (Tom v vs) = (k,v) : pairs k vs + +---------------------------------------------------------------- + +-- | O(N) +-- "Constructing Red-Black Trees" by Ralf Hinze +fromSortedList :: Ord k => [(k,Some v)] -> MMap k v +fromSortedList = linkAll . foldr add [] + +data Digit k v = Uno k (Some v) (MMap k v) + | Due k (Some v) (MMap k v) k (Some v) (MMap k v) + deriving (Eq,Show) + +incr :: Digit k v -> [Digit k v] -> [Digit k v] +incr (Uno k v t) [] = [Uno k v t] +incr (Uno k1 v1 t1) (Uno k2 v2 t2 : ps) = Due k1 v1 t1 k2 v2 t2 : ps +incr (Uno k1 v1 t1) (Due k2 v2 t2 k3 v3 t3 : ps) = Uno k1 v1 t1 : incr (Uno k2 v2 (Node B t2 k3 v3 t3)) ps +incr _ _ = error "incr" + +add :: (k,Some v) -> [Digit k v] -> [Digit k v] +add (k,v) ps = incr (Uno k v Leaf) ps + +linkAll :: [Digit k v] -> MMap k v +linkAll = foldl' link Leaf + +link :: MMap k v -> Digit k v -> MMap k v +link l (Uno k v t) = Node B l k v t +--link l (Due k1 v1 t1 k2 v2 t2) = Node B (Node R l k1 v1 t1) k2 v2 t2 +link l (Due k1 v1 t1 k2 v2 t2) = Node B l k1 v1 (Node R t1 k2 v2 t2) + +---------------------------------------------------------------- + +-- | O(N) +toSortedList :: MMap k v -> [(k,Some v)] +toSortedList t = inorder t [] + where + inorder Leaf xs = xs + inorder (Node _ l k v r) xs = inorder l ((k,v) : inorder r xs) + +---------------------------------------------------------------- + +-- | O(N) +pruneWith :: Ord k => + MMap k v + -> (k -> Some v -> IO [(k, Some v)]) + -> IO (MMap k v) +pruneWith t run = fromSortedList <$> inorder t [] + where + inorder Leaf xs = return xs + inorder (Node _ l k v r) xs = do + ys <- run k v + zs <- inorder r xs + inorder l (ys ++ zs) + +---------------------------------------------------------------- + +-- O(N log N) where N is the size of the second argument +merge :: Ord k => MMap k v -> MMap k v -> MMap k v +merge base m = foldl' ins base xs + where + ins t (k,v) = insert k v t + xs = toList m + +---------------------------------------------------------------- +-- for testing + +valid :: Ord k => MMap k v -> Bool +valid t = isBalanced t && isOrdered t + +isBalanced :: MMap k v -> Bool +isBalanced t = isBlackSame t && isRedSeparate t + +isBlackSame :: MMap k v -> Bool +isBlackSame t = all (n==) ns + where + n:ns = blacks t + +blacks :: MMap k v -> [Int] +blacks = blacks' 0 + where + blacks' n Leaf = [n+1] + blacks' n (Node R l _ _ r) = blacks' n l ++ blacks' n r + blacks' n (Node B l _ _ r) = blacks' n' l ++ blacks' n' r + where + n' = n + 1 + +isRedSeparate :: MMap k v -> Bool +isRedSeparate = reds B + +reds :: Color -> MMap k v -> Bool +reds _ Leaf = True +reds R (Node R _ _ _ _) = False +reds _ (Node c l _ _ r) = reds c l && reds c r + +isOrdered :: Ord k => MMap k v -> Bool +isOrdered t = ordered $ toSortedList t + where + ordered [] = True + ordered [_] = True + ordered (x:y:xys) = fst x <= fst y && ordered (y:xys)
Network/Wai/Handler/Warp/ReadInt.hs view
@@ -1,67 +1,67 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE BangPatterns #-}---- Copyright : Erik de Castro Lopo <erikd@mega-nerd.com>--- License : BSD3--module Network.Wai.Handler.Warp.ReadInt (- readInt- , readInt64- ) where---- This function lives in its own file because the MagicHash pragma interacts--- poorly with the CPP pragma.--import Data.ByteString (ByteString)-import qualified Data.ByteString as S-import Data.Int (Int64)-import GHC.Prim-import GHC.Types-import GHC.Word--{-# INLINE readInt #-}-readInt :: Integral a => ByteString -> a-readInt bs = fromIntegral $ readInt64 bs---- This function is used to parse the Content-Length field of HTTP headers and--- is a performance hot spot. It should only be replaced with something--- significantly and provably faster.------ It needs to be able work correctly on 32 bit CPUs for file sizes > 2G so we--- use Int64 here and then make a generic 'readInt' that allows conversion to--- Int and Integer.--{- NOINLINE readInt64MH #-}-readInt64 :: ByteString -> Int64-readInt64 bs = S.foldl' (\ !i !c -> i * 10 + fromIntegral (mhDigitToInt c)) 0- $ S.takeWhile isDigit bs--data Table = Table !Addr#--{- NOINLINE mhDigitToInt #-}-mhDigitToInt :: Word8 -> Int-mhDigitToInt (W8# i) = I# (word2Int# (indexWord8OffAddr# addr (word2Int# i)))- where- !(Table addr) = table- table :: Table- table = Table- "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\- \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\- \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\- \\x00\x01\x02\x03\x04\x05\x06\x07\x08\x09\x00\x00\x00\x00\x00\x00\- \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\- \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\- \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\- \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\- \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\- \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\- \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\- \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\- \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\- \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\- \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\- \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"#--isDigit :: Word8 -> Bool-isDigit w = w >= 48 && w <= 57+{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE BangPatterns #-} + +-- Copyright : Erik de Castro Lopo <erikd@mega-nerd.com> +-- License : BSD3 + +module Network.Wai.Handler.Warp.ReadInt ( + readInt + , readInt64 + ) where + +-- This function lives in its own file because the MagicHash pragma interacts +-- poorly with the CPP pragma. + +import Data.ByteString (ByteString) +import qualified Data.ByteString as S +import Data.Int (Int64) +import GHC.Prim +import GHC.Types +import GHC.Word + +{-# INLINE readInt #-} +readInt :: Integral a => ByteString -> a +readInt bs = fromIntegral $ readInt64 bs + +-- This function is used to parse the Content-Length field of HTTP headers and +-- is a performance hot spot. It should only be replaced with something +-- significantly and provably faster. +-- +-- It needs to be able work correctly on 32 bit CPUs for file sizes > 2G so we +-- use Int64 here and then make a generic 'readInt' that allows conversion to +-- Int and Integer. + +{- NOINLINE readInt64MH #-} +readInt64 :: ByteString -> Int64 +readInt64 bs = S.foldl' (\ !i !c -> i * 10 + fromIntegral (mhDigitToInt c)) 0 + $ S.takeWhile isDigit bs + +data Table = Table !Addr# + +{- NOINLINE mhDigitToInt #-} +mhDigitToInt :: Word8 -> Int +mhDigitToInt (W8# i) = I# (word2Int# (indexWord8OffAddr# addr (word2Int# i))) + where + !(Table addr) = table + table :: Table + table = Table + "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ + \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ + \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ + \\x00\x01\x02\x03\x04\x05\x06\x07\x08\x09\x00\x00\x00\x00\x00\x00\ + \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ + \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ + \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ + \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ + \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ + \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ + \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ + \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ + \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ + \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ + \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ + \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# + +isDigit :: Word8 -> Bool +isDigit w = w >= 48 && w <= 57
Network/Wai/Handler/Warp/Request.hs view
@@ -1,214 +1,214 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE OverloadedStrings #-}--module Network.Wai.Handler.Warp.Request where--import Control.Applicative-import Control.Exception.Lifted (throwIO)-import Control.Monad.IO.Class (MonadIO, liftIO)-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.Void (Void)-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.ReadInt-import Network.Wai.Handler.Warp.Types-import Prelude hiding (lines)---- 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 port remoteHost' src1 = do- (src2, headers') <- src1 $$+ takeHeaders- parseRequest' conn port headers' remoteHost' src2--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---- | Parse a set of header lines and body into a 'Request'.-parseRequest' :: Connection- -> Port- -> [ByteString]- -> SockAddr- -> ResumableSource (ResourceT IO) ByteString -- FIXME was buffered- -> ResourceT IO (Request, IO (ResumableSource (ResourceT IO) ByteString))-parseRequest' _ _ [] _ _ = throwIO $ NotEnoughLines []-parseRequest' conn 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 = rbody- , vault = mempty- }, getSource)--{-# INLINE takeUntil #-}-takeUntil :: Word8 -> ByteString -> ByteString-takeUntil c bs =- case S.elemIndex c bs of- Just !idx -> SU.unsafeTake idx bs- Nothing -> 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--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')--type BSEndo = ByteString -> ByteString-type BSEndoList = [ByteString] -> [ByteString]--data THStatus = THStatus- {-# UNPACK #-} !Int -- running total byte count- 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 = throwIO IncompleteHeaders--push :: THStatus -> ByteString -> Pipe ByteString ByteString Void () (ResourceT IO) [ByteString]-push (THStatus len lines prepend) bs- -- Too many bytes- | len > maxTotalHeaderLength = throwIO OverLargeHeader- | otherwise = push' mnl- where- bsLen = S.length bs- mnl = do- nl <- S.elemIndex 10 bs- -- check if there are two more bytes in the bs- -- if so, see if the second of those is a horizontal space- if bsLen > nl + 1 then- let c = S.index bs (nl + 1)- in Just (nl, c == 32 || c == 9)- else- Just (nl, False)-- {-# INLINE push' #-}- -- No newline find in this chunk. Add it to the prepend,- -- update the length, and continue processing.- push' Nothing = await >>= maybe close (push status)- where- len' = len + bsLen- prepend' = prepend . S.append bs- status = THStatus len' lines prepend'- -- Found a newline, but next line continues as a multiline header- push' (Just (end, True)) = push status rest- where- rest = S.drop (end + 1) bs- prepend' = prepend . S.append (SU.unsafeTake (checkCR bs end) bs)- len' = len + end- status = THStatus len' lines prepend'- -- Found a newline at position end.- push' (Just (end, False))- -- leftover- | S.null line = let lines' = lines []- rest = if start < bsLen then- Just (SU.unsafeDrop start bs)- else- Nothing- in maybe (return ()) leftover rest >> return lines'- -- more headers- | otherwise = let len' = len + start- lines' = lines . (line:)- status = THStatus len' lines' id- in if start < bsLen then- -- more bytes in this chunk, push again- let bs' = SU.unsafeDrop start bs- in push status bs'- else- -- no more bytes in this chunk, ask for more- await >>= maybe close (push status)- where- start = end + 1 -- start of next chunk- line- -- There were some bytes before the newline, get them- | end > 0 = prepend $ SU.unsafeTake (checkCR bs end) bs- -- No bytes before the newline- | otherwise = prepend S.empty--{-# INLINE checkCR #-}-checkCR :: ByteString -> Int -> Int-checkCR bs pos = if 13 == S.index bs p then p else pos -- 13 is CR- where- !p = pos - 1+{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} + +module Network.Wai.Handler.Warp.Request where + +import Control.Applicative +import Control.Exception.Lifted (throwIO) +import Control.Monad.IO.Class (MonadIO, liftIO) +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.Void (Void) +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.ReadInt +import Network.Wai.Handler.Warp.Types +import Prelude hiding (lines) + +-- 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 port remoteHost' src1 = do + (src2, headers') <- src1 $$+ takeHeaders + parseRequest' conn port headers' remoteHost' src2 + +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 + +-- | Parse a set of header lines and body into a 'Request'. +parseRequest' :: Connection + -> Port + -> [ByteString] + -> SockAddr + -> ResumableSource (ResourceT IO) ByteString -- FIXME was buffered + -> ResourceT IO (Request, IO (ResumableSource (ResourceT IO) ByteString)) +parseRequest' _ _ [] _ _ = throwIO $ NotEnoughLines [] +parseRequest' conn 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 = rbody + , vault = mempty + }, getSource) + +{-# INLINE takeUntil #-} +takeUntil :: Word8 -> ByteString -> ByteString +takeUntil c bs = + case S.elemIndex c bs of + Just !idx -> SU.unsafeTake idx bs + Nothing -> 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 + +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') + +type BSEndo = ByteString -> ByteString +type BSEndoList = [ByteString] -> [ByteString] + +data THStatus = THStatus + {-# UNPACK #-} !Int -- running total byte count + 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 = throwIO IncompleteHeaders + +push :: THStatus -> ByteString -> Pipe ByteString ByteString Void () (ResourceT IO) [ByteString] +push (THStatus len lines prepend) bs + -- Too many bytes + | len > maxTotalHeaderLength = throwIO OverLargeHeader + | otherwise = push' mnl + where + bsLen = S.length bs + mnl = do + nl <- S.elemIndex 10 bs + -- check if there are two more bytes in the bs + -- if so, see if the second of those is a horizontal space + if bsLen > nl + 1 then + let c = S.index bs (nl + 1) + in Just (nl, c == 32 || c == 9) + else + Just (nl, False) + + {-# INLINE push' #-} + -- No newline find in this chunk. Add it to the prepend, + -- update the length, and continue processing. + push' Nothing = await >>= maybe close (push status) + where + len' = len + bsLen + prepend' = prepend . S.append bs + status = THStatus len' lines prepend' + -- Found a newline, but next line continues as a multiline header + push' (Just (end, True)) = push status rest + where + rest = S.drop (end + 1) bs + prepend' = prepend . S.append (SU.unsafeTake (checkCR bs end) bs) + len' = len + end + status = THStatus len' lines prepend' + -- Found a newline at position end. + push' (Just (end, False)) + -- leftover + | S.null line = let lines' = lines [] + rest = if start < bsLen then + Just (SU.unsafeDrop start bs) + else + Nothing + in maybe (return ()) leftover rest >> return lines' + -- more headers + | otherwise = let len' = len + start + lines' = lines . (line:) + status = THStatus len' lines' id + in if start < bsLen then + -- more bytes in this chunk, push again + let bs' = SU.unsafeDrop start bs + in push status bs' + else + -- no more bytes in this chunk, ask for more + await >>= maybe close (push status) + where + start = end + 1 -- start of next chunk + line + -- There were some bytes before the newline, get them + | end > 0 = prepend $ SU.unsafeTake (checkCR bs end) bs + -- No bytes before the newline + | otherwise = prepend S.empty + +{-# INLINE checkCR #-} +checkCR :: ByteString -> Int -> Int +checkCR bs pos = if 13 == S.index bs p then p else pos -- 13 is CR + where + !p = pos - 1
Network/Wai/Handler/Warp/Response.hs view
@@ -1,215 +1,215 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}--module Network.Wai.Handler.Warp.Response (- sendResponse- ) 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 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.Maybe (isJust)-import Data.Monoid (mappend)-import qualified Network.HTTP.Types as H-import Network.Wai-import Network.Wai.Handler.Warp.ReadInt-import qualified Network.Wai.Handler.Warp.ResponseHeader as RH-import qualified Network.Wai.Handler.Warp.Timeout as T-import Network.Wai.Handler.Warp.Types-import qualified System.PosixCompat.Files as P-------------------------------------------------------------------------------------------------------------------------------------sendResponse :: Cleaner -> Request -> Connection -> Response- -> ResourceT IO Bool--------------------------------------------------------------------sendResponse cleaner req conn (ResponseFile s hs path mpart) =- headerAndLength >>= sendResponse'- where- th = threadHandle cleaner- headerAndLength = case (readInt <$> checkLength hs, mpart) of- (Just cl, _) -> return $ Right (hs, cl)- (Nothing, Nothing) -> liftIO . try $ do- cl <- fromIntegral . P.fileSize <$> P.getFileStatus path- return (addLength cl hs, cl)- (Nothing, Just part) -> do- let cl = fromIntegral $ filePartByteCount part- return $ Right (addLength cl hs, cl)-- sendResponse' (Right (lengthyHeaders, cl))- | hasBody s req = liftIO $ do- connSendFile conn path beg end (T.tickle th) [lheader] cleaner- T.tickle th- return isPersist- | otherwise = liftIO $ do- connSendAll conn $ composeHeader version s hs- T.tickle th- return isPersist -- FIXME isKeepAlive?- where- (beg,end) = case mpart of- Nothing -> (0,cl)- Just prt -> (filePartOffset prt, filePartByteCount prt)- lheader = composeHeader version s lengthyHeaders- version = httpVersion req- (isPersist,_) = infoFromRequest req-- sendResponse' (Left (_ :: SomeException)) =- sendResponse cleaner req conn notFound- where- notFound = responseLBS H.status404 [(H.hContentType, "text/plain")] "File not found"--------------------------------------------------------------------sendResponse cleaner req conn (ResponseBuilder s hs b)- | hasBody s req = liftIO $ do- flip toByteStringIO body $ \bs -> do- connSendAll conn bs- T.tickle th- return isKeepAlive- | otherwise = liftIO $ do- connSendAll conn $ composeHeader version s hs- T.tickle th- return isPersist- where- th = threadHandle cleaner- header = composeHeaderBuilder version s hs needsChunked- body- | needsChunked = header `mappend` chunkedTransferEncoding b- `mappend` chunkedTransferTerminator- | otherwise = header `mappend` b- version = httpVersion req- reqinfo@(isPersist,_) = infoFromRequest req- (isKeepAlive, needsChunked) = infoFromResponse hs reqinfo--------------------------------------------------------------------sendResponse cleaner req conn (ResponseSource s hs bodyFlush)- | hasBody s req = do- let src = CL.sourceList [header] `mappend` cbody- src $$ builderToByteString =$ connSink conn th- return isKeepAlive- | otherwise = liftIO $ do- connSendAll conn $ composeHeader version s hs- T.tickle th- return isPersist- where- th = threadHandle cleaner- header = composeHeaderBuilder version s hs needsChunked- 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- chunk = await >>= maybe (yield chunkedTransferTerminator) (\x -> yield (chunkedTransferEncoding x) >> chunk)- version = httpVersion req- reqinfo@(isPersist,_) = infoFromRequest req- (isKeepAlive, needsChunked) = infoFromResponse hs reqinfo--------------------------------------------------------------------------------------------------------------------------------------- | Use 'connSendAll' to send this data while respecting timeout rules.-connSink :: Connection -> T.Handle -> Sink ByteString (ResourceT IO) ()-connSink Connection { connSendAll = send } th =- sink- where- sink = await >>= maybe close push- close = liftIO (T.resume th)- push x = do- liftIO $ T.resume th- liftIO $ send x- liftIO $ T.pause th- sink- -- We pause timeouts before passing control back to user code. This ensures- -- that a timeout will only ever be executed when Warp is in control. We- -- also make sure to resume the timeout after the completion of user code- -- so that we can kill idle connections.--------------------------------------------------------------------infoFromRequest :: Request -> (Bool,Bool)-infoFromRequest req = (checkPersist req, checkChunk req)--checkPersist :: Request -> Bool-checkPersist req- | ver == H.http11 = checkPersist11 conn- | otherwise = checkPersist10 conn- where- ver = httpVersion req- conn = lookup H.hConnection $ requestHeaders req- checkPersist11 (Just x)- | CI.foldCase x == "close" = False- checkPersist11 _ = True- checkPersist10 (Just x)- | CI.foldCase x == "keep-alive" = True- checkPersist10 _ = False--checkChunk :: Request -> Bool-checkChunk req = httpVersion req == H.http11--------------------------------------------------------------------infoFromResponse :: H.ResponseHeaders -> (Bool,Bool) -> (Bool,Bool)-infoFromResponse hs (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--------------------------------------------------------------------hasBody :: H.Status -> Request -> Bool-hasBody s req = sc /= 204- && sc /= 304- && sc >= 200- && method /= H.methodHead- where- sc = H.statusCode s- method = requestMethod req--------------------------------------------------------------------addLength :: Integer -> H.ResponseHeaders -> H.ResponseHeaders-addLength cl hdrs = (H.hContentLength, B.pack $ show cl) : hdrs--addEncodingHeader :: H.ResponseHeaders -> H.ResponseHeaders-addEncodingHeader hdrs = (hTransferEncoding, "chunked") : hdrs--addServerHeader :: H.ResponseHeaders -> H.ResponseHeaders-addServerHeader hdrs = case lookup hServer hdrs of- Nothing -> warpVersionHeader : hdrs- Just _ -> hdrs--warpVersionHeader :: H.Header-warpVersionHeader = (hServer, ver)- where- ver = B.pack $ "Warp/" ++ warpVersion--------------------------------------------------------------------composeHeader :: H.HttpVersion -> H.Status -> H.ResponseHeaders -> ByteString-composeHeader version s hs = RH.composeHeader version s (addServerHeader hs)--composeHeaderBuilder :: H.HttpVersion -> H.Status -> H.ResponseHeaders -> Bool -> Builder-composeHeaderBuilder ver s hs True =- fromByteString $ composeHeader ver s (addEncodingHeader hs)-composeHeaderBuilder ver s hs False =- fromByteString $ composeHeader ver s hs+{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} + +module Network.Wai.Handler.Warp.Response ( + sendResponse + ) 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 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.Maybe (isJust) +import Data.Monoid (mappend) +import qualified Network.HTTP.Types as H +import Network.Wai +import Network.Wai.Handler.Warp.ReadInt +import qualified Network.Wai.Handler.Warp.ResponseHeader as RH +import qualified Network.Wai.Handler.Warp.Timeout as T +import Network.Wai.Handler.Warp.Types +import qualified System.PosixCompat.Files as P + +---------------------------------------------------------------- +---------------------------------------------------------------- + +sendResponse :: Cleaner -> Request -> Connection -> Response + -> ResourceT IO Bool + +---------------------------------------------------------------- + +sendResponse cleaner req conn (ResponseFile s hs path mpart) = + headerAndLength >>= sendResponse' + where + th = threadHandle cleaner + headerAndLength = case (readInt <$> checkLength hs, mpart) of + (Just cl, _) -> return $ Right (hs, cl) + (Nothing, Nothing) -> liftIO . try $ do + cl <- fromIntegral . P.fileSize <$> P.getFileStatus path + return (addLength cl hs, cl) + (Nothing, Just part) -> do + let cl = fromIntegral $ filePartByteCount part + return $ Right (addLength cl hs, cl) + + sendResponse' (Right (lengthyHeaders, cl)) + | hasBody s req = liftIO $ do + connSendFile conn path beg end (T.tickle th) [lheader] cleaner + T.tickle th + return isPersist + | otherwise = liftIO $ do + connSendAll conn $ composeHeader version s hs + T.tickle th + return isPersist -- FIXME isKeepAlive? + where + (beg,end) = case mpart of + Nothing -> (0,cl) + Just prt -> (filePartOffset prt, filePartByteCount prt) + lheader = composeHeader version s lengthyHeaders + version = httpVersion req + (isPersist,_) = infoFromRequest req + + sendResponse' (Left (_ :: SomeException)) = + sendResponse cleaner req conn notFound + where + notFound = responseLBS H.status404 [(H.hContentType, "text/plain")] "File not found" + +---------------------------------------------------------------- + +sendResponse cleaner req conn (ResponseBuilder s hs b) + | hasBody s req = liftIO $ do + flip toByteStringIO body $ \bs -> do + connSendAll conn bs + T.tickle th + return isKeepAlive + | otherwise = liftIO $ do + connSendAll conn $ composeHeader version s hs + T.tickle th + return isPersist + where + th = threadHandle cleaner + header = composeHeaderBuilder version s hs needsChunked + body + | needsChunked = header `mappend` chunkedTransferEncoding b + `mappend` chunkedTransferTerminator + | otherwise = header `mappend` b + version = httpVersion req + reqinfo@(isPersist,_) = infoFromRequest req + (isKeepAlive, needsChunked) = infoFromResponse hs reqinfo + +---------------------------------------------------------------- + +sendResponse cleaner req conn (ResponseSource s hs bodyFlush) + | hasBody s req = do + let src = CL.sourceList [header] `mappend` cbody + src $$ builderToByteString =$ connSink conn th + return isKeepAlive + | otherwise = liftIO $ do + connSendAll conn $ composeHeader version s hs + T.tickle th + return isPersist + where + th = threadHandle cleaner + header = composeHeaderBuilder version s hs needsChunked + 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 + chunk = await >>= maybe (yield chunkedTransferTerminator) (\x -> yield (chunkedTransferEncoding x) >> chunk) + version = httpVersion req + reqinfo@(isPersist,_) = infoFromRequest req + (isKeepAlive, needsChunked) = infoFromResponse hs reqinfo + +---------------------------------------------------------------- +---------------------------------------------------------------- + +-- | Use 'connSendAll' to send this data while respecting timeout rules. +connSink :: Connection -> T.Handle -> Sink ByteString (ResourceT IO) () +connSink Connection { connSendAll = send } th = + sink + where + sink = await >>= maybe close push + close = liftIO (T.resume th) + push x = do + liftIO $ T.resume th + liftIO $ send x + liftIO $ T.pause th + sink + -- We pause timeouts before passing control back to user code. This ensures + -- that a timeout will only ever be executed when Warp is in control. We + -- also make sure to resume the timeout after the completion of user code + -- so that we can kill idle connections. + +---------------------------------------------------------------- + +infoFromRequest :: Request -> (Bool,Bool) +infoFromRequest req = (checkPersist req, checkChunk req) + +checkPersist :: Request -> Bool +checkPersist req + | ver == H.http11 = checkPersist11 conn + | otherwise = checkPersist10 conn + where + ver = httpVersion req + conn = lookup H.hConnection $ requestHeaders req + checkPersist11 (Just x) + | CI.foldCase x == "close" = False + checkPersist11 _ = True + checkPersist10 (Just x) + | CI.foldCase x == "keep-alive" = True + checkPersist10 _ = False + +checkChunk :: Request -> Bool +checkChunk req = httpVersion req == H.http11 + +---------------------------------------------------------------- + +infoFromResponse :: H.ResponseHeaders -> (Bool,Bool) -> (Bool,Bool) +infoFromResponse hs (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 + +---------------------------------------------------------------- + +hasBody :: H.Status -> Request -> Bool +hasBody s req = sc /= 204 + && sc /= 304 + && sc >= 200 + && method /= H.methodHead + where + sc = H.statusCode s + method = requestMethod req + +---------------------------------------------------------------- + +addLength :: Integer -> H.ResponseHeaders -> H.ResponseHeaders +addLength cl hdrs = (H.hContentLength, B.pack $ show cl) : hdrs + +addEncodingHeader :: H.ResponseHeaders -> H.ResponseHeaders +addEncodingHeader hdrs = (hTransferEncoding, "chunked") : hdrs + +addServerHeader :: H.ResponseHeaders -> H.ResponseHeaders +addServerHeader hdrs = case lookup hServer hdrs of + Nothing -> warpVersionHeader : hdrs + Just _ -> hdrs + +warpVersionHeader :: H.Header +warpVersionHeader = (hServer, ver) + where + ver = B.pack $ "Warp/" ++ warpVersion + +---------------------------------------------------------------- + +composeHeader :: H.HttpVersion -> H.Status -> H.ResponseHeaders -> ByteString +composeHeader version s hs = RH.composeHeader version s (addServerHeader hs) + +composeHeaderBuilder :: H.HttpVersion -> H.Status -> H.ResponseHeaders -> Bool -> Builder +composeHeaderBuilder ver s hs True = + fromByteString $ composeHeader ver s (addEncodingHeader hs) +composeHeaderBuilder ver s hs False = + fromByteString $ composeHeader ver s hs
Network/Wai/Handler/Warp/ResponseHeader.hs view
@@ -1,94 +1,94 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE BangPatterns #-}--module Network.Wai.Handler.Warp.ResponseHeader (composeHeader) where--import Control.Monad-import Data.ByteString (ByteString)-import qualified Data.ByteString as S-import Data.ByteString.Internal (ByteString(..), unsafeCreate, memcpy)-import qualified Data.CaseInsensitive as CI-import Data.List (foldl')-import Data.Word (Word8)-import Foreign.ForeignPtr-import Foreign.Ptr-import GHC.Storable-import qualified Network.HTTP.Types as H--------------------------------------------------------------------composeHeader :: H.HttpVersion -> H.Status -> H.ResponseHeaders -> ByteString-composeHeader !httpversion !status !responseHeaders = unsafeCreate len $ \ptr -> do- ptr1 <- copyStatus ptr httpversion status- ptr2 <- copyHeaders ptr1 responseHeaders- void $ copyCRLF ptr2- where- !len = 17 + slen + foldl' fieldLength 0 responseHeaders- fieldLength !l !(k,v) = l + S.length (CI.original k) + S.length v + 4- !slen = S.length $ H.statusMessage status--{-# INLINE copy #-}-copy :: Ptr Word8 -> ByteString -> IO (Ptr Word8)-copy !ptr !(PS fp o l) = withForeignPtr fp $ \p -> do- memcpy ptr (p `plusPtr` o) (fromIntegral l)- return $! ptr `plusPtr` l--httpVer11 :: ByteString-httpVer11 = "HTTP/1.1 "--httpVer10 :: ByteString-httpVer10 = "HTTP/1.0 "--{-# INLINE copyStatus #-}-copyStatus :: Ptr Word8 -> H.HttpVersion -> H.Status -> IO (Ptr Word8)-copyStatus !ptr !httpversion !status = do- ptr1 <- copy ptr httpVer- writeWord8OffPtr ptr1 0 (zero + fromIntegral r2)- writeWord8OffPtr ptr1 1 (zero + fromIntegral r1)- writeWord8OffPtr ptr1 2 (zero + fromIntegral r0)- writeWord8OffPtr ptr1 3 spc- ptr2 <- copy (ptr1 `plusPtr` 4) (H.statusMessage status)- copyCRLF ptr2- where- httpVer- | httpversion == H.HttpVersion 1 1 = httpVer11- | otherwise = httpVer10- (q0,r0) = H.statusCode status `divMod` 10- (q1,r1) = q0 `divMod` 10- r2 = q1 `mod` 10--{-# INLINE copyHeaders #-}-copyHeaders :: Ptr Word8 -> [H.Header] -> IO (Ptr Word8)-copyHeaders !ptr [] = return ptr-copyHeaders !ptr (h:hs) = do- ptr1 <- copyHeader ptr h- copyHeaders ptr1 hs--{-# INLINE copyHeader #-}-copyHeader :: Ptr Word8 -> H.Header -> IO (Ptr Word8)-copyHeader !ptr (k,v) = do- ptr1 <- copy ptr (CI.original k)- writeWord8OffPtr ptr1 0 colon- writeWord8OffPtr ptr1 1 spc- ptr2 <- copy (ptr1 `plusPtr` 2) v- copyCRLF ptr2--{-# INLINE copyCRLF #-}-copyCRLF :: Ptr Word8 -> IO (Ptr Word8)-copyCRLF !ptr = do- writeWord8OffPtr ptr 0 cr- writeWord8OffPtr ptr 1 lf- return $! ptr `plusPtr` 2--zero :: Word8-zero = 48-spc :: Word8-spc = 32-colon :: Word8-colon = 58-cr :: Word8-cr = 13-lf :: Word8-lf = 10--+{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} + +module Network.Wai.Handler.Warp.ResponseHeader (composeHeader) where + +import Control.Monad +import Data.ByteString (ByteString) +import qualified Data.ByteString as S +import Data.ByteString.Internal (ByteString(..), unsafeCreate, memcpy) +import qualified Data.CaseInsensitive as CI +import Data.List (foldl') +import Data.Word (Word8) +import Foreign.ForeignPtr +import Foreign.Ptr +import GHC.Storable +import qualified Network.HTTP.Types as H + +---------------------------------------------------------------- + +composeHeader :: H.HttpVersion -> H.Status -> H.ResponseHeaders -> ByteString +composeHeader !httpversion !status !responseHeaders = unsafeCreate len $ \ptr -> do + ptr1 <- copyStatus ptr httpversion status + ptr2 <- copyHeaders ptr1 responseHeaders + void $ copyCRLF ptr2 + where + !len = 17 + slen + foldl' fieldLength 0 responseHeaders + fieldLength !l !(k,v) = l + S.length (CI.original k) + S.length v + 4 + !slen = S.length $ H.statusMessage status + +{-# INLINE copy #-} +copy :: Ptr Word8 -> ByteString -> IO (Ptr Word8) +copy !ptr !(PS fp o l) = withForeignPtr fp $ \p -> do + memcpy ptr (p `plusPtr` o) (fromIntegral l) + return $! ptr `plusPtr` l + +httpVer11 :: ByteString +httpVer11 = "HTTP/1.1 " + +httpVer10 :: ByteString +httpVer10 = "HTTP/1.0 " + +{-# INLINE copyStatus #-} +copyStatus :: Ptr Word8 -> H.HttpVersion -> H.Status -> IO (Ptr Word8) +copyStatus !ptr !httpversion !status = do + ptr1 <- copy ptr httpVer + writeWord8OffPtr ptr1 0 (zero + fromIntegral r2) + writeWord8OffPtr ptr1 1 (zero + fromIntegral r1) + writeWord8OffPtr ptr1 2 (zero + fromIntegral r0) + writeWord8OffPtr ptr1 3 spc + ptr2 <- copy (ptr1 `plusPtr` 4) (H.statusMessage status) + copyCRLF ptr2 + where + httpVer + | httpversion == H.HttpVersion 1 1 = httpVer11 + | otherwise = httpVer10 + (q0,r0) = H.statusCode status `divMod` 10 + (q1,r1) = q0 `divMod` 10 + r2 = q1 `mod` 10 + +{-# INLINE copyHeaders #-} +copyHeaders :: Ptr Word8 -> [H.Header] -> IO (Ptr Word8) +copyHeaders !ptr [] = return ptr +copyHeaders !ptr (h:hs) = do + ptr1 <- copyHeader ptr h + copyHeaders ptr1 hs + +{-# INLINE copyHeader #-} +copyHeader :: Ptr Word8 -> H.Header -> IO (Ptr Word8) +copyHeader !ptr (k,v) = do + ptr1 <- copy ptr (CI.original k) + writeWord8OffPtr ptr1 0 colon + writeWord8OffPtr ptr1 1 spc + ptr2 <- copy (ptr1 `plusPtr` 2) v + copyCRLF ptr2 + +{-# INLINE copyCRLF #-} +copyCRLF :: Ptr Word8 -> IO (Ptr Word8) +copyCRLF !ptr = do + writeWord8OffPtr ptr 0 cr + writeWord8OffPtr ptr 1 lf + return $! ptr `plusPtr` 2 + +zero :: Word8 +zero = 48 +spc :: Word8 +spc = 32 +colon :: Word8 +colon = 58 +cr :: Word8 +cr = 13 +lf :: Word8 +lf = 10 + +
Network/Wai/Handler/Warp/Run.hs view
@@ -1,213 +1,215 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE CPP #-}--module Network.Wai.Handler.Warp.Run where--import Control.Concurrent (forkIO, threadDelay)-import Control.Exception-import Control.Monad (forever, when, unless, void)-import Control.Monad.IO.Class (MonadIO, liftIO)-import Control.Monad.Trans.Class (lift)-import Data.ByteString (ByteString)-import qualified Data.ByteString as S-import Data.Conduit-import Data.Conduit.Internal (ResumableSource (..))-import qualified Data.Conduit.List as CL-import Data.Conduit.Network (bindPort)-import Network (sClose, Socket)-import Network.Sendfile-import Network.Socket (accept, SockAddr)-import qualified Network.Socket.ByteString as Sock-import Network.Wai-import Network.Wai.Handler.Warp.Request-import Network.Wai.Handler.Warp.Response-import Network.Wai.Handler.Warp.Settings-import qualified Network.Wai.Handler.Warp.Timeout as T-import Network.Wai.Handler.Warp.Types-import Prelude hiding (catch)---- 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.-#define PESSIMISTIC_RECV 1--#ifdef PESSIMISTIC_RECV-import System.Posix.Types (Fd(..))-import Control.Concurrent (threadWaitRead)-import Network.Socket (Socket(..))-#endif--#if WINDOWS-import qualified Control.Concurrent.MVar as MV-import Network.Socket (withSocketsDo)-#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-#ifdef PESSIMISTIC_RECV-socketConnection s@(MkSocket fd _ _ _ _) = Connection-#else-socketConnection s = Connection-#endif- { connSendMany = Sock.sendMany s- , connSendAll = Sock.sendAll s- , connSendFile = sendFile s- , connClose = sClose s-#ifdef PESSIMISTIC_RECV- , connRecv = threadWaitRead (Fd fd) >> Sock.recv s bytesPerRead-#else- , connRecv = Sock.recv s bytesPerRead-#endif- }--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--#if __GLASGOW_HASKELL__ < 702-allowInterrupt :: IO ()-allowInterrupt = unblock $ return ()-#endif---- | Run an 'Application' on the given port. This calls 'runSettings' with--- 'defaultSettings'.-run :: Port -> Application -> IO ()-run p = runSettings defaultSettings { settingsPort = p }---- | Run a Warp server with the given settings.-runSettings :: Settings -> Application -> IO ()-#if WINDOWS-runSettings set app = withSocketsDo $ do- var <- MV.newMVar Nothing- let clean = MV.modifyMVar_ var $ \s -> maybe (return ()) sClose s >> return Nothing- void . forkIO $ bracket- (bindPort (settingsPort set) (settingsHost set))- (const clean)- (\s -> do- MV.modifyMVar_ var (\_ -> return $ Just s)- runSettingsSocket set s app)- forever (threadDelay maxBound) `finally` clean-#else-runSettings set =- bracket- (bindPort (settingsPort set) (settingsHost set))- sClose .- flip (runSettingsSocket set)-#endif---- | Same as 'runSettings', but uses a user-supplied socket instead of opening--- one. This allows the user to provide, for example, Unix named socket, which--- can be used when reverse HTTP proxying into your application.------ Note that the 'settingsPort' will still be passed to 'Application's via the--- 'serverPort' record.-runSettingsSocket :: Settings -> Socket -> Application -> IO ()-runSettingsSocket set socket app =- runSettingsConnection set getter app- where- getter = do- (conn, sa) <- accept socket- return (socketConnection conn, sa)--runSettingsConnection :: Settings -> IO (Connection, SockAddr) -> Application -> IO ()-runSettingsConnection set getConn app = do- tm <- maybe (T.initialize $ settingsTimeout set * 1000000) return- $ settingsManager set-#if SENDFILEFD- let duration = settingsFdCacheDuration set- fc <- case duration of- 0 -> return Nothing- _ -> Just <$> F.initialize (duration * 1000000)-#endif- mask $ \restore -> forever $ do- allowInterrupt- (conn, addr) <- getConnLoop- void . forkIO $ do- th <- T.registerKillThread tm-#if SENDFILEFD- let cleaner = Cleaner th fc-#else- let cleaner = Cleaner th-#endif- let serve = do- onOpen- restore $ serveConnection set cleaner port app conn addr- cleanup- cleanup = connClose conn >> T.cancel th >> onClose- handle onE $ (serve `onException` cleanup)- where- -- FIXME: only IOEception is caught. What about other exceptions?- getConnLoop = getConn `catch` \(e :: IOException) -> do- onE (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--serveConnection :: Settings- -> Cleaner- -> Port -> Application -> Connection -> SockAddr-> IO ()-serveConnection settings cleaner port app conn remoteHost' =- runResourceT serveConnection'- where- innerRunResourceT- | settingsResourceTPerRequest settings = lift . runResourceT- | otherwise = id- th = threadHandle cleaner-- serveConnection' :: ResourceT IO ()- serveConnection' = serveConnection'' $ connSource conn th-- serveConnection'' fromClient = do- (env, getSource) <- parseRequest conn port remoteHost' fromClient- case settingsIntercept settings env of- Nothing -> do- -- Let the application run for as long as it wants- liftIO $ T.pause th- keepAlive <- innerRunResourceT $ do- res <- app env-- liftIO $ T.resume th- sendResponse cleaner env conn res-- -- flush the rest of the request body- requestBody env $$ CL.sinkNull- ResumableSource fromClient' _ <- liftIO getSource-- when keepAlive $ serveConnection'' fromClient'- Just intercept -> do- liftIO $ T.pause th- ResumableSource fromClient' _ <- liftIO getSource- intercept fromClient' conn--connSource :: Connection -> T.Handle -> Source (ResourceT IO) ByteString-connSource Connection { connRecv = recv } th = src- where- src = do- bs <- liftIO recv- unless (S.null bs) $ do- when (S.length bs >= 2048) $ liftIO $ T.tickle th- yield bs- src+{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} + +module Network.Wai.Handler.Warp.Run where + +import Control.Concurrent (forkIO, threadDelay) +import Control.Exception +import Control.Monad (forever, when, unless, void) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Trans.Class (lift) +import Data.ByteString (ByteString) +import qualified Data.ByteString as S +import Data.Conduit +import Data.Conduit.Internal (ResumableSource (..)) +import qualified Data.Conduit.List as CL +import Data.Conduit.Network (bindPort) +import Network (sClose, Socket) +import Network.Sendfile +import Network.Socket (accept, SockAddr) +import qualified Network.Socket.ByteString as Sock +import Network.Wai +import Network.Wai.Handler.Warp.Request +import Network.Wai.Handler.Warp.Response +import Network.Wai.Handler.Warp.Settings +import qualified Network.Wai.Handler.Warp.Timeout as T +import Network.Wai.Handler.Warp.Types +import Prelude hiding (catch) + +-- 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 +#define PESSIMISTIC_RECV 1 +#endif + +#ifdef PESSIMISTIC_RECV +import System.Posix.Types (Fd(..)) +import Control.Concurrent (threadWaitRead) +import Network.Socket (Socket(..)) +#endif + +#if WINDOWS +import qualified Control.Concurrent.MVar as MV +import Network.Socket (withSocketsDo) +#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 +#ifdef PESSIMISTIC_RECV +socketConnection s@(MkSocket fd _ _ _ _) = Connection +#else +socketConnection s = Connection +#endif + { connSendMany = Sock.sendMany s + , connSendAll = Sock.sendAll s + , connSendFile = sendFile s + , connClose = sClose s +#ifdef PESSIMISTIC_RECV + , connRecv = threadWaitRead (Fd fd) >> Sock.recv s bytesPerRead +#else + , connRecv = Sock.recv s bytesPerRead +#endif + } + +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 + +#if __GLASGOW_HASKELL__ < 702 +allowInterrupt :: IO () +allowInterrupt = unblock $ return () +#endif + +-- | Run an 'Application' on the given port. This calls 'runSettings' with +-- 'defaultSettings'. +run :: Port -> Application -> IO () +run p = runSettings defaultSettings { settingsPort = p } + +-- | Run a Warp server with the given settings. +runSettings :: Settings -> Application -> IO () +#if WINDOWS +runSettings set app = withSocketsDo $ do + var <- MV.newMVar Nothing + let clean = MV.modifyMVar_ var $ \s -> maybe (return ()) sClose s >> return Nothing + void . forkIO $ bracket + (bindPort (settingsPort set) (settingsHost set)) + (const clean) + (\s -> do + MV.modifyMVar_ var (\_ -> return $ Just s) + runSettingsSocket set s app) + forever (threadDelay maxBound) `finally` clean +#else +runSettings set = + bracket + (bindPort (settingsPort set) (settingsHost set)) + sClose . + flip (runSettingsSocket set) +#endif + +-- | Same as 'runSettings', but uses a user-supplied socket instead of opening +-- one. This allows the user to provide, for example, Unix named socket, which +-- can be used when reverse HTTP proxying into your application. +-- +-- Note that the 'settingsPort' will still be passed to 'Application's via the +-- 'serverPort' record. +runSettingsSocket :: Settings -> Socket -> Application -> IO () +runSettingsSocket set socket app = + runSettingsConnection set getter app + where + getter = do + (conn, sa) <- accept socket + return (socketConnection conn, sa) + +runSettingsConnection :: Settings -> IO (Connection, SockAddr) -> Application -> IO () +runSettingsConnection set getConn app = do + tm <- maybe (T.initialize $ settingsTimeout set * 1000000) return + $ settingsManager set +#if SENDFILEFD + let duration = settingsFdCacheDuration set + fc <- case duration of + 0 -> return Nothing + _ -> Just <$> F.initialize (duration * 1000000) +#endif + mask $ \restore -> forever $ do + allowInterrupt + (conn, addr) <- getConnLoop + void . forkIO $ do + th <- T.registerKillThread tm +#if SENDFILEFD + let cleaner = Cleaner th fc +#else + let cleaner = Cleaner th +#endif + let serve = do + onOpen + restore $ serveConnection set cleaner port app conn addr + cleanup + cleanup = connClose conn >> T.cancel th >> onClose + handle onE $ (serve `onException` cleanup) + where + -- FIXME: only IOEception is caught. What about other exceptions? + getConnLoop = getConn `catch` \(e :: IOException) -> do + onE (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 + +serveConnection :: Settings + -> Cleaner + -> Port -> Application -> Connection -> SockAddr-> IO () +serveConnection settings cleaner port app conn remoteHost' = + runResourceT serveConnection' + where + innerRunResourceT + | settingsResourceTPerRequest settings = lift . runResourceT + | otherwise = id + th = threadHandle cleaner + + serveConnection' :: ResourceT IO () + serveConnection' = serveConnection'' $ connSource conn th + + serveConnection'' fromClient = do + (env, getSource) <- parseRequest conn port remoteHost' fromClient + case settingsIntercept settings env of + Nothing -> do + -- Let the application run for as long as it wants + liftIO $ T.pause th + keepAlive <- innerRunResourceT $ do + res <- app env + + liftIO $ T.resume th + sendResponse cleaner env conn res + + -- flush the rest of the request body + requestBody env $$ CL.sinkNull + ResumableSource fromClient' _ <- liftIO getSource + + when keepAlive $ serveConnection'' fromClient' + Just intercept -> do + liftIO $ T.pause th + ResumableSource fromClient' _ <- liftIO getSource + intercept fromClient' conn + +connSource :: Connection -> T.Handle -> Source (ResourceT IO) ByteString +connSource Connection { connRecv = recv } th = src + where + src = do + bs <- liftIO recv + unless (S.null bs) $ do + when (S.length bs >= 2048) $ liftIO $ T.tickle th + yield bs + src
Network/Wai/Handler/Warp/Settings.hs view
@@ -1,60 +1,60 @@-module Network.Wai.Handler.Warp.Settings where--import Control.Exception-import Control.Monad-import qualified Data.ByteString as S-import Data.Conduit-import Data.Conduit.Network (HostPreference (HostIPv4))-import Network.Wai-import Network.Wai.Handler.Warp.Timeout-import Network.Wai.Handler.Warp.Types-import System.IO (hPrint, stderr)---- | Various Warp server settings. This is purposely kept as an abstract data--- type so that new settings can be added without breaking backwards--- compatibility. In order to create a 'Settings' value, use 'defaultSettings'--- and record syntax to modify individual records. For example:------ > defaultSettings { settingsTimeout = 20 }-data Settings = Settings- { settingsPort :: Int -- ^ 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.- , 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 ())- , 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@.- }---- | The default settings for the Warp server. See the individual settings for--- the default value.-defaultSettings :: Settings-defaultSettings = Settings- { settingsPort = 3000- , settingsHost = HostIPv4- , settingsOnException = \e ->- case fromException e of- Just x -> go x- Nothing ->- when (go' $ fromException e) $- hPrint stderr e- , settingsOnOpen = return ()- , settingsOnClose = return ()- , settingsTimeout = 30- , settingsIntercept = const Nothing- , settingsManager = Nothing- , settingsFdCacheDuration = 10- , settingsResourceTPerRequest = True- }- where- go :: InvalidRequest -> IO ()- go _ = return ()- go' (Just ThreadKilled) = False- go' _ = True+module Network.Wai.Handler.Warp.Settings where + +import Control.Exception +import Control.Monad +import qualified Data.ByteString as S +import Data.Conduit +import Data.Conduit.Network (HostPreference (HostIPv4)) +import Network.Wai +import Network.Wai.Handler.Warp.Timeout +import Network.Wai.Handler.Warp.Types +import System.IO (hPrint, stderr) + +-- | Various Warp server settings. This is purposely kept as an abstract data +-- type so that new settings can be added without breaking backwards +-- compatibility. In order to create a 'Settings' value, use 'defaultSettings' +-- and record syntax to modify individual records. For example: +-- +-- > defaultSettings { settingsTimeout = 20 } +data Settings = Settings + { settingsPort :: Int -- ^ 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. + , 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 ()) + , 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@. + } + +-- | The default settings for the Warp server. See the individual settings for +-- the default value. +defaultSettings :: Settings +defaultSettings = Settings + { settingsPort = 3000 + , settingsHost = HostIPv4 + , settingsOnException = \e -> + case fromException e of + Just x -> go x + Nothing -> + when (go' $ fromException e) $ + hPrint stderr e + , settingsOnOpen = return () + , settingsOnClose = return () + , settingsTimeout = 30 + , settingsIntercept = const Nothing + , settingsManager = Nothing + , settingsFdCacheDuration = 10 + , settingsResourceTPerRequest = True + } + where + go :: InvalidRequest -> IO () + go _ = return () + go' (Just ThreadKilled) = False + go' _ = True
Network/Wai/Handler/Warp/Timeout.hs view
@@ -1,80 +1,80 @@-module Network.Wai.Handler.Warp.Timeout (- Manager- , Handle- , initialize- , register- , registerKillThread- , tickle- , pause- , resume- , cancel- , withManager- ) where--import Control.Concurrent (forkIO, threadDelay, myThreadId, killThread)-import qualified Control.Exception as E-import Control.Monad (forever)-import Control.Monad (void)-import qualified Data.IORef as I---- FIXME implement stopManager---- | A timeout manager-newtype Manager = Manager (I.IORef [Handle])---- | A handle used by 'Manager'-data Handle = Handle (IO ()) (I.IORef State)--data State = Active | Inactive | Paused | Canceled--initialize :: Int -> IO Manager-initialize timeout = do- ref <- I.newIORef []- void . forkIO $ forever $ do- threadDelay timeout- ms <- I.atomicModifyIORef ref (\x -> ([], x))- ms' <- go ms id- I.atomicModifyIORef ref (\x -> (ms' x, ()))- return $ Manager ref- where- go [] front = return front- go (m@(Handle onTimeout iactive):rest) front = do- state <- I.atomicModifyIORef iactive (\x -> (go' x, x))- case state of- Inactive -> do- onTimeout `E.catch` ignoreAll- go rest front- Canceled -> go rest front- _ -> go rest (front . (:) m)- go' Active = Inactive- go' x = x--ignoreAll :: E.SomeException -> IO ()-ignoreAll _ = return ()--register :: Manager -> IO () -> IO Handle-register (Manager ref) onTimeout = do- iactive <- I.newIORef Active- let h = Handle onTimeout iactive- I.atomicModifyIORef ref (\x -> (h : x, ()))- return h--registerKillThread :: Manager -> IO Handle-registerKillThread m = do- tid <- myThreadId- register m $ killThread tid--tickle, pause, resume, cancel :: Handle -> IO ()-tickle (Handle _ iactive) = I.writeIORef iactive Active-pause (Handle _ iactive) = I.writeIORef iactive Paused-resume = tickle-cancel (Handle _ iactive) = I.writeIORef iactive Canceled---- | Call the inner function with a timeout manager.-withManager :: Int -- ^ timeout in microseconds- -> (Manager -> IO a)- -> IO a-withManager timeout f = do- -- FIXME when stopManager is available, use it- man <- initialize timeout- f man+module Network.Wai.Handler.Warp.Timeout ( + Manager + , Handle + , initialize + , register + , registerKillThread + , tickle + , pause + , resume + , cancel + , withManager + ) where + +import Control.Concurrent (forkIO, threadDelay, myThreadId, killThread) +import qualified Control.Exception as E +import Control.Monad (forever) +import Control.Monad (void) +import qualified Data.IORef as I + +-- FIXME implement stopManager + +-- | A timeout manager +newtype Manager = Manager (I.IORef [Handle]) + +-- | A handle used by 'Manager' +data Handle = Handle (IO ()) (I.IORef State) + +data State = Active | Inactive | Paused | Canceled + +initialize :: Int -> IO Manager +initialize timeout = do + ref <- I.newIORef [] + void . forkIO $ forever $ do + threadDelay timeout + ms <- I.atomicModifyIORef ref (\x -> ([], x)) + ms' <- go ms id + I.atomicModifyIORef ref (\x -> (ms' x, ())) + return $ Manager ref + where + go [] front = return front + go (m@(Handle onTimeout iactive):rest) front = do + state <- I.atomicModifyIORef iactive (\x -> (go' x, x)) + case state of + Inactive -> do + onTimeout `E.catch` ignoreAll + go rest front + Canceled -> go rest front + _ -> go rest (front . (:) m) + go' Active = Inactive + go' x = x + +ignoreAll :: E.SomeException -> IO () +ignoreAll _ = return () + +register :: Manager -> IO () -> IO Handle +register (Manager ref) onTimeout = do + iactive <- I.newIORef Active + let h = Handle onTimeout iactive + I.atomicModifyIORef ref (\x -> (h : x, ())) + return h + +registerKillThread :: Manager -> IO Handle +registerKillThread m = do + tid <- myThreadId + register m $ killThread tid + +tickle, pause, resume, cancel :: Handle -> IO () +tickle (Handle _ iactive) = I.writeIORef iactive Active +pause (Handle _ iactive) = I.writeIORef iactive Paused +resume = tickle +cancel (Handle _ iactive) = I.writeIORef iactive Canceled + +-- | Call the inner function with a timeout manager. +withManager :: Int -- ^ timeout in microseconds + -> (Manager -> IO a) + -> IO a +withManager timeout f = do + -- FIXME when stopManager is available, use it + man <- initialize timeout + f man
Network/Wai/Handler/Warp/Types.hs view
@@ -1,88 +1,88 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE CPP #-}--module Network.Wai.Handler.Warp.Types where--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 qualified Network.Wai.Handler.Warp.FdCache as F-#endif--------------------------------------------------------------------warpVersion :: String-warpVersion = showVersion Paths_warp.version---------------------------------------------------------------------- | TCP port number-type Port = Int--------------------------------------------------------------------hTransferEncoding :: HeaderName-hTransferEncoding = "Transfer-Encoding"--hHost :: HeaderName-hHost = "Host"--hServer :: HeaderName-hServer = "Server"--------------------------------------------------------------------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.-data Connection = Connection- { connSendMany :: [ByteString] -> IO ()- , connSendAll :: ByteString -> IO ()- , connSendFile :: FilePath -> Integer -> Integer -> IO () -> [ByteString] -> Cleaner -> IO () -- ^ offset, length- , connClose :: IO ()- , connRecv :: IO ByteString- }--------------------------------------------------------------------#if SENDFILEFD-data Cleaner = Cleaner {- threadHandle :: T.Handle- , fdCacher :: Maybe F.MutableFdCache- }-#else-newtype Cleaner = Cleaner { threadHandle :: T.Handle }-#endif+{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} + +module Network.Wai.Handler.Warp.Types where + +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 qualified Network.Wai.Handler.Warp.FdCache as F +#endif + +---------------------------------------------------------------- + +warpVersion :: String +warpVersion = showVersion Paths_warp.version + +---------------------------------------------------------------- + +-- | TCP port number +type Port = Int + +---------------------------------------------------------------- + +hTransferEncoding :: HeaderName +hTransferEncoding = "Transfer-Encoding" + +hHost :: HeaderName +hHost = "Host" + +hServer :: HeaderName +hServer = "Server" + +---------------------------------------------------------------- + +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. +data Connection = Connection + { connSendMany :: [ByteString] -> IO () + , connSendAll :: ByteString -> IO () + , connSendFile :: FilePath -> Integer -> Integer -> IO () -> [ByteString] -> Cleaner -> IO () -- ^ offset, length + , connClose :: IO () + , connRecv :: IO ByteString + } + +---------------------------------------------------------------- + +#if SENDFILEFD +data Cleaner = Cleaner { + threadHandle :: T.Handle + , fdCacher :: Maybe F.MutableFdCache + } +#else +newtype Cleaner = Cleaner { threadHandle :: T.Handle } +#endif
Setup.lhs view
@@ -1,7 +1,7 @@-#!/usr/bin/env runhaskell--> module Main where-> import Distribution.Simple--> main :: IO ()-> main = defaultMain+#!/usr/bin/env runhaskell + +> module Main where +> import Distribution.Simple + +> main :: IO () +> main = defaultMain
test/Spec.hs view
@@ -1,1 +1,1 @@-{-# OPTIONS_GHC -F -pgmF hspec-discover #-}+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
warp.cabal view
@@ -1,94 +1,94 @@-Name: warp-Version: 1.3.3.2-Synopsis: A fast, light-weight web server for WAI applications.-License: MIT-License-file: LICENSE-Author: Michael Snoyman, Kazu Yamamoto, Matt Brown-Maintainer: michael@snoyman.com-Homepage: http://github.com/yesodweb/wai-Category: Web, Yesod-Build-Type: Simple-Cabal-Version: >=1.8-Stability: Stable-Description: The premier WAI handler. For more information, see <http://steve.vinoski.net/blog/2011/05/01/warp-a-haskell-web-server/>.--Flag network-bytestring- Default: False--Library- Build-Depends: base >= 3 && < 5- , blaze-builder >= 0.2.1.4 && < 0.4- , blaze-builder-conduit >= 0.5 && < 0.6- , bytestring >= 0.9.1.4- , case-insensitive >= 0.2- , conduit >= 0.5 && < 0.6- , ghc-prim- , http-types >= 0.7 && < 0.8- , lifted-base >= 0.1- , network-conduit >= 0.5 && < 0.7- , simple-sendfile >= 0.2.7 && < 0.3- , transformers >= 0.2.2 && < 0.4- , unix-compat >= 0.2- , void- , wai >= 1.3 && < 1.4- if flag(network-bytestring)- Build-Depends: network >= 2.2.1.5 && < 2.2.3- , network-bytestring >= 0.1.3 && < 0.1.4- else- Build-Depends: network >= 2.3- Exposed-modules: Network.Wai.Handler.Warp- Other-modules: Network.Wai.Handler.Warp.Conduit- Network.Wai.Handler.Warp.ReadInt- Network.Wai.Handler.Warp.Request- Network.Wai.Handler.Warp.Response- Network.Wai.Handler.Warp.ResponseHeader- Network.Wai.Handler.Warp.Run- Network.Wai.Handler.Warp.Settings- Network.Wai.Handler.Warp.Timeout- Network.Wai.Handler.Warp.Types- Paths_warp- Ghc-Options: -Wall- if os(linux) || os(freebsd) || os(darwin)- Cpp-Options: -DSENDFILEFD- Build-Depends: unix- , hashable- Other-modules: Network.Wai.Handler.Warp.FdCache- Network.Wai.Handler.Warp.MultiMap- if os(windows)- Cpp-Options: -DWINDOWS--Test-Suite spec- Main-Is: Spec.hs- 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- , blaze-builder-conduit >= 0.5 && < 0.6- , bytestring >= 0.9.1.4- , case-insensitive >= 0.2- , conduit >= 0.5 && < 0.6- , ghc-prim- , http-types >= 0.7 && < 0.8- , lifted-base >= 0.1- , network-conduit- , simple-sendfile >= 0.2.4 && < 0.3- , transformers >= 0.2.2 && < 0.4- , unix-compat >= 0.2- , void- , wai >= 1.3 && < 1.4- , network- , HUnit- , QuickCheck- , hspec == 1.3.*- if os(linux) || os(freebsd) || os(darwin)- Cpp-Options: -DSENDFILEFD- Build-Depends: unix- , hashable- if os(windows)- Cpp-Options: -DWINDOWS--Source-Repository head- Type: git- Location: git://github.com/yesodweb/wai.git+Name: warp +Version: 1.3.3.3 +Synopsis: A fast, light-weight web server for WAI applications. +License: MIT +License-file: LICENSE +Author: Michael Snoyman, Kazu Yamamoto, Matt Brown +Maintainer: michael@snoyman.com +Homepage: http://github.com/yesodweb/wai +Category: Web, Yesod +Build-Type: Simple +Cabal-Version: >=1.8 +Stability: Stable +Description: The premier WAI handler. For more information, see <http://steve.vinoski.net/blog/2011/05/01/warp-a-haskell-web-server/>. + +Flag network-bytestring + Default: False + +Library + Build-Depends: base >= 3 && < 5 + , blaze-builder >= 0.2.1.4 && < 0.4 + , blaze-builder-conduit >= 0.5 && < 0.6 + , bytestring >= 0.9.1.4 + , case-insensitive >= 0.2 + , conduit >= 0.5 && < 0.6 + , ghc-prim + , http-types >= 0.7 && < 0.8 + , lifted-base >= 0.1 + , network-conduit >= 0.5 && < 0.7 + , simple-sendfile >= 0.2.7 && < 0.3 + , transformers >= 0.2.2 && < 0.4 + , unix-compat >= 0.2 + , void + , wai >= 1.3 && < 1.4 + if flag(network-bytestring) + Build-Depends: network >= 2.2.1.5 && < 2.2.3 + , network-bytestring >= 0.1.3 && < 0.1.4 + else + Build-Depends: network >= 2.3 + Exposed-modules: Network.Wai.Handler.Warp + Other-modules: Network.Wai.Handler.Warp.Conduit + Network.Wai.Handler.Warp.ReadInt + Network.Wai.Handler.Warp.Request + Network.Wai.Handler.Warp.Response + Network.Wai.Handler.Warp.ResponseHeader + Network.Wai.Handler.Warp.Run + Network.Wai.Handler.Warp.Settings + Network.Wai.Handler.Warp.Timeout + Network.Wai.Handler.Warp.Types + Paths_warp + Ghc-Options: -Wall + if os(linux) || os(freebsd) || os(darwin) + Cpp-Options: -DSENDFILEFD + Build-Depends: unix + , hashable + Other-modules: Network.Wai.Handler.Warp.FdCache + Network.Wai.Handler.Warp.MultiMap + if os(windows) + Cpp-Options: -DWINDOWS + +Test-Suite spec + Main-Is: Spec.hs + 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 + , blaze-builder-conduit >= 0.5 && < 0.6 + , bytestring >= 0.9.1.4 + , case-insensitive >= 0.2 + , conduit >= 0.5 && < 0.6 + , ghc-prim + , http-types >= 0.7 && < 0.8 + , lifted-base >= 0.1 + , network-conduit + , simple-sendfile >= 0.2.4 && < 0.3 + , transformers >= 0.2.2 && < 0.4 + , unix-compat >= 0.2 + , void + , wai >= 1.3 && < 1.4 + , network + , HUnit + , QuickCheck + , hspec == 1.3.* + if os(linux) || os(freebsd) || os(darwin) + Cpp-Options: -DSENDFILEFD + Build-Depends: unix + , hashable + if os(windows) + Cpp-Options: -DWINDOWS + +Source-Repository head + Type: git + Location: git://github.com/yesodweb/wai.git