warp 1.3.0.1 → 1.3.1
raw patch · 15 files changed
+1191/−1274 lines, 15 filesdep +QuickCheckdep +voiddep −warpdep ~bytestringdep ~conduitdep ~http-types
Dependencies added: QuickCheck, void
Dependencies removed: warp
Dependency ranges changed: bytestring, conduit, http-types, transformers, wai
Files
- Network/Wai/Handler/Warp.hs +50/−817
- Network/Wai/Handler/Warp/Conduit.hs +147/−0
- Network/Wai/Handler/Warp/ReadInt.hs +64/−0
- Network/Wai/Handler/Warp/Request.hs +214/−0
- Network/Wai/Handler/Warp/Response.hs +207/−0
- Network/Wai/Handler/Warp/ResponseHeader.hs +94/−0
- Network/Wai/Handler/Warp/Run.hs +158/−0
- Network/Wai/Handler/Warp/Settings.hs +52/−0
- Network/Wai/Handler/Warp/Timeout.hs +80/−0
- Network/Wai/Handler/Warp/Types.hs +73/−0
- ReadInt.hs +0/−58
- Timeout.hs +0/−66
- test/Spec.hs +1/−0
- test/main.hs +0/−298
- warp.cabal +51/−35
Network/Wai/Handler/Warp.hs view
@@ -1,11 +1,5 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}+ --------------------------------------------------------- -- -- Module : Network.Wai.Handler.Warp@@ -21,816 +15,55 @@ --------------------------------------------------------- -- | 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- -- ** Data types- , HostPreference (..)- -- * Connection- , Connection (..)- , runSettingsConnection- -- * Datatypes- , Port- , InvalidRequest (..)- -- * Internal- , Manager- , withManager- , parseRequest- , sendResponse- , registerKillThread- , pause- , resume- , T.cancel- , T.register- , T.initialize- , socketConnection+module Network.Wai.Handler.Warp (+ -- * Run a Warp server+ run+ , runSettings+ , runSettingsSocket+ -- * Settings+ , Settings+ , defaultSettings+ , settingsPort+ , settingsHost+ , settingsOnException+ , settingsOnOpen+ , settingsOnClose+ , settingsTimeout+ , settingsIntercept+ , settingsManager+ -- ** 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 Prelude hiding (lines, catch)-import Network.Wai--import Data.ByteString (ByteString)-import qualified Data.ByteString as S-import qualified Data.ByteString.Unsafe as SU-import qualified Data.ByteString.Char8 as B-import qualified Data.ByteString.Lazy as L-import Network (sClose, Socket)-import Network.Socket (accept, SockAddr)-import qualified Network.Socket.ByteString as Sock-import Control.Exception- ( mask, catch, handle, onException, bracket- , Exception, SomeException, IOException, AsyncException (ThreadKilled)- , fromException, toException- , try-#if __GLASGOW_HASKELL__ >= 702- , allowInterrupt-#else- , unblock-#endif-#if WINDOWS- , finally-#endif- )-import Control.Concurrent (forkIO, threadDelay)-import Data.Maybe (fromMaybe, isJust)-import Data.Char (toLower, isHexDigit)-import Data.Word (Word)--import Data.Typeable (Typeable)--import Data.Conduit-import Data.Conduit.Internal (ResumableSource (..))-import qualified Data.Conduit.List as CL-import qualified Data.Conduit.Binary as CB-import Data.Conduit.Blaze (builderToByteString)-import Control.Exception.Lifted (throwIO)-import Blaze.ByteString.Builder.HTTP- (chunkedTransferEncoding, chunkedTransferTerminator)-import Blaze.ByteString.Builder- (copyByteString, Builder, toLazyByteString, toByteStringIO, flush)-import Blaze.ByteString.Builder.Char8 (fromChar, fromShow)-import Data.Monoid (mappend, mempty)-import Network.Sendfile--import qualified System.PosixCompat.Files as P--import Control.Monad.IO.Class (MonadIO, liftIO)-import Control.Monad.Trans.Class (lift)-import qualified Timeout as T-import Timeout (Manager, registerKillThread, pause, resume)-import Data.Word (Word8)-import Data.List (foldl')-import Control.Monad (forever, when, void)-import qualified Network.HTTP.Types as H-import qualified Data.CaseInsensitive as CI-import System.IO (hPrint, stderr)-import ReadInt (readInt64)-import qualified Data.IORef as I-import Data.Conduit.Network (bindPort, HostPreference (HostIPv4))--#if WINDOWS-import qualified Control.Concurrent.MVar as MV-import Network.Socket (withSocketsDo)-#endif--import Data.Version (showVersion)-import qualified Paths_warp--warpVersion :: String-warpVersion = showVersion Paths_warp.version--#if __GLASGOW_HASKELL__ < 702-allowInterrupt :: IO ()-allowInterrupt = unblock $ return ()-#endif---- |------ 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 :: [B.ByteString] -> IO ()- , connSendAll :: B.ByteString -> IO ()- , connSendFile :: FilePath -> Integer -> Integer -> IO () -> [ByteString] -> IO () -- ^ offset, length- , connClose :: IO ()- , connRecv :: IO B.ByteString- }--socketConnection :: Socket -> Connection-socketConnection s = Connection- { connSendMany = Sock.sendMany s- , connSendAll = Sock.sendAll s- , connSendFile = \fp off len act hdr -> sendfileWithHeader s fp (PartOfFile off len) act hdr- , connClose = sClose s- , connRecv = Sock.recv s bytesPerRead- }---- | 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- _ <- 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)+ , takeHeaders+ , parseFirst+ , readInt #endif--type Port = Int---- | 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- mask $ \restore -> forever $ do- allowInterrupt- (conn, addr) <- getConnLoop- void $ forkIO $ do- th <- T.registerKillThread tm- handle onE $ (do onOpen- restore $ serveConnection set th port app conn addr- connClose conn >> T.cancel th >> onClose- ) `onException` (T.cancel th >> connClose conn >> onClose)- 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---- | 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- if count == 0- -- No more bytes wanted downstream, so we're done.- then return ()- else 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) = fmap snd $ I.readIORef ref--serveConnection :: Settings- -> T.Handle- -> Port -> Application -> Connection -> SockAddr-> IO ()-serveConnection settings th port app conn remoteHost' =- runResourceT serveConnection'- where- serveConnection' :: ResourceT IO ()- serveConnection' = do- let fromClient = connSource conn th- serveConnection'' fromClient-- 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- res <- app env-- liftIO $ T.resume th- keepAlive <- sendResponse th 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--parseRequest :: Connection -> Port -> SockAddr- -> Source (ResourceT IO) S.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---- FIXME come up with good values here-bytesPerRead, maxTotalHeaderLength :: Int-bytesPerRead = 4096-maxTotalHeaderLength = 50 * 1024--data InvalidRequest =- NotEnoughLines [String]- | BadFirstLine String- | NonHttp- | IncompleteHeaders- | ConnectionClosedByPeer- | OverLargeHeader- deriving (Show, Typeable, Eq)-instance Exception InvalidRequest--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) S.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 "host" heads- let len0 =- case lookup "content-length" heads of- Nothing -> 0- Just bs -> readInt bs- let serverName' = takeUntil 58 host -- ':'- let chunked = maybe False ((== "chunked") . B.map toLower)- $ lookup "transfer-encoding" heads- (rbody, getSource) <- liftIO $- if chunked- then do- ref <- I.newIORef (src, NeedLen)- return (chunkedSource ref, fmap fst $ I.readIORef ref)- else do- ibs <- fmap 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)--data ChunkState = NeedLen- | NeedLenNewline- | HaveLen Word--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) = 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- $ B.takeWhile isHexDigit x- return (w, S.drop 1 y)-- hexToWord w- | w < 58 = w - 48- | w < 71 = w - 55- | otherwise = w - 87--takeUntil :: Word8 -> ByteString -> ByteString-takeUntil c bs =- case S.elemIndex c bs of- Just !idx -> SU.unsafeTake idx bs- Nothing -> bs-{-# INLINE takeUntil #-}--parseFirst :: ByteString- -> 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) = B.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-{-# INLINE parseFirst #-} -- FIXME is this inline necessary? the function is only called from one place and not exported--httpBuilder, spaceBuilder, newlineBuilder, transferEncodingBuilder- , colonSpaceBuilder :: Builder-httpBuilder = copyByteString "HTTP/"-spaceBuilder = fromChar ' '-newlineBuilder = copyByteString "\r\n"-transferEncodingBuilder = copyByteString "Transfer-Encoding: chunked\r\n\r\n"-colonSpaceBuilder = copyByteString ": "--headers :: H.HttpVersion -> H.Status -> H.ResponseHeaders -> Bool -> Builder-headers !httpversion !status !responseHeaders !isChunked' = {-# SCC "headers" #-}- let !start = httpBuilder- `mappend` copyByteString- (case httpversion of- H.HttpVersion 1 1 -> "1.1"- _ -> "1.0")- `mappend` spaceBuilder- `mappend` fromShow (H.statusCode status)- `mappend` spaceBuilder- `mappend` copyByteString (H.statusMessage status)- `mappend` newlineBuilder- !start' = foldl' responseHeaderToBuilder start (serverHeader responseHeaders)- !end = if isChunked'- then transferEncodingBuilder- else newlineBuilder- in start' `mappend` end--responseHeaderToBuilder :: Builder -> H.Header -> Builder-responseHeaderToBuilder b (x, y) = b- `mappend` copyByteString (CI.original x)- `mappend` colonSpaceBuilder- `mappend` copyByteString y- `mappend` newlineBuilder--checkPersist :: Request -> Bool-checkPersist req- | ver == H.http11 = checkPersist11 conn- | otherwise = checkPersist10 conn- where- ver = httpVersion req- conn = lookup "connection" $ requestHeaders req- checkPersist11 (Just x)- | CI.foldCase x == "close" = False- checkPersist11 _ = True- checkPersist10 (Just x)- | CI.foldCase x == "keep-alive" = True- checkPersist10 _ = False--isChunked :: H.HttpVersion -> Bool-isChunked = (==) H.http11--hasBody :: H.Status -> Request -> Bool-hasBody s req = s /= H.Status 204 "" && s /= H.status304 &&- H.statusCode s >= 200 && requestMethod req /= "HEAD"--sendResponse :: T.Handle- -> Request -> Connection -> Response -> ResourceT IO Bool-sendResponse th req conn r = sendResponse' r- where- version = httpVersion req- isPersist = checkPersist req- isChunked' = isChunked version- needsChunked hs = isChunked' && not (hasLength hs)- isKeepAlive hs = isPersist && (isChunked' || hasLength hs)- hasLength hs = isJust $ lookup "content-length" hs- sendHeader = connSendMany conn . L.toChunks . toLazyByteString-- sendResponse' :: Response -> ResourceT IO Bool- sendResponse' (ResponseFile s hs fp mpart) = do- eres <-- case (readInt `fmap` lookup "content-length" hs, mpart) of- (Just cl, _) -> return $ Right (hs, cl)- (Nothing, Nothing) -> liftIO $ try $ do- cl <- P.fileSize `fmap` P.getFileStatus fp- return $ addClToHeaders cl- (Nothing, Just part) -> do- let cl = filePartByteCount part- return $ Right $ addClToHeaders cl- case eres of- Left (_ :: SomeException) -> sendResponse' $ responseLBS- H.status404- [("Content-Type", "text/plain")]- "File not found"- Right (lengthyHeaders, cl) -> liftIO $ do- let headers' = L.toChunks . toLazyByteString $ headers version s lengthyHeaders False- T.tickle th- if hasBody s req then do- case mpart of- Nothing -> connSendFile conn fp 0 cl (T.tickle th) headers'- Just part -> connSendFile conn fp (filePartOffset part) (filePartByteCount part) (T.tickle th) headers'- T.tickle th- return isPersist- else- return isPersist- where- addClToHeaders cl = (("Content-Length", B.pack $ show cl):hs, fromIntegral cl)-- sendResponse' (ResponseBuilder s hs b)- | hasBody s req = liftIO $ do- toByteStringIO (\bs -> do- connSendAll conn bs- T.tickle th) body- return (isKeepAlive hs)- | otherwise = liftIO $ do- sendHeader $ headers' False- T.tickle th- return isPersist- where- headers' = headers version s hs- needsChunked' = needsChunked hs- body = if needsChunked'- then headers' needsChunked'- `mappend` chunkedTransferEncoding b- `mappend` chunkedTransferTerminator- else headers' False `mappend` b-- sendResponse' (ResponseSource s hs bodyFlush)- | hasBody s req = do- let src = CL.sourceList [headers' needsChunked'] `mappend`- (if needsChunked' then body $= chunk else body)- src $$ builderToByteString =$ connSink conn th- return $ isKeepAlive hs- | otherwise = liftIO $ do- sendHeader $ headers' False- T.tickle th- return isPersist- where- body = mapOutput (\x -> case x of- Flush -> flush- Chunk builder -> builder) bodyFlush- headers' = headers version s hs- -- FIXME perhaps alloca a buffer per thread and reuse that in all- -- functions below. Should lessen greatly the GC burden (I hope)- needsChunked' = needsChunked hs- chunk :: Conduit Builder (ResourceT IO) Builder- chunk = await >>= maybe (yield chunkedTransferTerminator) (\x -> yield (chunkedTransferEncoding x) >> chunk)--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')--connSource :: Connection -> T.Handle -> Source (ResourceT IO) ByteString-connSource Connection { connRecv = recv } th =- src- where- src = do- bs <- liftIO recv- if S.null bs- then return ()- else do- when (S.length bs >= 2048) $ liftIO $ T.tickle th- yield bs- src---- | Use 'connSendAll' to send this data while respecting timeout rules.-connSink :: Connection -> T.Handle -> Sink B.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.-------- The functions below are not warp-specific and could be split out into a---separate package.---- | 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'- }---- | 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- }- where- go :: InvalidRequest -> IO ()- go _ = return ()- go' (Just ThreadKilled) = False- go' _ = True--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--takeHeaders :: Sink ByteString (ResourceT IO) [ByteString]-takeHeaders =- await >>= maybe (throwIO ConnectionClosedByPeer) (push (THStatus 0 id id))- where- close :: Sink ByteString (ResourceT IO) a- close = throwIO IncompleteHeaders-- push (THStatus len lines prepend) bs- -- Too many bytes- | len > maxTotalHeaderLength = throwIO OverLargeHeader- | otherwise =- case mnl of- -- No newline find in this chunk. Add it to the prepend,- -- update the length, and continue processing.- Nothing ->- let len' = len + bsLen- prepend' = prepend . S.append bs- status = THStatus len' lines prepend'- in await >>= maybe close (push status)- -- Found a newline, but next line continues as a multiline header- Just (end, True) ->- let rest = S.drop (end + 1) bs- prepend' = prepend . S.append (SU.unsafeTake (checkCR bs end) bs)- len' = len + end- status = THStatus len' lines prepend'- in push status rest- -- Found a newline at position end.- Just (end, False) ->- let 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- in if S.null line- -- no more headers- then- let lines' = lines []- -- leftover- rest = if start < bsLen- then Just (SU.unsafeDrop start bs)- else Nothing- in maybe (return ()) leftover rest >> return lines'- -- more headers- else- let len' = len + start- lines' = lines . (line:)- status = THStatus len' lines' id- in if start < bsLen- -- more bytes in this chunk, push again- then let bs' = SU.unsafeDrop start bs- in push status bs'- -- no more bytes in this chunk, ask for more- else await >>= maybe close (push status)- 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 takeHeaders #-}--checkCR :: ByteString -> Int -> Int-checkCR bs pos =- let !p = pos - 1- in if '\r' == B.index bs p- then p- else pos-{-# INLINE checkCR #-}--readInt :: Integral a => ByteString -> a-readInt bs = fromIntegral $ readInt64 bs-{-# INLINE readInt #-}----- | 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 <- T.initialize timeout- f man--serverHeader :: H.RequestHeaders -> H.RequestHeaders-serverHeader hdrs = case lookup key hdrs of- Nothing -> server : hdrs- Just _ -> hdrs- where- key = "Server"- ver = B.pack $ "Warp/" ++ warpVersion- server = (key, ver)+ ) where -fmapResume :: (Source m o1 -> Source m o2) -> ResumableSource m o1 -> ResumableSource m o2-fmapResume f (ResumableSource src m) = ResumableSource (f src) m+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
@@ -0,0 +1,147 @@+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 qualified Data.ByteString as S+import qualified Data.ByteString.Char8 as B+import Data.Char (isHexDigit)+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)+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++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) = 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+ $ B.takeWhile isHexDigit x+ return (w, S.drop 1 y)++ hexToWord w+ | w < 58 = w - 48+ | w < 71 = w - 55+ | otherwise = w - 87++----------------------------------------------------------------++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/ReadInt.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE OverloadedStrings, MagicHash, 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.Char8 as B+import qualified Data.Char as C+import Data.Int (Int64)+import GHC.Prim+import GHC.Types++{-# 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 =+ B.foldl' (\i c -> i * 10 + fromIntegral (mhDigitToInt c)) 0+ $ B.takeWhile C.isDigit bs++data Table = Table !Addr#++{- NOINLINE mhDigitToInt #-}+mhDigitToInt :: Char -> Int+mhDigitToInt (C# i) = I# (word2Int# (indexWord8OffAddr# addr (ord# 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"#+
+ Network/Wai/Handler/Warp/Request.hs view
@@ -0,0 +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+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) S.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) S.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) = B.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 '\r' == B.index bs p then p else pos+ where+ !p = pos - 1
+ Network/Wai/Handler/Warp/Response.hs view
@@ -0,0 +1,207 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE BangPatterns #-}++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 qualified Data.ByteString.Char8 as B+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 :: T.Handle+ -> Request -> Connection -> Response -> ResourceT IO Bool++----------------------------------------------------------------++sendResponse th req conn (ResponseFile s hs fp mpart) =+ headerAndLength >>= sendResponse'+ where+ headerAndLength = case (readInt <$> checkLength hs, mpart) of+ (Just cl, _) -> return $ Right (hs, cl)+ (Nothing, Nothing) -> liftIO . try $ do+ cl <- fromIntegral . P.fileSize <$> P.getFileStatus fp+ 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 fp beg end (T.tickle th) [lheader]+ 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 th req conn notFound+ where+ notFound = responseLBS H.status404 [(H.hContentType, "text/plain")] "File not found"++----------------------------------------------------------------++sendResponse th 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+ 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 th 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+ 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 B.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 B.ByteString+checkLength = lookup H.hContentLength++----------------------------------------------------------------++hasBody :: H.Status -> Request -> Bool+hasBody s req = s /= H.Status 204 ""+ && s /= H.status304+ && H.statusCode s >= 200+ && requestMethod req /= H.methodHead++----------------------------------------------------------------++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 -> B.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
@@ -0,0 +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++
+ Network/Wai/Handler/Warp/Run.hs view
@@ -0,0 +1,158 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}++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 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)++#if WINDOWS+import qualified Control.Concurrent.MVar as MV+import Network.Socket (withSocketsDo)+#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 = \fp off len act hdr -> sendfileWithHeader s fp (PartOfFile off len) act hdr+ , connClose = sClose s+ , connRecv = Sock.recv s bytesPerRead+ }++#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+ mask $ \restore -> forever $ do+ allowInterrupt+ (conn, addr) <- getConnLoop+ void . forkIO $ do+ th <- T.registerKillThread tm+ let serve = do+ onOpen+ restore $ serveConnection set th 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+ -> T.Handle+ -> Port -> Application -> Connection -> SockAddr-> IO ()+serveConnection settings th port app conn remoteHost' =+ runResourceT serveConnection'+ where+ 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+ res <- app env++ liftIO $ T.resume th+ keepAlive <- sendResponse th 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
@@ -0,0 +1,52 @@+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'+ }++-- | 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+ }+ where+ go :: InvalidRequest -> IO ()+ go _ = return ()+ go' (Just ThreadKilled) = False+ go' _ = True
+ Network/Wai/Handler/Warp/Timeout.hs view
@@ -0,0 +1,80 @@+module Network.Wai.Handler.Warp.Timeout (+ Manager+ , Handle+ , initialize+ , register+ , registerKillThread+ , tickle+ , pause+ , resume+ , cancel+ , withManager+ ) where++import Control.Concurrent (forkIO, threadDelay, myThreadId, killThread)+import qualified Control.Exception as E+import Control.Monad (forever)+import Control.Monad (void)+import qualified Data.IORef as I++-- FIXME implement stopManager++-- | A timeout manager+newtype Manager = Manager (I.IORef [Handle])++-- | A handle used by 'Manager'+data Handle = Handle (IO ()) (I.IORef State)++data State = Active | Inactive | Paused | Canceled++initialize :: Int -> IO Manager+initialize timeout = do+ ref <- I.newIORef []+ void . forkIO $ forever $ do+ threadDelay timeout+ ms <- I.atomicModifyIORef ref (\x -> ([], x))+ ms' <- go ms id+ I.atomicModifyIORef ref (\x -> (ms' x, ()))+ return $ Manager ref+ where+ go [] front = return front+ go (m@(Handle onTimeout iactive):rest) front = do+ state <- I.atomicModifyIORef iactive (\x -> (go' x, x))+ case state of+ Inactive -> do+ onTimeout `E.catch` ignoreAll+ go rest front+ Canceled -> go rest front+ _ -> go rest (front . (:) m)+ go' Active = Inactive+ go' x = x++ignoreAll :: E.SomeException -> IO ()+ignoreAll _ = return ()++register :: Manager -> IO () -> IO Handle+register (Manager ref) onTimeout = do+ iactive <- I.newIORef Active+ let h = Handle onTimeout iactive+ I.atomicModifyIORef ref (\x -> (h : x, ()))+ return h++registerKillThread :: Manager -> IO Handle+registerKillThread m = do+ tid <- myThreadId+ register m $ killThread tid++tickle, pause, resume, cancel :: Handle -> IO ()+tickle (Handle _ iactive) = I.writeIORef iactive Active+pause (Handle _ iactive) = I.writeIORef iactive Paused+resume = tickle+cancel (Handle _ iactive) = I.writeIORef iactive Canceled++-- | Call the inner function with a timeout manager.+withManager :: Int -- ^ timeout in microseconds+ -> (Manager -> IO a)+ -> IO a+withManager timeout f = do+ -- FIXME when stopManager is available, use it+ man <- initialize timeout+ f man
+ Network/Wai/Handler/Warp/Types.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-}++module Network.Wai.Handler.Warp.Types where++import Control.Exception+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as B+import Data.Typeable (Typeable)+import Data.Version (showVersion)+import Network.HTTP.Types.Header+import qualified Paths_warp++----------------------------------------------------------------++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 :: [B.ByteString] -> IO ()+ , connSendAll :: B.ByteString -> IO ()+ , connSendFile :: FilePath -> Integer -> Integer -> IO () -> [ByteString] -> IO () -- ^ offset, length+ , connClose :: IO ()+ , connRecv :: IO B.ByteString+ }
− ReadInt.hs
@@ -1,58 +0,0 @@-{-# LANGUAGE OverloadedStrings, MagicHash, BangPatterns #-}---- Copyright : Erik de Castro Lopo <erikd@mega-nerd.com>--- License : BSD3--module 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 Data.Int (Int64)-import GHC.Prim-import GHC.Types--import qualified Data.ByteString.Char8 as B-import qualified Data.Char as C---- 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.--readInt64 :: ByteString -> Int64-readInt64 bs =- B.foldl' (\i c -> i * 10 + fromIntegral (mhDigitToInt c)) 0- $ B.takeWhile C.isDigit bs-{- NOINLINE readInt64MH #-}--data Table = Table !Addr#--{- NOINLINE mhDigitToInt #-}-mhDigitToInt :: Char -> Int-mhDigitToInt (C# i) = I# (word2Int# (indexWord8OffAddr# addr (ord# 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"#-
− Timeout.hs
@@ -1,66 +0,0 @@-module Timeout- ( Manager- , Handle- , initialize- , register- , registerKillThread- , tickle- , pause- , resume- , cancel- ) where--import qualified Data.IORef as I-import Control.Concurrent (forkIO, threadDelay, myThreadId, killThread)-import Control.Monad (forever)-import qualified Control.Exception as E---- FIXME implement stopManager---- | A timeout manager-newtype Manager = Manager (I.IORef [Handle])-data Handle = Handle (IO ()) (I.IORef State)-data State = Active | Inactive | Paused | Canceled--initialize :: Int -> IO Manager-initialize timeout = do- ref <- I.newIORef []- _ <- 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
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
− test/main.hs
@@ -1,298 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-import Network.Wai-import Network.Wai.Handler.Warp-import qualified Data.IORef as I-import Control.Monad.IO.Class (MonadIO, liftIO)-import Network.HTTP.Types-import Control.Concurrent (forkIO, killThread, threadDelay)-import Control.Monad (forM_)--import System.IO (hFlush, hClose)-import System.IO.Unsafe (unsafePerformIO)-import Data.ByteString (ByteString, hPutStr, hGetSome)-import qualified Data.ByteString as S-import qualified Data.ByteString.Lazy as L-import Network (connectTo, PortID (PortNumber))--import Test.Hspec.Monadic-import Test.Hspec.HUnit ()-import Test.HUnit--import Data.Conduit (($$))-import qualified Data.Conduit.List--type Counter = I.IORef (Either String Int)-type CounterApplication = Counter -> Application--incr :: MonadIO m => Counter -> m ()-incr icount = liftIO $ I.atomicModifyIORef icount $ \ecount ->- ((case ecount of- Left s -> Left s- Right i -> Right $ i + 1), ())--err :: (MonadIO m, Show a) => Counter -> a -> m ()-err icount msg = liftIO $ I.writeIORef icount $ Left $ show msg--readBody :: CounterApplication-readBody icount req = do- body <- requestBody req $$ Data.Conduit.List.consume- case () of- ()- | pathInfo req == ["hello"] && L.fromChunks body /= "Hello"- -> err icount ("Invalid hello" :: String, body)- | requestMethod req == "GET" && L.fromChunks body /= ""- -> err icount ("Invalid GET" :: String, body)- | not $ requestMethod req `elem` ["GET", "POST"]- -> err icount ("Invalid request method (readBody)" :: String, requestMethod req)- | otherwise -> incr icount- return $ responseLBS status200 [] "Read the body"--ignoreBody :: CounterApplication-ignoreBody icount req = do- if (requestMethod req `elem` ["GET", "POST"])- then incr icount- else err icount ("Invalid request method" :: String, requestMethod req)- return $ responseLBS status200 [] "Ignored the body"--doubleConnect :: CounterApplication-doubleConnect icount req = do- _ <- requestBody req $$ Data.Conduit.List.consume- _ <- requestBody req $$ Data.Conduit.List.consume- incr icount- return $ responseLBS status200 [] "double connect"--nextPort :: I.IORef Int-nextPort = unsafePerformIO $ I.newIORef 5000--getPort :: IO Int-getPort = I.atomicModifyIORef nextPort $ \p -> (p + 1, p)--runTest :: Int -- ^ expected number of requests- -> CounterApplication- -> [ByteString] -- ^ chunks to send- -> IO ()-runTest expected app chunks = do- port <- getPort- ref <- I.newIORef (Right 0)- tid <- forkIO $ run port $ app ref- threadDelay 1000- handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port- forM_ chunks $ \chunk -> hPutStr handle chunk >> hFlush handle- _ <- hGetSome handle 4096- threadDelay 1000- killThread tid- res <- I.readIORef ref- case res of- Left s -> error s- Right i -> i @?= expected--dummyApp :: Application-dummyApp _ = return $ responseLBS status200 [] "foo"--runTerminateTest :: InvalidRequest- -> ByteString- -> IO ()-runTerminateTest expected input = do- port <- getPort- ref <- I.newIORef Nothing- tid <- forkIO $ runSettings defaultSettings- { settingsOnException = \e -> I.writeIORef ref $ Just e- , settingsPort = port- } dummyApp- threadDelay 1000- handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port- hPutStr handle input- hFlush handle- hClose handle- threadDelay 1000- killThread tid- res <- I.readIORef ref- show res @?= show (Just expected)--singleGet :: ByteString-singleGet = "GET / HTTP/1.1\r\nHost: localhost\r\n\r\n"--singlePostHello :: ByteString-singlePostHello = "POST /hello HTTP/1.1\r\nHost: localhost\r\nContent-length: 5\r\n\r\nHello"--main :: IO ()-main = hspec $ do- describe "non-pipelining" $ do- it "no body, read" $ runTest 5 readBody $ replicate 5 singleGet- it "no body, ignore" $ runTest 5 ignoreBody $ replicate 5 singleGet- it "has body, read" $ runTest 2 readBody- [ singlePostHello- , singleGet- ]- it "has body, ignore" $ runTest 2 ignoreBody- [ singlePostHello- , singleGet- ]- describe "pipelining" $ do- it "no body, read" $ runTest 5 readBody [S.concat $ replicate 5 singleGet]- it "no body, ignore" $ runTest 5 ignoreBody [S.concat $ replicate 5 singleGet]- it "has body, read" $ runTest 2 readBody $ return $ S.concat- [ singlePostHello- , singleGet- ]- it "has body, ignore" $ runTest 2 ignoreBody $ return $ S.concat- [ singlePostHello- , singleGet- ]- describe "no hanging" $ do- it "has body, read" $ runTest 1 readBody $ map S.singleton $ S.unpack singlePostHello- it "double connect" $ runTest 1 doubleConnect [singlePostHello]-- describe "connection termination" $ do- it "ConnectionClosedByPeer" $ runTerminateTest ConnectionClosedByPeer "GET / HTTP/1.1\r\ncontent-length: 10\r\n\r\nhello"- it "IncompleteHeaders" $ runTerminateTest IncompleteHeaders "GET / HTTP/1.1\r\ncontent-length: 10\r\n"-- describe "special input" $ do- it "multiline headers" $ do- iheaders <- I.newIORef []- port <- getPort- tid <- forkIO $ run port $ \req -> do- liftIO $ I.writeIORef iheaders $ requestHeaders req- return $ responseLBS status200 [] ""- threadDelay 1000- handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port- let input = S.concat- [ "GET / HTTP/1.1\r\nfoo: bar\r\n baz\r\n\tbin\r\n\r\n"- ]- hPutStr handle input- hFlush handle- hClose handle- threadDelay 1000- killThread tid- headers <- I.readIORef iheaders- headers @?=- [ ("foo", "bar baz\tbin")- ]- it "no space between colon and value" $ do- iheaders <- I.newIORef []- port <- getPort- tid <- forkIO $ run port $ \req -> do- liftIO $ I.writeIORef iheaders $ requestHeaders req- return $ responseLBS status200 [] ""- threadDelay 1000- handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port- let input = S.concat- [ "GET / HTTP/1.1\r\nfoo:bar\r\n\r\n"- ]- hPutStr handle input- hFlush handle- hClose handle- threadDelay 1000- killThread tid- headers <- I.readIORef iheaders- headers @?=- [ ("foo", "bar")- ]- it "extra spaces in first line" $ do- iheaders <- I.newIORef []- port <- getPort- tid <- forkIO $ run port $ \req -> do- liftIO $ I.writeIORef iheaders $ requestHeaders req- return $ responseLBS status200 [] ""- threadDelay 1000- handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port- let input = S.concat- [ "GET / HTTP/1.1\r\nfoo: bar\r\n\r\n"- ]- hPutStr handle input- hFlush handle- hClose handle- threadDelay 1000- killThread tid- headers <- I.readIORef iheaders- headers @?=- [ ("foo", "bar")- ]- it "spaces in http version" $ do- iversion <- I.newIORef $ error "Version not parsed"- port <- getPort- tid <- forkIO $ run port $ \req -> do- liftIO $ I.writeIORef iversion $ httpVersion req- return $ responseLBS status200 [] ""- threadDelay 1000- handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port- let input = S.concat- [ "GET / HTTP\t/ 1 . 1 \r\nfoo: bar\r\n\r\n"- ]- hPutStr handle input- hFlush handle- hClose handle- threadDelay 1000- killThread tid- version <- I.readIORef iversion- version @?= http11-- describe "chunked bodies" $ do- it "works" $ do- ifront <- I.newIORef id- port <- getPort- tid <- forkIO $ run port $ \req -> do- bss <- requestBody req $$ Data.Conduit.List.consume- liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())- return $ responseLBS status200 [] ""- threadDelay 1000- handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port- let input = S.concat- [ "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"- , "c\r\nHello World\n\r\n3\r\nBye\r\n0\r\n"- , "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"- , "b\r\nHello World\r\n0\r\n"- ]- hPutStr handle input- hFlush handle- hClose handle- threadDelay 1000- killThread tid- front <- I.readIORef ifront- front [] @?=- [ "Hello World\nBye"- , "Hello World"- ]- it "lots of chunks" $ do- ifront <- I.newIORef id- port <- getPort- tid <- forkIO $ run port $ \req -> do- bss <- requestBody req $$ Data.Conduit.List.consume- liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())- return $ responseLBS status200 [] ""- threadDelay 1000- handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port- let input = concat $ replicate 2 $- ["POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"] ++- (replicate 50 "5\r\n12345\r\n") ++- ["0\r\n"]- mapM_ (\bs -> hPutStr handle bs >> hFlush handle) input- hClose handle- threadDelay 1000- killThread tid- front <- I.readIORef ifront- front [] @?= replicate 2 (S.concat $ replicate 50 "12345")- it "in chunks" $ do- ifront <- I.newIORef id- port <- getPort- tid <- forkIO $ run port $ \req -> do- bss <- requestBody req $$ Data.Conduit.List.consume- liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())- return $ responseLBS status200 [] ""- threadDelay 1000- handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port- let input = S.concat- [ "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"- , "c\r\nHello World\n\r\n3\r\nBye\r\n0\r\n"- , "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"- , "b\r\nHello World\r\n0\r\n"- ]- mapM_ (\bs -> hPutStr handle bs >> hFlush handle) $ map S.singleton $ S.unpack input- hClose handle- threadDelay 1000- killThread tid- front <- I.readIORef ifront- front [] @?=- [ "Hello World\nBye"- , "Hello World"- ]
warp.cabal view
@@ -1,5 +1,5 @@ Name: warp-Version: 1.3.0.1+Version: 1.3.1 Synopsis: A fast, light-weight web server for WAI applications. License: MIT License-file: LICENSE@@ -11,56 +11,72 @@ 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/>.-extra-source-files: test/main.hs -flag network-bytestring+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- , wai >= 1.3 && < 1.4- , transformers >= 0.2.2 && < 0.4+ , case-insensitive >= 0.2 , conduit >= 0.5 && < 0.6- , network-conduit >= 0.5 && < 0.6- , blaze-builder-conduit >= 0.5 && < 0.6+ , ghc-prim+ , http-types >= 0.7 && < 0.8 , lifted-base >= 0.1 && < 0.2- , blaze-builder >= 0.2.1.4 && < 0.4+ , network-conduit >= 0.5 && < 0.6 , simple-sendfile >= 0.2.4 && < 0.3- , http-types >= 0.7 && < 0.8- , case-insensitive >= 0.2+ , transformers >= 0.2.2 && < 0.4 , unix-compat >= 0.2- , ghc-prim+ , void+ , wai >= 1.3 && < 1.4 if flag(network-bytestring)- build-depends: network >= 2.2.1.5 && < 2.2.3+ Build-Depends: network >= 2.2.1.5 && < 2.2.3 , network-bytestring >= 0.1.3 && < 0.1.4 else- build-depends: network >= 2.3 && < 2.4+ Build-Depends: network >= 2.3 && < 2.4 Exposed-modules: Network.Wai.Handler.Warp- Other-modules: Timeout- ReadInt+ 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+ Ghc-Options: -Wall if os(windows)- Cpp-options: -DWINDOWS+ Cpp-options: -DWINDOWS -test-suite test- main-is: main.hs- hs-source-dirs: test- type: exitcode-stdio-1.0+Test-Suite spec+ Main-Is: Spec.hs+ Hs-Source-Dirs: test, .+ Type: exitcode-stdio-1.0 - ghc-options: -Wall- build-depends: base >= 4 && < 5- , HUnit- , hspec- , bytestring- , warp- , conduit- , network- , http-types- , transformers- , wai+ 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 && < 0.2+ , network-conduit >= 0.5 && < 0.6+ , 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 -source-repository head- type: git- location: git://github.com/yesodweb/wai.git+Source-Repository head+ Type: git+ Location: git://github.com/yesodweb/wai.git