diff --git a/Network/Wai/Handler/Warp.hs b/Network/Wai/Handler/Warp.hs --- a/Network/Wai/Handler/Warp.hs +++ b/Network/Wai/Handler/Warp.hs @@ -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(..)) diff --git a/Network/Wai/Handler/Warp/Conduit.hs b/Network/Wai/Handler/Warp/Conduit.hs new file mode 100644 --- /dev/null +++ b/Network/Wai/Handler/Warp/Conduit.hs @@ -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 diff --git a/Network/Wai/Handler/Warp/ReadInt.hs b/Network/Wai/Handler/Warp/ReadInt.hs new file mode 100644 --- /dev/null +++ b/Network/Wai/Handler/Warp/ReadInt.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE OverloadedStrings, MagicHash, 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.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"# + diff --git a/Network/Wai/Handler/Warp/Request.hs b/Network/Wai/Handler/Warp/Request.hs new file mode 100644 --- /dev/null +++ b/Network/Wai/Handler/Warp/Request.hs @@ -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 diff --git a/Network/Wai/Handler/Warp/Response.hs b/Network/Wai/Handler/Warp/Response.hs new file mode 100644 --- /dev/null +++ b/Network/Wai/Handler/Warp/Response.hs @@ -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 diff --git a/Network/Wai/Handler/Warp/ResponseHeader.hs b/Network/Wai/Handler/Warp/ResponseHeader.hs new file mode 100644 --- /dev/null +++ b/Network/Wai/Handler/Warp/ResponseHeader.hs @@ -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 + + diff --git a/Network/Wai/Handler/Warp/Run.hs b/Network/Wai/Handler/Warp/Run.hs new file mode 100644 --- /dev/null +++ b/Network/Wai/Handler/Warp/Run.hs @@ -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 diff --git a/Network/Wai/Handler/Warp/Settings.hs b/Network/Wai/Handler/Warp/Settings.hs new file mode 100644 --- /dev/null +++ b/Network/Wai/Handler/Warp/Settings.hs @@ -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 diff --git a/Network/Wai/Handler/Warp/Timeout.hs b/Network/Wai/Handler/Warp/Timeout.hs new file mode 100644 --- /dev/null +++ b/Network/Wai/Handler/Warp/Timeout.hs @@ -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 diff --git a/Network/Wai/Handler/Warp/Types.hs b/Network/Wai/Handler/Warp/Types.hs new file mode 100644 --- /dev/null +++ b/Network/Wai/Handler/Warp/Types.hs @@ -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 + } diff --git a/ReadInt.hs b/ReadInt.hs deleted file mode 100644 --- a/ReadInt.hs +++ /dev/null @@ -1,58 +0,0 @@ -{-# LANGUAGE OverloadedStrings, MagicHash, BangPatterns #-} - --- Copyright : Erik de Castro Lopo --- 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"# - diff --git a/Timeout.hs b/Timeout.hs deleted file mode 100644 --- a/Timeout.hs +++ /dev/null @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/main.hs b/test/main.hs deleted file mode 100644 --- a/test/main.hs +++ /dev/null @@ -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" - ] diff --git a/warp.cabal b/warp.cabal --- a/warp.cabal +++ b/warp.cabal @@ -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 . -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