warp 1.3.3.3 → 1.3.4
raw patch · 16 files changed
+1769/−1742 lines, 16 filessetup-changed
Files
- LICENSE +20/−20
- Network/Wai/Handler/Warp.hs +72/−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 +222/−215
- Network/Wai/Handler/Warp/ResponseHeader.hs +94/−94
- Network/Wai/Handler/Warp/Run.hs +215/−215
- Network/Wai/Handler/Warp/Settings.hs +60/−60
- Network/Wai/Handler/Warp/Timeout.hs +88/−80
- Network/Wai/Handler/Warp/Types.hs +99/−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,72 @@-{-# 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+ , dummyCleaner+ , 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,222 @@-{-# 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) = do+ liftIO $ putStrLn "sendResponse1"+ x <- headerAndLength+ liftIO $ print ("sendResponse2", x)+ sendResponse' x+ 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+ putStrLn "hasBody"+ connSendFile conn path beg end (T.tickle th) [lheader] cleaner+ putStrLn "finished connSendFile"+ T.tickle th+ print ("tickled", isPersist)+ return isPersist+ | otherwise = liftIO $ do+ putStrLn "otherwise"+ 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,215 +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. -#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 +{-# 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,88 @@-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+ , dummyHandle+ ) 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+import System.IO.Unsafe (unsafePerformIO)++-- FIXME implement stopManager++-- | A timeout manager+newtype Manager = Manager (I.IORef [Handle])++-- | A handle used by 'Manager'+--+-- First field is action to be performed on timeout.+data Handle = Handle (IO ()) (I.IORef State)++-- | A dummy @Handle@.+dummyHandle :: Handle+dummyHandle = Handle (return ()) (unsafePerformIO $ I.newIORef Active)++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,99 @@-{-# 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+ }++----------------------------------------------------------------++-- | A dummy @Cleaner@, intended for applications making use of the low-level+-- request parsing and rendering functions.+--+-- Since 1.3.4+dummyCleaner :: Cleaner++#if SENDFILEFD+dummyCleaner = Cleaner T.dummyHandle Nothing++data Cleaner = Cleaner {+ threadHandle :: T.Handle+ , fdCacher :: Maybe F.MutableFdCache+ }++#else+dummyCleaner = Cleaner T.dummyHandle++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.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 +Name: warp+Version: 1.3.4+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