@@ -1,11 +1,5 @@
1−{-# LANGUAGE DeriveDataTypeable #-}
2−{-# LANGUAGE FlexibleContexts #-}
3−{-# LANGUAGE OverloadedStrings #-}
41{-# LANGUAGE CPP #-}
5−{-# LANGUAGE BangPatterns #-}
6−{-# LANGUAGE MagicHash #-}
7−{-# LANGUAGE ScopedTypeVariables #-}
8−{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
2+
93---------------------------------------------------------
104--
115-- Module : Network.Wai.Handler.Warp
@@ -21,816 +15,53 @@
2115---------------------------------------------------------
2216
2317-- | A fast, light-weight HTTP server handler for WAI.
24−module Network.Wai.Handler.Warp
25− ( -- * Run a Warp server
26− run
27− , runSettings
28− , runSettingsSocket
29− -- * Settings
30− , Settings
31− , defaultSettings
32− , settingsPort
33− , settingsHost
34− , settingsOnException
35− , settingsOnOpen
36− , settingsOnClose
37− , settingsTimeout
38− , settingsIntercept
39− , settingsManager
40− -- ** Data types
41− , HostPreference (..)
42− -- * Connection
43− , Connection (..)
44− , runSettingsConnection
45− -- * Datatypes
46− , Port
47− , InvalidRequest (..)
48− -- * Internal
49− , Manager
50− , withManager
51− , parseRequest
52− , sendResponse
53− , registerKillThread
54− , pause
55− , resume
56− , T.cancel
57− , T.register
58− , T.initialize
59− , socketConnection
18+module Network.Wai.Handler.Warp (
19+ -- * Run a Warp server
20+ run
21+ , runSettings
22+ , runSettingsSocket
23+ -- * Settings
24+ , Settings
25+ , defaultSettings
26+ , settingsPort
27+ , settingsHost
28+ , settingsOnException
29+ , settingsOnOpen
30+ , settingsOnClose
31+ , settingsTimeout
32+ , settingsIntercept
33+ , settingsManager
34+ -- ** Data types
35+ , HostPreference (..)
36+ -- * Connection
37+ , Connection (..)
38+ , runSettingsConnection
39+ -- * Datatypes
40+ , Port
41+ , InvalidRequest (..)
42+ -- * Internal
43+ , Manager
44+ , withManager
45+ , parseRequest
46+ , sendResponse
47+ , registerKillThread
48+ , pause
49+ , resume
50+ , cancel
51+ , register
52+ , initialize
53+ , socketConnection
6054#if TEST
61− , takeHeaders
62− , parseFirst
63− , readInt
64−#endif
65− ) where
66−
67−import Prelude hiding (lines, catch)
68−import Network.Wai
69−
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
82− , try
83−#if __GLASGOW_HASKELL__ >= 702
84− , allowInterrupt
85−#else
86− , unblock
87−#endif
88−#if WINDOWS
89− , finally
90−#endif
91− )
92−import Control.Concurrent (forkIO, threadDelay)
93−import Data.Maybe (fromMaybe, isJust)
94−import Data.Char (toLower, isHexDigit)
95−import Data.Word (Word)
96−
97−import Data.Typeable (Typeable)
98−
99−import Data.Conduit
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
112−
113−import qualified System.PosixCompat.Files as P
114−
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))
128−
129−#if WINDOWS
130−import qualified Control.Concurrent.MVar as MV
131−import Network.Socket (withSocketsDo)
132−#endif
133−
134−import Data.Version (showVersion)
135−import qualified Paths_warp
136−
137−warpVersion :: String
138−warpVersion = showVersion Paths_warp.version
139−
140−#if __GLASGOW_HASKELL__ < 702
141−allowInterrupt :: IO ()
142−allowInterrupt = unblock $ return ()
143−#endif
144−
145−-- |
146−--
147−-- In order to provide slowloris protection, Warp provides timeout handlers. We
148−-- follow these rules:
149−--
150−-- * A timeout is created when a connection is opened.
151−--
152−-- * When all request headers are read, the timeout is tickled.
153−--
154−-- * Every time at least 2048 bytes of the request body are read, the timeout
155−-- is tickled.
156−--
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.
160−--
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
168− }
169−
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
177− }
178−
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 }
183−
184−-- | Run a Warp server with the given settings.
185−runSettings :: Settings -> Application -> IO ()
186−#if WINDOWS
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))
192− (const clean)
193− (\s -> do
194− MV.modifyMVar_ var (\_ -> return $ Just s)
195− runSettingsSocket set s app)
196− forever (threadDelay maxBound) `finally` clean
197−#else
198−runSettings set =
199− bracket
200− (bindPort (settingsPort set) (settingsHost set))
201− sClose .
202− flip (runSettingsSocket set)
55+ , takeHeaders
56+ , parseFirst
57+ , readInt
20358#endif
204−
205−type Port = Int
206−
207−-- | Same as 'runSettings', but uses a user-supplied socket instead of opening
208−-- one. This allows the user to provide, for example, Unix named socket, which
209−-- can be used when reverse HTTP proxying into your application.
210−--
211−-- Note that the 'settingsPort' will still be passed to 'Application's via the
212−-- 'serverPort' record.
213−runSettingsSocket :: Settings -> Socket -> Application -> IO ()
214−runSettingsSocket set socket app =
215− runSettingsConnection set getter app
216− where
217− getter = do
218− (conn, sa) <- accept socket
219− return (socketConnection conn, sa)
220−
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
226− allowInterrupt
227− (conn, addr) <- getConnLoop
228− void $ forkIO $ do
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)
234− where
235− -- FIXME: only IOEception is caught. What about other exceptions?
236− getConnLoop = getConn `catch` \(e :: IOException) -> do
237− onE (toException e)
238− -- "resource exhausted (Too many open files)" may happen by accept().
239− -- Wait a second hoping that resource will be available.
240− threadDelay 1000000
241− getConnLoop
242− onE = settingsOnException set
243− port = settingsPort set
244− onOpen = settingsOnOpen set
245− onClose = settingsOnClose set
246−
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))
249−
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
257− if count == 0
258− -- No more bytes wanted downstream, so we're done.
259− then return ()
260− else do
261− -- Get the next chunk (if available) and the updated source
262− (src', mbs) <- lift $ src $$++ CL.head
263−
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
267−
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
272− case () of
273− ()
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
277− -- next chunk.
278− | count' > 0 -> do
279− liftIO $ I.writeIORef ref (count', src')
280− yield bs
281− ibsIsolate ibs
282−
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')
288− yield bs
289−
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.
294− | otherwise -> do
295− let (x, y) = S.splitAt toSend bs
296− liftIO $ I.writeIORef ref (count', fmapResume (yield y >>) src')
297− yield x
298−
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
303−
304−serveConnection :: Settings
305− -> T.Handle
306− -> Port -> Application -> Connection -> SockAddr-> IO ()
307−serveConnection settings th port app conn remoteHost' =
308− runResourceT serveConnection'
309− where
310− serveConnection' :: ResourceT IO ()
311− serveConnection' = do
312− let fromClient = connSource conn th
313− serveConnection'' fromClient
314−
315− serveConnection'' fromClient = do
316− (env, getSource) <- parseRequest conn port remoteHost' fromClient
317− case settingsIntercept settings env of
318− Nothing -> do
319− -- Let the application run for as long as it wants
320− liftIO $ T.pause th
321− res <- app env
322−
323− liftIO $ T.resume th
324− keepAlive <- sendResponse th env conn res
325−
326− -- flush the rest of the request body
327− requestBody env $$ CL.sinkNull
328− ResumableSource fromClient' _ <- liftIO getSource
329−
330− when keepAlive $ serveConnection'' fromClient'
331− Just intercept -> do
332− liftIO $ T.pause th
333− ResumableSource fromClient' _ <- liftIO getSource
334− intercept fromClient' conn
335−
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
342−
343−-- FIXME come up with good values here
344−bytesPerRead, maxTotalHeaderLength :: Int
345−bytesPerRead = 4096
346−maxTotalHeaderLength = 50 * 1024
347−
348−data InvalidRequest =
349− NotEnoughLines [String]
350− | BadFirstLine String
351− | NonHttp
352− | IncompleteHeaders
353− | ConnectionClosedByPeer
354− | OverLargeHeader
355− deriving (Show, Typeable, Eq)
356−instance Exception InvalidRequest
357−
358−handleExpect :: Connection
359− -> H.HttpVersion
360− -> ([H.Header] -> [H.Header])
361− -> [H.Header]
362− -> IO [H.Header]
363−handleExpect _ _ front [] = return $ front []
364−handleExpect conn hv front (("expect", "100-continue"):rest) = do
365− connSendAll conn $
366− if hv == H.http11
367− then "HTTP/1.1 100 Continue\r\n\r\n"
368− else "HTTP/1.0 100 Continue\r\n\r\n"
369− return $ front rest
370−handleExpect conn hv front (x:xs) = handleExpect conn hv (front . (x:)) xs
371−
372−-- | Parse a set of header lines and body into a 'Request'.
373−parseRequest' :: Connection
374− -> Port
375− -> [ByteString]
376− -> SockAddr
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
382− let (host',rpath)
383− | S.null rpath' = ("", "/")
384− | "http://" `S.isPrefixOf` rpath' = S.breakByte 47 $ S.drop 7 rpath'
385− | otherwise = ("", rpath')
386− heads <- liftIO
387− $ handleExpect conn httpversion id
388− (map parseHeaderNoAttr otherLines)
389− let host = fromMaybe host' $ lookup "host" heads
390− let len0 =
391− case lookup "content-length" heads of
392− Nothing -> 0
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 $
398− if chunked
399− then do
400− ref <- I.newIORef (src, NeedLen)
401− return (chunkedSource ref, fmap fst $ I.readIORef ref)
402− else do
403− ibs <- fmap IsolatedBSSource $ I.newIORef (len0, src)
404− return (ibsIsolate ibs, ibsDone ibs)
405−
406− return (Request
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'
414− , serverPort = port
415− , requestHeaders = heads
416− , isSecure = False
417− , remoteHost = remoteHost'
418− , requestBody = rbody
419− , vault = mempty
420− }, getSource)
421−
422−data ChunkState = NeedLen
423− | NeedLenNewline
424− | HaveLen Word
425−
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
431− go src mlen
432− where
433− go' src front = do
434− (src', (len, bs)) <- lift $ src $$++ front getLen
435− let src''
436− | S.null bs = src'
437− | otherwise = fmapResume (yield bs >>) src'
438− go src'' $ HaveLen len
439−
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
445− case mbs of
446− Nothing -> liftIO $ I.writeIORef ipair (src', HaveLen 0)
447− Just bs ->
448− case S.length bs `compare` fromIntegral len of
449− EQ -> yield' src' NeedLenNewline bs
450− LT -> do
451− let mlen = HaveLen $ len - fromIntegral (S.length bs)
452− yield' src' mlen bs
453− GT -> do
454− let (x, y) = S.splitAt (fromIntegral len) bs
455− let src'' = fmapResume (yield y >>) src'
456− yield' src'' NeedLenNewline x
457−
458− yield' src mlen bs = do
459− liftIO $ I.writeIORef ipair (src, mlen)
460− yield bs
461− go src mlen
462−
463− getLen :: Monad m => Sink ByteString m (Word, ByteString)
464− getLen = do
465− mbs <- CL.head
466− case mbs of
467− Nothing -> return (0, S.empty)
468− Just bs -> do
469− (x, y) <-
470− case S.breakByte 10 bs of
471− (x, y)
472− | S.null y -> do
473− mbs2 <- CL.head
474− case mbs2 of
475− Nothing -> return (x, y)
476− Just bs2 -> return $ S.breakByte 10 $ bs `S.append` bs2
477− | otherwise -> return (x, y)
478− let w =
479− S.foldl' (\i c -> i * 16 + fromIntegral (hexToWord c)) 0
480− $ B.takeWhile isHexDigit x
481− return (w, S.drop 1 y)
482−
483− hexToWord w
484− | w < 58 = w - 48
485− | w < 71 = w - 55
486− | otherwise = w - 87
487−
488−takeUntil :: Word8 -> ByteString -> ByteString
489−takeUntil c bs =
490− case S.elemIndex c bs of
491− Just !idx -> SU.unsafeTake idx bs
492− Nothing -> bs
493−{-# INLINE takeUntil #-}
494−
495−parseFirst :: ByteString
496− -> ResourceT IO (ByteString, ByteString, ByteString, H.HttpVersion)
497−parseFirst s =
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 -- '?'
504− hv =
505− case hsecond of
506− "1.1" -> H.http11
507− _ -> H.http10
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
512−
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 ": "
520−
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"
527− _ -> "1.0")
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
536− else newlineBuilder
537− in start' `mappend` end
538−
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
545−
546−checkPersist :: Request -> Bool
547−checkPersist req
548− | ver == H.http11 = checkPersist11 conn
549− | otherwise = checkPersist10 conn
550− where
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
559−
560−isChunked :: H.HttpVersion -> Bool
561−isChunked = (==) H.http11
562−
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"
566−
567−sendResponse :: T.Handle
568− -> Request -> Connection -> Response -> ResourceT IO Bool
569−sendResponse th req conn r = sendResponse' r
570− where
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
578−
579− sendResponse' :: Response -> ResourceT IO Bool
580− sendResponse' (ResponseFile s hs fp mpart) = do
581− eres <-
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
590− case eres of
591− Left (_ :: SomeException) -> sendResponse' $ responseLBS
592− H.status404
593− [("Content-Type", "text/plain")]
594− "File not found"
595− Right (lengthyHeaders, cl) -> liftIO $ do
596− let headers' = L.toChunks . toLazyByteString $ headers version s lengthyHeaders False
597− T.tickle th
598− if hasBody s req then do
599− case mpart of
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'
602− T.tickle th
603− return isPersist
604− else
605− return isPersist
606− where
607− addClToHeaders cl = (("Content-Length", B.pack $ show cl):hs, fromIntegral cl)
608−
609− sendResponse' (ResponseBuilder s hs b)
610− | hasBody s req = liftIO $ do
611− toByteStringIO (\bs -> do
612− connSendAll conn bs
613− T.tickle th) body
614− return (isKeepAlive hs)
615− | otherwise = liftIO $ do
616− sendHeader $ headers' False
617− T.tickle th
618− return isPersist
619− where
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
627−
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
636− T.tickle th
637− return isPersist
638− where
639− body = mapOutput (\x -> case x of
640− Flush -> flush
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)
648−
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
653− in (CI.mk k, rest')
654−
655−connSource :: Connection -> T.Handle -> Source (ResourceT IO) ByteString
656−connSource Connection { connRecv = recv } th =
657− src
658− where
659− src = do
660− bs <- liftIO recv
661− if S.null bs
662− then return ()
663− else do
664− when (S.length bs >= 2048) $ liftIO $ T.tickle th
665− yield bs
666− src
667−
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 =
671− sink
672− where
673− sink = await >>= maybe close push
674− close = liftIO (T.resume th)
675− push x = do
676− liftIO $ T.resume th
677− liftIO $ send x
678− liftIO $ T.pause th
679− sink
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.
684−
685−------ The functions below are not warp-specific and could be split out into a
686−--separate package.
687−
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:
692−--
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'
703− }
704−
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
713− Just x -> go x
714− Nothing ->
715− when (go' $ fromException e) $
716− hPrint stderr e
717− , settingsOnOpen = return ()
718− , settingsOnClose = return ()
719− , settingsTimeout = 30
720− , settingsIntercept = const Nothing
721− , settingsManager = Nothing
722− }
723− where
724− go :: InvalidRequest -> IO ()
725− go _ = return ()
726− go' (Just ThreadKilled) = False
727− go' _ = True
728−
729−type BSEndo = ByteString -> ByteString
730−type BSEndoList = [ByteString] -> [ByteString]
731−
732−data THStatus = THStatus
733− {-# UNPACK #-} !Int -- running total byte count
734− BSEndoList -- previously parsed lines
735− BSEndo -- bytestrings to be prepended
736−
737−takeHeaders :: Sink ByteString (ResourceT IO) [ByteString]
738−takeHeaders =
739− await >>= maybe (throwIO ConnectionClosedByPeer) (push (THStatus 0 id id))
740− where
741− close :: Sink ByteString (ResourceT IO) a
742− close = throwIO IncompleteHeaders
743−
744− push (THStatus len lines prepend) bs
745− -- Too many bytes
746− | len > maxTotalHeaderLength = throwIO OverLargeHeader
747− | otherwise =
748− case mnl of
749− -- No newline find in this chunk. Add it to the prepend,
750− -- update the length, and continue processing.
751− Nothing ->
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
757− Just (end, True) ->
758− let rest = S.drop (end + 1) bs
759− prepend' = prepend . S.append (SU.unsafeTake (checkCR bs end) bs)
760− len' = len + end
761− status = THStatus len' lines prepend'
762− in push status rest
763− -- Found a newline at position end.
764− Just (end, False) ->
765− let start = end + 1 -- start of next chunk
766− line
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
771− in if S.null line
772− -- no more headers
773− then
774− let lines' = lines []
775− -- leftover
776− rest = if start < bsLen
777− then Just (SU.unsafeDrop start bs)
778− else Nothing
779− in maybe (return ()) leftover rest >> return lines'
780− -- more headers
781− else
782− let len' = len + start
783− lines' = lines . (line:)
784− status = THStatus len' lines' id
785− in if start < bsLen
786− -- more bytes in this chunk, push again
787− then let bs' = SU.unsafeDrop start bs
788− in push status bs'
789− -- no more bytes in this chunk, ask for more
790− else await >>= maybe close (push status)
791− where
792− bsLen = S.length bs
793− mnl = do
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
797− if bsLen > nl + 1
798− then
799− let c = S.index bs (nl + 1)
800− in Just (nl, c == 32 || c == 9)
801− else Just (nl, False)
802−{-# INLINE takeHeaders #-}
803−
804−checkCR :: ByteString -> Int -> Int
805−checkCR bs pos =
806− let !p = pos - 1
807− in if '\r' == B.index bs p
808− then p
809− else pos
810−{-# INLINE checkCR #-}
811−
812−readInt :: Integral a => ByteString -> a
813−readInt bs = fromIntegral $ readInt64 bs
814−{-# INLINE readInt #-}
815−
816−
817−-- | Call the inner function with a timeout manager.
818−withManager :: Int -- ^ timeout in microseconds
819− -> (Manager -> IO a)
820− -> IO a
821−withManager timeout f = do
822− -- FIXME when stopManager is available, use it
823− man <- T.initialize timeout
824− f man
825−
826−serverHeader :: H.RequestHeaders -> H.RequestHeaders
827−serverHeader hdrs = case lookup key hdrs of
828− Nothing -> server : hdrs
829− Just _ -> hdrs
830− where
831− key = "Server"
832− ver = B.pack $ "Warp/" ++ warpVersion
833− server = (key, ver)
834−
835−fmapResume :: (Source m o1 -> Source m o2) -> ResumableSource m o1 -> ResumableSource m o2
836−fmapResume f (ResumableSource src m) = ResumableSource (f src) m
59+ ) where
60+
61+import Network.Wai.Handler.Warp.Request
62+import Network.Wai.Handler.Warp.Response
63+import Network.Wai.Handler.Warp.Run
64+import Network.Wai.Handler.Warp.Settings
65+import Network.Wai.Handler.Warp.Types
66+import Network.Wai.Handler.Warp.Timeout
67+import Data.Conduit.Network (HostPreference(..))