warp-1.3.9/0000755000000000000000000000000012162030510010651 5ustar0000000000000000warp-1.3.9/LICENSE0000644000000000000000000000207512162030510011662 0ustar0000000000000000Copyright (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. warp-1.3.9/warp.cabal0000644000000000000000000001104112162030510012603 0ustar0000000000000000Name: warp Version: 1.3.9 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 . . Changelog . [1.3.9] Support for byte range requests. . [1.3.7] Sockets now have FD_CLOEXEC set on them. This behavior is more secure, and the change should not affect the vast majority of use cases. extra-source-files: attic/hex Flag network-bytestring Default: False Flag allow-sendfilefd Description: Allow use of sendfileFd (not available on GNU/kFreeBSD) Default: True Library Build-Depends: base >= 3 && < 5 , blaze-builder >= 0.2.1.4 && < 0.4 , blaze-builder-conduit >= 0.5 && < 1.1 , bytestring >= 0.9.1.4 , case-insensitive >= 0.2 , conduit >= 0.5 && < 1.1 , ghc-prim , http-types >= 0.7 , lifted-base >= 0.1 , network-conduit >= 0.5 && < 1.1 , simple-sendfile >= 0.2.7 && < 0.3 , transformers >= 0.2.2 && < 0.4 , unix-compat >= 0.2 , void , wai >= 1.3 && < 1.5 , http-attoparsec 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)) && flag(allow-sendfilefd) Cpp-Options: -DSENDFILEFD Build-Depends: hashable Other-modules: Network.Wai.Handler.Warp.FdCache Network.Wai.Handler.Warp.MultiMap if os(windows) Cpp-Options: -DWINDOWS else Build-Depends: unix 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 , bytestring >= 0.9.1.4 , case-insensitive >= 0.2 , conduit >= 0.5 , ghc-prim , http-types >= 0.7 , 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 , http-attoparsec , network , HUnit , QuickCheck , hspec >= 1.3 -- Yes, this means that the test suite will no longer work on Windows. -- Unfortunately there is a bug in older versions of cabal, and this conditional -- will therefore break older systems. --if (os(linux) || os(freebsd) || os(darwin)) && flag(allow-sendfilefd) 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 warp-1.3.9/Setup.lhs0000644000000000000000000000016212162030510012460 0ustar0000000000000000#!/usr/bin/env runhaskell > module Main where > import Distribution.Simple > main :: IO () > main = defaultMain warp-1.3.9/Network/0000755000000000000000000000000012162030510012302 5ustar0000000000000000warp-1.3.9/Network/Wai/0000755000000000000000000000000012162030510013022 5ustar0000000000000000warp-1.3.9/Network/Wai/Handler/0000755000000000000000000000000012162030510014377 5ustar0000000000000000warp-1.3.9/Network/Wai/Handler/Warp.hs0000644000000000000000000000326712162030510015654 0ustar0000000000000000{-# LANGUAGE CPP #-} --------------------------------------------------------- -- -- Module : Network.Wai.Handler.Warp -- Copyright : Michael Snoyman -- License : BSD3 -- -- Maintainer : Michael Snoyman -- 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 , settingsBeforeMainLoop , settingsServerName -- ** Data types , HostPreference (..) -- * Connection , Connection (..) , runSettingsConnection , runSettingsConnectionMaker -- * 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 -- * Misc , warpVersion ) 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(..)) warp-1.3.9/Network/Wai/Handler/Warp/0000755000000000000000000000000012162030510015310 5ustar0000000000000000warp-1.3.9/Network/Wai/Handler/Warp/ResponseHeader.hs0000644000000000000000000000524212162030510020556 0ustar0000000000000000{-# 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(..), create, 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 -> IO ByteString composeHeader !httpversion !status !responseHeaders = create 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 warp-1.3.9/Network/Wai/Handler/Warp/FdCache.hs0000644000000000000000000000672712162030510017135 0ustar0000000000000000{-# 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) warp-1.3.9/Network/Wai/Handler/Warp/Types.hs0000644000000000000000000000522112162030510016750 0ustar0000000000000000{-# 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 warp-1.3.9/Network/Wai/Handler/Warp/Conduit.hs0000644000000000000000000001442312162030510017255 0ustar0000000000000000module 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 warp-1.3.9/Network/Wai/Handler/Warp/Timeout.hs0000644000000000000000000000705312162030510017277 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE UnboxedTuples, MagicHash #-} module Network.Wai.Handler.Warp.Timeout ( Manager , Handle , initialize , stopManager , register , registerKillThread , tickle , pause , resume , cancel , withManager , dummyHandle ) where import System.Mem.Weak (deRefWeak) #if MIN_VERSION_base(4,6,0) import Control.Concurrent (mkWeakThreadId) #else import GHC.Weak (Weak (..)) import GHC.Conc.Sync (ThreadId (..)) import GHC.IO (IO (IO)) import GHC.Exts (mkWeak#) #endif import Control.Concurrent (forkIO, threadDelay, myThreadId, killThread) import qualified Control.Exception as E import Control.Monad (forever, void) import qualified Data.IORef as I import System.IO.Unsafe (unsafePerformIO) import Data.Typeable (Typeable) -- | 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 $ E.handle ignoreStop $ forever $ do threadDelay timeout ms <- I.atomicModifyIORef ref (\x -> ([], x)) ms' <- go ms id I.atomicModifyIORef ref (\x -> (ms' x, ())) return $ Manager ref where ignoreStop TimeoutManagerStopped = return () 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 data TimeoutManagerStopped = TimeoutManagerStopped deriving (Show, Typeable) instance E.Exception TimeoutManagerStopped stopManager :: Manager -> IO () stopManager (Manager ihandles) = E.mask_ $ do -- Put an undefined value in the IORef to kill the worker thread (yes, it's -- a bit of a hack) !handles <- I.atomicModifyIORef ihandles $ \h -> (E.throw TimeoutManagerStopped, h) mapM_ go handles where go (Handle onTimeout _) = onTimeout `E.catch` ignoreAll 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 wtid <- myThreadId >>= mkWeakThreadId register m $ deRefWeak wtid >>= maybe (return ()) killThread #if !MIN_VERSION_base(4,6,0) mkWeakThreadId :: ThreadId -> IO (Weak ThreadId) mkWeakThreadId t@(ThreadId t#) = IO $ \s -> case mkWeak# t# t Nothing s of (# s1, w #) -> (# s1, Weak w #) #endif 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 warp-1.3.9/Network/Wai/Handler/Warp/Settings.hs0000644000000000000000000000762212162030510017453 0ustar0000000000000000module Network.Wai.Handler.Warp.Settings where import Control.Exception import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import Data.Conduit import Data.Conduit.Network (HostPreference (HostIPv4)) import GHC.IO.Exception (IOErrorType(..)) import Network.Wai import Network.Wai.Handler.Warp.Timeout import Network.Wai.Handler.Warp.Types import System.IO (hPrint, stderr) import System.IO.Error (ioeGetErrorType) -- | 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@. , settingsBeforeMainLoop :: IO () -- ^ Code to run after the listening socket is ready but before entering -- the main event loop. Useful for signaling to tests that they can start -- running, or to drop permissions after binding to a restricted port. -- -- Default: do nothing. -- -- Since 1.3.6 , settingsServerName :: S.ByteString -- ^ Server name to be sent in the Server header. -- -- Default: Warp\//version/ -- -- Since 1.3.8 } -- | The default settings for the Warp server. See the individual settings for -- the default value. defaultSettings :: Settings defaultSettings = Settings { settingsPort = 3000 , settingsHost = HostIPv4 , settingsOnException = defaultExceptionHandler , settingsOnOpen = return () , settingsOnClose = return () , settingsTimeout = 30 , settingsIntercept = const Nothing , settingsManager = Nothing , settingsFdCacheDuration = 10 , settingsResourceTPerRequest = True , settingsBeforeMainLoop = return () , settingsServerName = S8.pack $ "Warp/" ++ warpVersion } defaultExceptionHandler :: SomeException -> IO () defaultExceptionHandler e = throwIO e `catches` handlers where handlers = [Handler ah, Handler ih, Handler oh, Handler sh] ah :: AsyncException -> IO () ah ThreadKilled = return () ah x = hPrint stderr x ih :: InvalidRequest -> IO () ih _ = return () oh :: IOException -> IO () oh x | et == ResourceVanished || et == InvalidArgument = return () | otherwise = hPrint stderr x where et = ioeGetErrorType x sh :: SomeException -> IO () sh x = hPrint stderr x warp-1.3.9/Network/Wai/Handler/Warp/Run.hs0000644000000000000000000002530212162030510016412 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} module Network.Wai.Handler.Warp.Run where import Control.Concurrent (threadDelay, forkIOWithUnmask) 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 import qualified Control.Concurrent.MVar as MV import Network.Socket (withSocketsDo) import Control.Concurrent (forkIO) #else import System.Posix.IO (FdOption(CloseOnExec), setFdOption) import Network.Socket (fdSocket) #endif #if SENDFILEFD import Control.Applicative import qualified Network.Wai.Handler.Warp.FdCache as F #endif -- FIXME come up with good values here bytesPerRead :: Int bytesPerRead = 4096 -- | Default action value for 'Connection' socketConnection :: Socket -> Connection socketConnection s = Connection { connSendMany = Sock.sendMany s , connSendAll = Sock.sendAll s , connSendFile = sendFile s , connClose = sClose s , connRecv = Sock.recv s bytesPerRead } sendFile :: Socket -> FilePath -> Integer -> Integer -> IO () -> [ByteString] -> Cleaner -> IO () #if SENDFILEFD sendFile s path off len act hdr cleaner = case fdCacher cleaner of Nothing -> sendfileWithHeader s path (PartOfFile off len) act hdr Just fdc -> do (fd, fresher) <- F.getFd fdc path sendfileFdWithHeader s fd (PartOfFile off len) (act>>fresher) hdr #else sendFile s path off len act hdr _ = sendfileWithHeader s path (PartOfFile off len) act hdr #endif #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 app = bracket (bindPort (settingsPort set) (settingsHost set)) sClose (\socket -> do setSocketCloseOnExec socket runSettingsSocket set socket app) #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 setSocketCloseOnExec socket return (socketConnection conn, sa) runSettingsConnection :: Settings -> IO (Connection, SockAddr) -> Application -> IO () runSettingsConnection set getConn app = runSettingsConnectionMaker set getConnMaker app where getConnMaker = do (conn, sa) <- getConn return (return conn, sa) -- | Allows you to provide a function which will return a @Connection@. In -- cases where creating the @Connection@ can be expensive, this allows the -- expensive computations to be performed in a separate thread instead of the -- main server loop. -- -- Since 1.3.5 runSettingsConnectionMaker :: Settings -> IO (IO Connection, SockAddr) -> Application -> IO () runSettingsConnectionMaker set getConn app = do #if SENDFILEFD let duration = settingsFdCacheDuration set fc <- case duration of 0 -> return Nothing _ -> Just <$> F.initialize (duration * 1000000) #endif settingsBeforeMainLoop set -- Note that there is a thorough discussion of the exception safety of the -- following code at: https://github.com/yesodweb/wai/issues/146 -- -- We need to make sure of two things: -- -- 1. Asynchronous exceptions are not blocked entirely in the main loop. -- Doing so would make it impossible to kill the Warp thread. -- -- 2. Once a connection maker is received via getConnLoop, the connection -- is guaranteed to be closed, even in the presence of async exceptions. -- -- Our approach is explained in the comments below. -- First mask all exceptions in the main loop. This is necessary to ensure -- that no async exception is throw between the call to getConnLoop and the -- registering of connClose. withTimeoutManager $ \tm -> mask_ . forever $ do -- Allow async exceptions before receiving the next connection maker. allowInterrupt -- getConnLoop will try to receive the next incoming request. It -- returns a /connection maker/, not a connection, since in some -- circumstances creating a working connection from a raw socket may be -- an expensive operation, and this expensive work should not be -- performed in the main event loop. An example of something expensive -- would be TLS negotiation. (mkConn, addr) <- getConnLoop -- Fork a new worker thread for this connection maker, and ask for a -- function to unmask (i.e., allow async exceptions to be thrown). -- -- GHC 7.8 cannot infer the type of "void . forkIOWithUnmask" void $ forkIOWithUnmask $ \unmask -> -- Run the connection maker to get a new connection, and ensure -- that the connection is closed. If the mkConn call throws an -- exception, we will leak the connection. If the mkConn call is -- vulnerable to attacks (e.g., Slowloris), we do nothing to -- protect the server. It is therefore vital that mkConn is well -- vetted. -- -- We grab the connection before registering timeouts since the -- timeouts will be useless during connection creation, due to the -- fact that async exceptions are still masked. bracket mkConn connClose $ \conn -> -- We need to register a timeout handler for this thread, and -- cancel that handler as soon as we exit. bracket (T.registerKillThread tm) T.cancel $ \th -> #if SENDFILEFD let cleaner = Cleaner th fc #else let cleaner = Cleaner th #endif -- We now have fully registered a connection close handler -- in the case of all exceptions, so it is safe to one -- again allow async exceptions. in unmask . -- Call the user-supplied on exception code if any -- exceptions are thrown. handle onE . -- Call the user-supplied code for connection open and close events bracket_ onOpen onClose $ -- Actually serve this connection. serveConnection th set cleaner port app conn addr 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 withTimeoutManager f = case settingsManager set of Nothing -> bracket (T.initialize $ settingsTimeout set * 1000000) T.stopManager f Just tm -> f tm serveConnection :: T.Handle -> Settings -> Cleaner -> Port -> Application -> Connection -> SockAddr-> IO () serveConnection timeoutHandle 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) <- parseRequestInternal conn timeoutHandle 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 settings 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 -- Copied from: https://github.com/mzero/plush/blob/master/src/Plush/Server/Warp.hs setSocketCloseOnExec :: Socket -> IO () #if WINDOWS setSocketCloseOnExec _ = return () #else setSocketCloseOnExec socket = setFdOption (fromIntegral $ fdSocket socket) CloseOnExec True #endif warp-1.3.9/Network/Wai/Handler/Warp/Request.hs0000644000000000000000000002270012162030510017275 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} 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) import qualified Network.Wai.Handler.Warp.Timeout as Timeout -- FIXME come up with good values here maxTotalHeaderLength :: Int maxTotalHeaderLength = 50 * 1024 parseRequest :: Connection -> Port -> SockAddr -> Source (ResourceT IO) ByteString -> ResourceT IO (Request, IO (ResumableSource (ResourceT IO) ByteString)) parseRequest conn = parseRequestInternal conn Timeout.dummyHandle parseRequestInternal :: Connection -> Timeout.Handle -> Port -> SockAddr -> Source (ResourceT IO) ByteString -> ResourceT IO (Request, IO (ResumableSource (ResourceT IO) ByteString)) parseRequestInternal conn timeoutHandle port remoteHost' src1 = do (src2, headers') <- src1 $$+ takeHeaders parseRequest' conn timeoutHandle port headers' remoteHost' src2 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 -> Timeout.Handle -> Port -> [ByteString] -> SockAddr -> ResumableSource (ResourceT IO) ByteString -- FIXME was buffered -> ResourceT IO (Request, IO (ResumableSource (ResourceT IO) ByteString)) parseRequest' _ _ _ [] _ _ = throwIO $ NotEnoughLines [] parseRequest' conn timeoutHandle port (firstLine:otherLines) remoteHost' src = do (method, rpath', gets, httpversion) <- parseFirst firstLine let (host',rpath) | S.null rpath' = ("", "/") | "http://" `S.isPrefixOf` rpath' = S.breakByte 47 $ S.drop 7 rpath' | otherwise = ("", rpath') heads <- liftIO $ handleExpect conn httpversion id (map parseHeaderNoAttr otherLines) let host = fromMaybe host' $ lookup hHost heads let len0 = case lookup H.hContentLength heads of Nothing -> 0 Just bs -> readInt bs let serverName' = takeUntil 58 host -- ':' let chunked = maybe False ((== "chunked") . CI.foldCase) $ lookup hTransferEncoding heads (rbody, getSource) <- liftIO $ if chunked then do ref <- I.newIORef (src, NeedLen) return (chunkedSource ref, fst <$> I.readIORef ref) else do ibs <- IsolatedBSSource <$> I.newIORef (len0, src) return (ibsIsolate ibs, ibsDone ibs) return (Request { requestMethod = method , httpVersion = httpversion , pathInfo = H.decodePathSegments rpath , rawPathInfo = rpath , rawQueryString = gets , queryString = H.parseQuery gets , serverName = serverName' , serverPort = port , requestHeaders = heads , isSecure = False , remoteHost = remoteHost' , requestBody = do -- Timeout handling was paused after receiving the full request -- headers. Now we need to resume it to avoid a slowloris -- attack during request body sending. liftIO $ Timeout.resume timeoutHandle -- As soon as we finish receiving the request body, whether -- because the application is not interested in more bytes, or -- because there is no more data available, pause the timeout -- handler again. addCleanup (const $ liftIO $ Timeout.pause timeoutHandle) rbody , vault = mempty #if MIN_VERSION_wai(1, 4, 0) , requestBodyLength = if chunked then ChunkedBody else KnownLength $ fromIntegral len0 #endif }, getSource) {-# 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 -> Sink ByteString (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) b = case nl of 0 -> True 1 -> S.index bs 0 == 13 _ -> False in Just (nl, (not b) && (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 warp-1.3.9/Network/Wai/Handler/Warp/Response.hs0000644000000000000000000002272712162030510017454 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} 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, listToMaybe) import Data.Monoid (mappend) import qualified Network.HTTP.Types as H import Network.Wai import Network.Wai.Handler.Warp.ReadInt import Network.Wai.Handler.Warp.Settings import qualified Network.Wai.Handler.Warp.ResponseHeader as RH import qualified Network.Wai.Handler.Warp.Timeout as T import Network.Wai.Handler.Warp.Types import qualified System.PosixCompat.Files as P import Network.HTTP.Attoparsec (parseByteRanges) import Numeric (showInt) ---------------------------------------------------------------- ---------------------------------------------------------------- sendResponse :: Settings -> Cleaner -> Request -> Connection -> Response -> ResourceT IO Bool ---------------------------------------------------------------- sendResponse settings cleaner req conn (ResponseFile s0 hs0 path mpart0) = headerAndLength >>= sendResponse' where hs = addAccept hs0 th = threadHandle cleaner headerAndLength = liftIO . try $ do (hadLength, cl) <- case readInt <$> checkLength hs of Just cl -> return (True, cl) Nothing -> case mpart0 of Just part -> return (False, fromIntegral $ filePartByteCount part) Nothing -> (False, ) . fromIntegral . P.fileSize <$> P.getFileStatus path let (s, addRange, beg, end) = case mpart0 of Just part -> (s0, id, filePartOffset part, filePartByteCount part) Nothing -> case lookup H.hRange (requestHeaders req) >>= parseByteRanges >>= listToMaybe of Just range | s0 == H.status200 -> case range of H.ByteRangeFrom from -> rangeRes cl from (cl - 1) H.ByteRangeFromTo from to -> rangeRes cl from to H.ByteRangeSuffix count -> rangeRes cl (cl - count) (cl - 1) _ -> (s0, id, 0, cl) hs' | hadLength = hs | otherwise = addLength end hs return (s, addRange hs', beg, end) rangeRes cl from to = (H.status206, (("Content-Range", rangeHeader cl from to):), from, to - from + 1) rangeHeader total from to = B.pack $ 'b' : 'y': 't' : 'e' : 's' : ' ' : showInt from ( '-' : showInt to ( '/' : showInt total "")) sendResponse' (Right (s, lengthyHeaders, beg, end)) | hasBody s req = liftIO $ do lheader <- composeHeader settings version s lengthyHeaders connSendFile conn path beg end (T.tickle th) [lheader] cleaner T.tickle th return isPersist | otherwise = liftIO $ do composeHeader settings version s hs >>= connSendAll conn T.tickle th return isPersist -- FIXME isKeepAlive? where version = httpVersion req (isPersist,_) = infoFromRequest req sendResponse' (Left (_ :: SomeException)) = sendResponse settings cleaner req conn notFound where notFound = responseLBS H.status404 [(H.hContentType, "text/plain")] "File not found" ---------------------------------------------------------------- sendResponse settings cleaner req conn (ResponseBuilder s hs b) | hasBody s req = liftIO $ do header <- composeHeaderBuilder settings version s hs needsChunked let body | needsChunked = header `mappend` chunkedTransferEncoding b `mappend` chunkedTransferTerminator | otherwise = header `mappend` b flip toByteStringIO body $ \bs -> do connSendAll conn bs T.tickle th return isKeepAlive | otherwise = liftIO $ do composeHeader settings version s hs >>= connSendAll conn T.tickle th return isPersist where th = threadHandle cleaner version = httpVersion req reqinfo@(isPersist,_) = infoFromRequest req (isKeepAlive, needsChunked) = infoFromResponse hs reqinfo ---------------------------------------------------------------- sendResponse settings cleaner req conn (ResponseSource s hs bodyFlush) | hasBody s req = do header <- liftIO $ composeHeaderBuilder settings version s hs needsChunked let src = CL.sourceList [header] `mappend` cbody src $$ builderToByteString =$ connSink conn th return isKeepAlive | otherwise = liftIO $ do composeHeader settings version s hs >>= connSendAll conn T.tickle th return isPersist where th = threadHandle cleaner body = mapOutput (\x -> case x of Flush -> flush Chunk builder -> builder) bodyFlush cbody = if needsChunked then body $= chunk else body -- FIXME perhaps alloca a buffer per thread and reuse that in all -- functions below. Should lessen greatly the GC burden (I hope) chunk :: Conduit Builder (ResourceT IO) Builder 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 addAccept :: H.ResponseHeaders -> H.ResponseHeaders addAccept = (("Accept-Ranges", "bytes"):) addEncodingHeader :: H.ResponseHeaders -> H.ResponseHeaders addEncodingHeader hdrs = (hTransferEncoding, "chunked") : hdrs addServerHeader :: Settings -> H.ResponseHeaders -> H.ResponseHeaders addServerHeader settings hdrs = case lookup hServer hdrs of Nothing -> warpVersionHeader settings : hdrs Just _ -> hdrs warpVersionHeader :: Settings -> H.Header warpVersionHeader settings = (hServer, settingsServerName settings) ---------------------------------------------------------------- composeHeader :: Settings -> H.HttpVersion -> H.Status -> H.ResponseHeaders -> IO ByteString composeHeader settings version s hs = RH.composeHeader version s $ addServerHeader settings hs composeHeaderBuilder :: Settings -> H.HttpVersion -> H.Status -> H.ResponseHeaders -> Bool -> IO Builder composeHeaderBuilder settings ver s hs True = fromByteString <$> composeHeader settings ver s (addEncodingHeader hs) composeHeaderBuilder settings ver s hs False = fromByteString <$> composeHeader settings ver s hs warp-1.3.9/Network/Wai/Handler/Warp/ReadInt.hs0000644000000000000000000000514612162030510017200 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE BangPatterns #-} -- Copyright : Erik de Castro Lopo -- 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 warp-1.3.9/Network/Wai/Handler/Warp/MultiMap.hs0000644000000000000000000001511112162030510017373 0ustar0000000000000000module 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) warp-1.3.9/test/0000755000000000000000000000000012162030510011630 5ustar0000000000000000warp-1.3.9/test/Spec.hs0000644000000000000000000000005412162030510013055 0ustar0000000000000000{-# OPTIONS_GHC -F -pgmF hspec-discover #-} warp-1.3.9/attic/0000755000000000000000000000000012162030510011755 5ustar0000000000000000warp-1.3.9/attic/hex0000644000000000000000000000002012162030510012454 0ustar00000000000000000123456789abcdef