@@ -1,11 +1,5 @@
1−{-# LANGUAGE DeriveDataTypeable #-}
2−{-# LANGUAGE FlexibleContexts #-}
3−{-# LANGUAGE OverloadedStrings #-}
4{-# LANGUAGE CPP #-}
1{-# LANGUAGE CPP #-}
5−{-# LANGUAGE BangPatterns #-}
2+
6−{-# LANGUAGE MagicHash #-}
7−{-# LANGUAGE ScopedTypeVariables #-}
8−{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
9---------------------------------------------------------
3---------------------------------------------------------
11-- Module : Network.Wai.Handler.Warp
5-- Module : Network.Wai.Handler.Warp
@@ -21,816 +15,53 @@
21---------------------------------------------------------
15---------------------------------------------------------
23-- | A fast, light-weight HTTP server handler for WAI.
17-- | A fast, light-weight HTTP server handler for WAI.
24−module Network.Wai.Handler.Warp
18+module Network.Wai.Handler.Warp (
25− ( -- * Run a Warp server
19+ -- * Run a Warp server
27− , runSettings
21+ , runSettings
28− , runSettingsSocket
22+ , runSettingsSocket
29− -- * Settings
23+ -- * Settings
30− , Settings
24+ , Settings
31− , defaultSettings
25+ , defaultSettings
32− , settingsPort
26+ , settingsPort
33− , settingsHost
27+ , settingsHost
34− , settingsOnException
28+ , settingsOnException
35− , settingsOnOpen
29+ , settingsOnOpen
36− , settingsOnClose
30+ , settingsOnClose
37− , settingsTimeout
31+ , settingsTimeout
38− , settingsIntercept
32+ , settingsIntercept
39− , settingsManager
33+ , settingsManager
40− -- ** Data types
34+ -- ** Data types
41− , HostPreference (..)
35+ , HostPreference (..)
42− -- * Connection
36+ -- * Connection
43− , Connection (..)
37+ , Connection (..)
44− , runSettingsConnection
38+ , runSettingsConnection
45− -- * Datatypes
39+ -- * Datatypes
47− , InvalidRequest (..)
41+ , InvalidRequest (..)
48− -- * Internal
42+ -- * Internal
49− , Manager
43+ , Manager
50− , withManager
44+ , withManager
51− , parseRequest
45+ , parseRequest
52− , sendResponse
46+ , sendResponse
53− , registerKillThread
47+ , registerKillThread
56− , T.cancel
50+ , cancel
57− , T.register
51+ , register
58− , T.initialize
52+ , initialize
59− , socketConnection
53+ , socketConnection
61− , takeHeaders
55+ , takeHeaders
62− , parseFirst
56+ , parseFirst
63− , readInt
57+ , readInt
67−import Prelude hiding (lines, catch)
70−import Data.ByteString (ByteString)
71−import qualified Data.ByteString as S
72−import qualified Data.ByteString.Unsafe as SU
73−import qualified Data.ByteString.Char8 as B
74−import qualified Data.ByteString.Lazy as L
75−import Network (sClose, Socket)
76−import Network.Socket (accept, SockAddr)
77−import qualified Network.Socket.ByteString as Sock
78−import Control.Exception
79− ( mask, catch, handle, onException, bracket
80− , Exception, SomeException, IOException, AsyncException (ThreadKilled)
81− , fromException, toException
83−#if __GLASGOW_HASKELL__ >= 702
92−import Control.Concurrent (forkIO, threadDelay)
93−import Data.Maybe (fromMaybe, isJust)
94−import Data.Char (toLower, isHexDigit)
95−import Data.Word (Word)
97−import Data.Typeable (Typeable)
100−import Data.Conduit.Internal (ResumableSource (..))
101−import qualified Data.Conduit.List as CL
102−import qualified Data.Conduit.Binary as CB
103−import Data.Conduit.Blaze (builderToByteString)
104−import Control.Exception.Lifted (throwIO)
105−import Blaze.ByteString.Builder.HTTP
106− (chunkedTransferEncoding, chunkedTransferTerminator)
107−import Blaze.ByteString.Builder
108− (copyByteString, Builder, toLazyByteString, toByteStringIO, flush)
109−import Blaze.ByteString.Builder.Char8 (fromChar, fromShow)
110−import Data.Monoid (mappend, mempty)
111−import Network.Sendfile
113−import qualified System.PosixCompat.Files as P
115−import Control.Monad.IO.Class (MonadIO, liftIO)
116−import Control.Monad.Trans.Class (lift)
117−import qualified Timeout as T
118−import Timeout (Manager, registerKillThread, pause, resume)
119−import Data.Word (Word8)
120−import Data.List (foldl')
121−import Control.Monad (forever, when, void)
122−import qualified Network.HTTP.Types as H
123−import qualified Data.CaseInsensitive as CI
124−import System.IO (hPrint, stderr)
125−import ReadInt (readInt64)
126−import qualified Data.IORef as I
127−import Data.Conduit.Network (bindPort, HostPreference (HostIPv4))
130−import qualified Control.Concurrent.MVar as MV
131−import Network.Socket (withSocketsDo)
134−import Data.Version (showVersion)
135−import qualified Paths_warp
137−warpVersion :: String
138−warpVersion = showVersion Paths_warp.version
140−#if __GLASGOW_HASKELL__ < 702
141−allowInterrupt :: IO ()
142−allowInterrupt = unblock $ return ()
147−-- In order to provide slowloris protection, Warp provides timeout handlers. We
148−-- follow these rules:
150−-- * A timeout is created when a connection is opened.
152−-- * When all request headers are read, the timeout is tickled.
154−-- * Every time at least 2048 bytes of the request body are read, the timeout
157−-- * The timeout is paused while executing user code. This will apply to both
158−-- the application itself, and a ResponseSource response. The timeout is
159−-- resumed as soon as we return from user code.
161−-- * Every time data is successfully sent to the client, the timeout is tickled.
162−data Connection = Connection
163− { connSendMany :: [B.ByteString] -> IO ()
164− , connSendAll :: B.ByteString -> IO ()
165− , connSendFile :: FilePath -> Integer -> Integer -> IO () -> [ByteString] -> IO () -- ^ offset, length
166− , connClose :: IO ()
167− , connRecv :: IO B.ByteString
170−socketConnection :: Socket -> Connection
171−socketConnection s = Connection
172− { connSendMany = Sock.sendMany s
173− , connSendAll = Sock.sendAll s
174− , connSendFile = \fp off len act hdr -> sendfileWithHeader s fp (PartOfFile off len) act hdr
175− , connClose = sClose s
176− , connRecv = Sock.recv s bytesPerRead
179−-- | Run an 'Application' on the given port. This calls 'runSettings' with
180−-- 'defaultSettings'.
181−run :: Port -> Application -> IO ()
182−run p = runSettings defaultSettings { settingsPort = p }
184−-- | Run a Warp server with the given settings.
185−runSettings :: Settings -> Application -> IO ()
187−runSettings set app = withSocketsDo $ do
188− var <- MV.newMVar Nothing
189− let clean = MV.modifyMVar_ var $ \s -> maybe (return ()) sClose s >> return Nothing
190− _ <- forkIO $ bracket
191− (bindPort (settingsPort set) (settingsHost set))
194− MV.modifyMVar_ var (\_ -> return $ Just s)
195− runSettingsSocket set s app)
196− forever (threadDelay maxBound) `finally` clean
200− (bindPort (settingsPort set) (settingsHost set))
202− flip (runSettingsSocket set)
206−
61+import Network.Wai.Handler.Warp.Request
207−-- | Same as 'runSettings', but uses a user-supplied socket instead of opening
62+import Network.Wai.Handler.Warp.Response
208−-- one. This allows the user to provide, for example, Unix named socket, which
63+import Network.Wai.Handler.Warp.Run
209−-- can be used when reverse HTTP proxying into your application.
64+import Network.Wai.Handler.Warp.Settings
210−--
65+import Network.Wai.Handler.Warp.Types
211−-- Note that the 'settingsPort' will still be passed to 'Application's via the
66+import Network.Wai.Handler.Warp.Timeout
212−-- 'serverPort' record.
67+import Data.Conduit.Network (HostPreference(..))
213−runSettingsSocket :: Settings -> Socket -> Application -> IO ()
214−runSettingsSocket set socket app =
215− runSettingsConnection set getter app
218− (conn, sa) <- accept socket
219− return (socketConnection conn, sa)
221−runSettingsConnection :: Settings -> IO (Connection, SockAddr) -> Application -> IO ()
222−runSettingsConnection set getConn app = do
223− tm <- maybe (T.initialize $ settingsTimeout set * 1000000) return
224− $ settingsManager set
225− mask $ \restore -> forever $ do
227− (conn, addr) <- getConnLoop
229− th <- T.registerKillThread tm
230− handle onE $ (do onOpen
231− restore $ serveConnection set th port app conn addr
232− connClose conn >> T.cancel th >> onClose
233− ) `onException` (T.cancel th >> connClose conn >> onClose)
235− -- FIXME: only IOEception is caught. What about other exceptions?
236− getConnLoop = getConn `catch` \(e :: IOException) -> do
238− -- "resource exhausted (Too many open files)" may happen by accept().
239− -- Wait a second hoping that resource will be available.
242− onE = settingsOnException set
243− port = settingsPort set
244− onOpen = settingsOnOpen set
245− onClose = settingsOnClose set
247−-- | Contains a @Source@ and a byte count that is still to be read in.
248−newtype IsolatedBSSource = IsolatedBSSource (I.IORef (Int, ResumableSource (ResourceT IO) ByteString))
250−-- | Given an @IsolatedBSSource@ provide a @Source@ that only allows up to the
251−-- specified number of bytes to be passed downstream. All leftovers should be
252−-- retained within the @Source@. If there are not enough bytes available,
253−-- throws a @ConnectionClosedByPeer@ exception.
254−ibsIsolate :: IsolatedBSSource -> Source (ResourceT IO) ByteString
255−ibsIsolate ibs@(IsolatedBSSource ref) = do
256− (count, src) <- liftIO $ I.readIORef ref
258− -- No more bytes wanted downstream, so we're done.
261− -- Get the next chunk (if available) and the updated source
262− (src', mbs) <- lift $ src $$++ CL.head
264− -- If no chunk available, then there aren't enough bytes in the
265− -- stream. Throw a ConnectionClosedByPeer
266− bs <- maybe (liftIO $ throwIO ConnectionClosedByPeer) return mbs
268− let -- How many of the bytes in this chunk to send downstream
269− toSend = min count (S.length bs)
270− -- How many bytes will still remain to be sent downstream
271− count' = count - toSend
274− -- The expected count is greater than the size of the
275− -- chunk we just read. Send the entire chunk
276− -- downstream, and then loop on this function for the
279− liftIO $ I.writeIORef ref (count', src')
283− -- The expected count is the total size of the chunk we
284− -- just read. Send this chunk downstream, and then
285− -- terminate the stream.
286− | count == S.length bs -> do
287− liftIO $ I.writeIORef ref (count', src')
290− -- Some of the bytes in this chunk should not be sent
291− -- downstream. Split up the chunk into the sent and
292− -- not-sent parts, add the not-sent parts onto the new
293− -- source, and send the rest of the chunk downstream.
295− let (x, y) = S.splitAt toSend bs
296− liftIO $ I.writeIORef ref (count', fmapResume (yield y >>) src')
299−-- | Extract the underlying @Source@ from an @IsolatedBSSource@, which will not
300−-- perform any more isolation.
301−ibsDone :: IsolatedBSSource -> IO (ResumableSource (ResourceT IO) ByteString)
302−ibsDone (IsolatedBSSource ref) = fmap snd $ I.readIORef ref
304−serveConnection :: Settings
306− -> Port -> Application -> Connection -> SockAddr-> IO ()
307−serveConnection settings th port app conn remoteHost' =
308− runResourceT serveConnection'
310− serveConnection' :: ResourceT IO ()
311− serveConnection' = do
312− let fromClient = connSource conn th
313− serveConnection'' fromClient
315− serveConnection'' fromClient = do
316− (env, getSource) <- parseRequest conn port remoteHost' fromClient
317− case settingsIntercept settings env of
319− -- Let the application run for as long as it wants
323− liftIO $ T.resume th
324− keepAlive <- sendResponse th env conn res
326− -- flush the rest of the request body
327− requestBody env $$ CL.sinkNull
328− ResumableSource fromClient' _ <- liftIO getSource
330− when keepAlive $ serveConnection'' fromClient'
331− Just intercept -> do
333− ResumableSource fromClient' _ <- liftIO getSource
334− intercept fromClient' conn
336−parseRequest :: Connection -> Port -> SockAddr
337− -> Source (ResourceT IO) S.ByteString
338− -> ResourceT IO (Request, IO (ResumableSource (ResourceT IO) ByteString))
339−parseRequest conn port remoteHost' src1 = do
340− (src2, headers') <- src1 $$+ takeHeaders
341− parseRequest' conn port headers' remoteHost' src2
343−-- FIXME come up with good values here
344−bytesPerRead, maxTotalHeaderLength :: Int
346−maxTotalHeaderLength = 50 * 1024
348−data InvalidRequest =
349− NotEnoughLines [String]
350− | BadFirstLine String
353− | ConnectionClosedByPeer
355− deriving (Show, Typeable, Eq)
356−instance Exception InvalidRequest
358−handleExpect :: Connection
360− -> ([H.Header] -> [H.Header])
363−handleExpect _ _ front [] = return $ front []
364−handleExpect conn hv front (("expect", "100-continue"):rest) = do
367− then "HTTP/1.1 100 Continue\r\n\r\n"
368− else "HTTP/1.0 100 Continue\r\n\r\n"
370−handleExpect conn hv front (x:xs) = handleExpect conn hv (front . (x:)) xs
372−-- | Parse a set of header lines and body into a 'Request'.
373−parseRequest' :: Connection
377− -> ResumableSource (ResourceT IO) S.ByteString -- FIXME was buffered
378− -> ResourceT IO (Request, IO (ResumableSource (ResourceT IO) ByteString))
379−parseRequest' _ _ [] _ _ = throwIO $ NotEnoughLines []
380−parseRequest' conn port (firstLine:otherLines) remoteHost' src = do
381− (method, rpath', gets, httpversion) <- parseFirst firstLine
383− | S.null rpath' = ("", "/")
384− | "http://" `S.isPrefixOf` rpath' = S.breakByte 47 $ S.drop 7 rpath'
385− | otherwise = ("", rpath')
387− $ handleExpect conn httpversion id
388− (map parseHeaderNoAttr otherLines)
389− let host = fromMaybe host' $ lookup "host" heads
391− case lookup "content-length" heads of
393− Just bs -> readInt bs
394− let serverName' = takeUntil 58 host -- ':'
395− let chunked = maybe False ((== "chunked") . B.map toLower)
396− $ lookup "transfer-encoding" heads
397− (rbody, getSource) <- liftIO $
400− ref <- I.newIORef (src, NeedLen)
401− return (chunkedSource ref, fmap fst $ I.readIORef ref)
403− ibs <- fmap IsolatedBSSource $ I.newIORef (len0, src)
404− return (ibsIsolate ibs, ibsDone ibs)
407− { requestMethod = method
408− , httpVersion = httpversion
409− , pathInfo = H.decodePathSegments rpath
410− , rawPathInfo = rpath
411− , rawQueryString = gets
412− , queryString = H.parseQuery gets
413− , serverName = serverName'
415− , requestHeaders = heads
417− , remoteHost = remoteHost'
418− , requestBody = rbody
422−data ChunkState = NeedLen
426−chunkedSource :: MonadIO m
427− => I.IORef (ResumableSource m ByteString, ChunkState)
428− -> Source m ByteString
429−chunkedSource ipair = do
430− (src, mlen) <- liftIO $ I.readIORef ipair
434− (src', (len, bs)) <- lift $ src $$++ front getLen
437− | otherwise = fmapResume (yield bs >>) src'
438− go src'' $ HaveLen len
440− go src NeedLen = go' src id
441− go src NeedLenNewline = go' src (CB.take 2 >>)
442− go src (HaveLen 0) = liftIO $ I.writeIORef ipair (src, HaveLen 0)
443− go src (HaveLen len) = do
444− (src', mbs) <- lift $ src $$++ CL.head
446− Nothing -> liftIO $ I.writeIORef ipair (src', HaveLen 0)
448− case S.length bs `compare` fromIntegral len of
449− EQ -> yield' src' NeedLenNewline bs
451− let mlen = HaveLen $ len - fromIntegral (S.length bs)
454− let (x, y) = S.splitAt (fromIntegral len) bs
455− let src'' = fmapResume (yield y >>) src'
456− yield' src'' NeedLenNewline x
458− yield' src mlen bs = do
459− liftIO $ I.writeIORef ipair (src, mlen)
463− getLen :: Monad m => Sink ByteString m (Word, ByteString)
467− Nothing -> return (0, S.empty)
470− case S.breakByte 10 bs of
475− Nothing -> return (x, y)
476− Just bs2 -> return $ S.breakByte 10 $ bs `S.append` bs2
477− | otherwise -> return (x, y)
479− S.foldl' (\i c -> i * 16 + fromIntegral (hexToWord c)) 0
480− $ B.takeWhile isHexDigit x
481− return (w, S.drop 1 y)
486− | otherwise = w - 87
488−takeUntil :: Word8 -> ByteString -> ByteString
490− case S.elemIndex c bs of
491− Just !idx -> SU.unsafeTake idx bs
493−{-# INLINE takeUntil #-}
495−parseFirst :: ByteString
496− -> ResourceT IO (ByteString, ByteString, ByteString, H.HttpVersion)
498− case filter (not . S.null) $ S.splitWith (\c -> c == 32 || c == 9) s of -- ' '
499− (method:query:http'') -> do
500− let http' = S.concat http''
501− (hfirst, hsecond) = B.splitAt 5 http'
502− if hfirst == "HTTP/"
503− then let (rpath, qstring) = S.breakByte 63 query -- '?'
508− in return (method, rpath, qstring, hv)
509− else throwIO NonHttp
510− _ -> throwIO $ BadFirstLine $ B.unpack s
511−{-# INLINE parseFirst #-} -- FIXME is this inline necessary? the function is only called from one place and not exported
513−httpBuilder, spaceBuilder, newlineBuilder, transferEncodingBuilder
514− , colonSpaceBuilder :: Builder
515−httpBuilder = copyByteString "HTTP/"
516−spaceBuilder = fromChar ' '
517−newlineBuilder = copyByteString "\r\n"
518−transferEncodingBuilder = copyByteString "Transfer-Encoding: chunked\r\n\r\n"
519−colonSpaceBuilder = copyByteString ": "
521−headers :: H.HttpVersion -> H.Status -> H.ResponseHeaders -> Bool -> Builder
522−headers !httpversion !status !responseHeaders !isChunked' = {-# SCC "headers" #-}
523− let !start = httpBuilder
524− `mappend` copyByteString
525− (case httpversion of
526− H.HttpVersion 1 1 -> "1.1"
528− `mappend` spaceBuilder
529− `mappend` fromShow (H.statusCode status)
530− `mappend` spaceBuilder
531− `mappend` copyByteString (H.statusMessage status)
532− `mappend` newlineBuilder
533− !start' = foldl' responseHeaderToBuilder start (serverHeader responseHeaders)
534− !end = if isChunked'
535− then transferEncodingBuilder
537− in start' `mappend` end
539−responseHeaderToBuilder :: Builder -> H.Header -> Builder
540−responseHeaderToBuilder b (x, y) = b
541− `mappend` copyByteString (CI.original x)
542− `mappend` colonSpaceBuilder
543− `mappend` copyByteString y
544− `mappend` newlineBuilder
546−checkPersist :: Request -> Bool
548− | ver == H.http11 = checkPersist11 conn
549− | otherwise = checkPersist10 conn
551− ver = httpVersion req
552− conn = lookup "connection" $ requestHeaders req
553− checkPersist11 (Just x)
554− | CI.foldCase x == "close" = False
555− checkPersist11 _ = True
556− checkPersist10 (Just x)
557− | CI.foldCase x == "keep-alive" = True
558− checkPersist10 _ = False
560−isChunked :: H.HttpVersion -> Bool
561−isChunked = (==) H.http11
563−hasBody :: H.Status -> Request -> Bool
564−hasBody s req = s /= H.Status 204 "" && s /= H.status304 &&
565− H.statusCode s >= 200 && requestMethod req /= "HEAD"
567−sendResponse :: T.Handle
568− -> Request -> Connection -> Response -> ResourceT IO Bool
569−sendResponse th req conn r = sendResponse' r
571− version = httpVersion req
572− isPersist = checkPersist req
573− isChunked' = isChunked version
574− needsChunked hs = isChunked' && not (hasLength hs)
575− isKeepAlive hs = isPersist && (isChunked' || hasLength hs)
576− hasLength hs = isJust $ lookup "content-length" hs
577− sendHeader = connSendMany conn . L.toChunks . toLazyByteString
579− sendResponse' :: Response -> ResourceT IO Bool
580− sendResponse' (ResponseFile s hs fp mpart) = do
582− case (readInt `fmap` lookup "content-length" hs, mpart) of
583− (Just cl, _) -> return $ Right (hs, cl)
584− (Nothing, Nothing) -> liftIO $ try $ do
585− cl <- P.fileSize `fmap` P.getFileStatus fp
586− return $ addClToHeaders cl
587− (Nothing, Just part) -> do
588− let cl = filePartByteCount part
589− return $ Right $ addClToHeaders cl
591− Left (_ :: SomeException) -> sendResponse' $ responseLBS
593− [("Content-Type", "text/plain")]
595− Right (lengthyHeaders, cl) -> liftIO $ do
596− let headers' = L.toChunks . toLazyByteString $ headers version s lengthyHeaders False
598− if hasBody s req then do
600− Nothing -> connSendFile conn fp 0 cl (T.tickle th) headers'
601− Just part -> connSendFile conn fp (filePartOffset part) (filePartByteCount part) (T.tickle th) headers'
607− addClToHeaders cl = (("Content-Length", B.pack $ show cl):hs, fromIntegral cl)
609− sendResponse' (ResponseBuilder s hs b)
610− | hasBody s req = liftIO $ do
611− toByteStringIO (\bs -> do
614− return (isKeepAlive hs)
615− | otherwise = liftIO $ do
616− sendHeader $ headers' False
620− headers' = headers version s hs
621− needsChunked' = needsChunked hs
622− body = if needsChunked'
623− then headers' needsChunked'
624− `mappend` chunkedTransferEncoding b
625− `mappend` chunkedTransferTerminator
626− else headers' False `mappend` b
628− sendResponse' (ResponseSource s hs bodyFlush)
629− | hasBody s req = do
630− let src = CL.sourceList [headers' needsChunked'] `mappend`
631− (if needsChunked' then body $= chunk else body)
632− src $$ builderToByteString =$ connSink conn th
633− return $ isKeepAlive hs
634− | otherwise = liftIO $ do
635− sendHeader $ headers' False
639− body = mapOutput (\x -> case x of
641− Chunk builder -> builder) bodyFlush
642− headers' = headers version s hs
643− -- FIXME perhaps alloca a buffer per thread and reuse that in all
644− -- functions below. Should lessen greatly the GC burden (I hope)
645− needsChunked' = needsChunked hs
646− chunk :: Conduit Builder (ResourceT IO) Builder
647− chunk = await >>= maybe (yield chunkedTransferTerminator) (\x -> yield (chunkedTransferEncoding x) >> chunk)
649−parseHeaderNoAttr :: ByteString -> H.Header
650−parseHeaderNoAttr s =
651− let (k, rest) = S.breakByte 58 s -- ':'
652− rest' = S.dropWhile (\c -> c == 32 || c == 9) $ S.drop 1 rest
655−connSource :: Connection -> T.Handle -> Source (ResourceT IO) ByteString
656−connSource Connection { connRecv = recv } th =
664− when (S.length bs >= 2048) $ liftIO $ T.tickle th
668−-- | Use 'connSendAll' to send this data while respecting timeout rules.
669−connSink :: Connection -> T.Handle -> Sink B.ByteString (ResourceT IO) ()
670−connSink Connection { connSendAll = send } th =
673− sink = await >>= maybe close push
674− close = liftIO (T.resume th)
676− liftIO $ T.resume th
680− -- We pause timeouts before passing control back to user code. This ensures
681− -- that a timeout will only ever be executed when Warp is in control. We
682− -- also make sure to resume the timeout after the completion of user code
683− -- so that we can kill idle connections.
685−------ The functions below are not warp-specific and could be split out into a
688−-- | Various Warp server settings. This is purposely kept as an abstract data
689−-- type so that new settings can be added without breaking backwards
690−-- compatibility. In order to create a 'Settings' value, use 'defaultSettings'
691−-- and record syntax to modify individual records. For example:
693−-- > defaultSettings { settingsTimeout = 20 }
694−data Settings = Settings
695− { settingsPort :: Int -- ^ Port to listen on. Default value: 3000
696− , settingsHost :: HostPreference -- ^ Default value: HostIPv4
697− , 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.
698− , settingsOnOpen :: IO () -- ^ What to do when a connection is open. Default: do nothing.
699− , settingsOnClose :: IO () -- ^ What to do when a connection is close. Default: do nothing.
700− , settingsTimeout :: Int -- ^ Timeout value in seconds. Default value: 30
701− , settingsIntercept :: Request -> Maybe (Source (ResourceT IO) S.ByteString -> Connection -> ResourceT IO ())
702− , settingsManager :: Maybe Manager -- ^ Use an existing timeout manager instead of spawning a new one. If used, 'settingsTimeout' is ignored. Default is 'Nothing'
705−-- | The default settings for the Warp server. See the individual settings for
706−-- the default value.
707−defaultSettings :: Settings
708−defaultSettings = Settings
709− { settingsPort = 3000
710− , settingsHost = HostIPv4
711− , settingsOnException = \e ->
712− case fromException e of
715− when (go' $ fromException e) $
717− , settingsOnOpen = return ()
718− , settingsOnClose = return ()
719− , settingsTimeout = 30
720− , settingsIntercept = const Nothing
721− , settingsManager = Nothing
724− go :: InvalidRequest -> IO ()
726− go' (Just ThreadKilled) = False
729−type BSEndo = ByteString -> ByteString
730−type BSEndoList = [ByteString] -> [ByteString]
732−data THStatus = THStatus
733− {-# UNPACK #-} !Int -- running total byte count
734− BSEndoList -- previously parsed lines
735− BSEndo -- bytestrings to be prepended
737−takeHeaders :: Sink ByteString (ResourceT IO) [ByteString]
739− await >>= maybe (throwIO ConnectionClosedByPeer) (push (THStatus 0 id id))
741− close :: Sink ByteString (ResourceT IO) a
742− close = throwIO IncompleteHeaders
744− push (THStatus len lines prepend) bs
746− | len > maxTotalHeaderLength = throwIO OverLargeHeader
749− -- No newline find in this chunk. Add it to the prepend,
750− -- update the length, and continue processing.
752− let len' = len + bsLen
753− prepend' = prepend . S.append bs
754− status = THStatus len' lines prepend'
755− in await >>= maybe close (push status)
756− -- Found a newline, but next line continues as a multiline header
758− let rest = S.drop (end + 1) bs
759− prepend' = prepend . S.append (SU.unsafeTake (checkCR bs end) bs)
761− status = THStatus len' lines prepend'
763− -- Found a newline at position end.
764− Just (end, False) ->
765− let start = end + 1 -- start of next chunk
767− -- There were some bytes before the newline, get them
768− | end > 0 = prepend $ SU.unsafeTake (checkCR bs end) bs
769− -- No bytes before the newline
770− | otherwise = prepend S.empty
774− let lines' = lines []
776− rest = if start < bsLen
777− then Just (SU.unsafeDrop start bs)
779− in maybe (return ()) leftover rest >> return lines'
782− let len' = len + start
783− lines' = lines . (line:)
784− status = THStatus len' lines' id
786− -- more bytes in this chunk, push again
787− then let bs' = SU.unsafeDrop start bs
789− -- no more bytes in this chunk, ask for more
790− else await >>= maybe close (push status)
794− nl <- S.elemIndex 10 bs
795− -- check if there are two more bytes in the bs
796− -- if so, see if the second of those is a horizontal space
799− let c = S.index bs (nl + 1)
800− in Just (nl, c == 32 || c == 9)
801− else Just (nl, False)
802−{-# INLINE takeHeaders #-}
804−checkCR :: ByteString -> Int -> Int
807− in if '\r' == B.index bs p
810−{-# INLINE checkCR #-}
812−readInt :: Integral a => ByteString -> a
813−readInt bs = fromIntegral $ readInt64 bs
814−{-# INLINE readInt #-}
817−-- | Call the inner function with a timeout manager.
818−withManager :: Int -- ^ timeout in microseconds
819− -> (Manager -> IO a)
821−withManager timeout f = do
822− -- FIXME when stopManager is available, use it
823− man <- T.initialize timeout
826−serverHeader :: H.RequestHeaders -> H.RequestHeaders
827−serverHeader hdrs = case lookup key hdrs of
828− Nothing -> server : hdrs
832− ver = B.pack $ "Warp/" ++ warpVersion
835−fmapResume :: (Source m o1 -> Source m o2) -> ResumableSource m o1 -> ResumableSource m o2
836−fmapResume f (ResumableSource src m) = ResumableSource (f src) m