@@ -0,0 +1,576 @@
1+{-# LANGUAGE DeriveDataTypeable #-}
2+{-# LANGUAGE FlexibleContexts #-}
3+{-# LANGUAGE OverloadedStrings #-}
4+{-# LANGUAGE CPP #-}
5+{-# LANGUAGE BangPatterns #-}
6+---------------------------------------------------------
7+--
8+-- Module : Network.Wai.Handler.Warp
9+-- Copyright : Michael Snoyman
10+-- License : BSD3
11+--
12+-- Maintainer : Michael Snoyman <michael@snoyman.com>
13+-- Stability : Stable
14+-- Portability : portable
15+--
16+-- A fast, light-weight HTTP server handler for WAI.
17+--
18+---------------------------------------------------------
19+
20+-- | A fast, light-weight HTTP server handler for WAI. Some random notes (a FAQ, if you will):
21+--
22+-- * When a 'ResponseFile' indicates a file which does not exist, an exception
23+-- is thrown. This will close the connection to the client as well. You should
24+-- handle file existance checks at the application level.
25+module Network.Wai.Handler.Warp
26+ ( -- * Run a Warp server
27+ run
28+ , runSettings
29+ , runSettingsSocket
30+ -- * Settings
31+ , Settings
32+ , defaultSettings
33+ , settingsPort
34+ , settingsHost
35+ , settingsOnException
36+ , settingsTimeout
37+ -- * Datatypes
38+ , Port
39+ , InvalidRequest (..)
40+ -- * Internal
41+ , Manager
42+ , withManager
43+ , parseRequest
44+ , sendResponse
45+ , registerKillThread
46+ , bindPort
47+ , enumSocket
48+ , pause
49+ , resume
50+#if TEST
51+ , takeHeaders
52+ , readInt
53+#endif
54+ ) where
55+
56+import Prelude hiding (catch, lines)
57+import Network.Wai
58+
59+import Data.ByteString (ByteString)
60+import qualified Data.ByteString as S
61+import qualified Data.ByteString.Unsafe as SU
62+import qualified Data.ByteString.Char8 as B
63+import qualified Data.ByteString.Lazy as L
64+import Network (sClose, Socket)
65+import Network.Socket
66+ ( accept, Family (..)
67+ , SocketType (Stream), listen, bindSocket, setSocketOption, maxListenQueue
68+ , SockAddr, SocketOption (ReuseAddr)
69+ , AddrInfo(..), AddrInfoFlag(..), defaultHints, getAddrInfo
70+ )
71+import qualified Network.Socket
72+import qualified Network.Socket.ByteString as Sock
73+import Control.Exception
74+ ( bracket, finally, Exception, SomeException, catch
75+ , fromException, AsyncException (ThreadKilled)
76+ , bracketOnError
77+ )
78+import Control.Concurrent (forkIO)
79+import qualified Data.Char as C
80+import Data.Maybe (fromMaybe)
81+
82+import Data.Typeable (Typeable)
83+
84+import Data.Enumerator (($$), (>>==))
85+import qualified Data.Enumerator as E
86+import qualified Data.Enumerator.List as EL
87+import qualified Data.Enumerator.Binary as EB
88+import Blaze.ByteString.Builder.Enumerator (builderToByteString)
89+import Blaze.ByteString.Builder.HTTP
90+ (chunkedTransferEncoding, chunkedTransferTerminator)
91+import Blaze.ByteString.Builder
92+ (copyByteString, Builder, toLazyByteString, toByteStringIO)
93+import Blaze.ByteString.Builder.Char8 (fromChar, fromShow)
94+import Data.Monoid (mappend, mconcat)
95+import Network.Sendfile
96+
97+import qualified System.PosixCompat.Files as P
98+
99+import Control.Monad.IO.Class (liftIO)
100+import qualified Timeout as T
101+import Timeout (Manager, registerKillThread, pause, resume)
102+import Data.Word (Word8)
103+import Data.List (foldl')
104+import Control.Monad (forever)
105+import qualified Network.HTTP.Types as H
106+import qualified Data.CaseInsensitive as CI
107+import System.IO (hPutStrLn, stderr)
108+
109+#if WINDOWS
110+import Control.Concurrent (threadDelay)
111+import qualified Control.Concurrent.MVar as MV
112+import Network.Socket (withSocketsDo)
113+#endif
114+
115+bindPort :: Int -> String -> IO Socket
116+bindPort p s = do
117+ let hints = defaultHints { addrFlags = [AI_PASSIVE
118+ , AI_NUMERICSERV
119+ , AI_NUMERICHOST]
120+ , addrSocketType = Stream }
121+ host = if s == "*" then Nothing else Just s
122+ port = Just . show $ p
123+ addrs <- getAddrInfo (Just hints) host port
124+ -- Choose an IPv6 socket if exists. This ensures the socket can
125+ -- handle both IPv4 and IPv6 if v6only is false.
126+ let addrs' = filter (\x -> addrFamily x == AF_INET6) addrs
127+ addr = if null addrs' then head addrs else head addrs'
128+ bracketOnError
129+ (Network.Socket.socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr))
130+ (sClose)
131+ (\sock -> do
132+ setSocketOption sock ReuseAddr 1
133+ bindSocket sock (addrAddress addr)
134+ listen sock maxListenQueue
135+ return sock
136+ )
137+
138+-- | Run an 'Application' on the given port. This calls 'runSettings' with
139+-- 'defaultSettings'.
140+run :: Port -> Application -> IO ()
141+run p = runSettings defaultSettings { settingsPort = p }
142+
143+-- | Run a Warp server with the given settings.
144+runSettings :: Settings -> Application -> IO ()
145+#if WINDOWS
146+runSettings set app = withSocketsDo $ do
147+ var <- MV.newMVar Nothing
148+ let clean = MV.modifyMVar_ var $ \s -> maybe (return ()) sClose s >> return Nothing
149+ _ <- forkIO $ bracket
150+ (bindPort (settingsPort set) (settingsHost set))
151+ (const clean)
152+ (\s -> do
153+ MV.modifyMVar_ var (\_ -> return $ Just s)
154+ runSettingsSocket set s app)
155+ forever (threadDelay maxBound) `finally` clean
156+#else
157+runSettings set =
158+ bracket
159+ (bindPort (settingsPort set) (settingsHost set))
160+ sClose .
161+ (flip (runSettingsSocket set))
162+#endif
163+
164+type Port = Int
165+
166+-- | Same as 'runSettings', but uses a user-supplied socket instead of opening
167+-- one. This allows the user to provide, for example, Unix named socket, which
168+-- can be used when reverse HTTP proxying into your application.
169+--
170+-- Note that the 'settingsPort' will still be passed to 'Application's via the
171+-- 'serverPort' record.
172+runSettingsSocket :: Settings -> Socket -> Application -> IO ()
173+runSettingsSocket set socket app = do
174+ let onE = settingsOnException set
175+ port = settingsPort set
176+ tm <- T.initialize $ settingsTimeout set * 1000000
177+ forever $ do
178+ (conn, sa) <- accept socket
179+ _ <- forkIO $ do
180+ th <- T.registerKillThread tm
181+ serveConnection th onE port app conn sa
182+ T.cancel th
183+ return ()
184+
185+serveConnection :: T.Handle
186+ -> (SomeException -> IO ())
187+ -> Port -> Application -> Socket -> SockAddr -> IO ()
188+serveConnection th onException port app conn remoteHost' = do
189+ catch
190+ (finally
191+ (E.run_ $ fromClient $$ serveConnection')
192+ (sClose conn))
193+ onException
194+ where
195+ fromClient = enumSocket th bytesPerRead conn
196+ serveConnection' = do
197+ (len, env) <- parseRequest port remoteHost'
198+ -- Let the application run for as long as it wants
199+ liftIO $ T.pause th
200+ res <- E.joinI $ EB.isolate len $$ app env
201+ liftIO $ T.resume th
202+ keepAlive <- liftIO $ sendResponse th env conn res
203+ if keepAlive then serveConnection' else return ()
204+
205+parseRequest :: Port -> SockAddr -> E.Iteratee S.ByteString IO (Integer, Request)
206+parseRequest port remoteHost' = do
207+ headers' <- takeHeaders
208+ parseRequest' port headers' remoteHost'
209+
210+-- FIXME come up with good values here
211+bytesPerRead, maxTotalHeaderLength :: Int
212+bytesPerRead = 4096
213+maxTotalHeaderLength = 50 * 1024
214+
215+data InvalidRequest =
216+ NotEnoughLines [String]
217+ | BadFirstLine String
218+ | NonHttp
219+ | IncompleteHeaders
220+ | OverLargeHeader
221+ deriving (Show, Typeable, Eq)
222+instance Exception InvalidRequest
223+
224+-- | Parse a set of header lines and body into a 'Request'.
225+parseRequest' :: Port
226+ -> [ByteString]
227+ -> SockAddr
228+ -> E.Iteratee S.ByteString IO (Integer, Request)
229+parseRequest' _ [] _ = E.throwError $ NotEnoughLines []
230+parseRequest' port (firstLine:otherLines) remoteHost' = do
231+ (method, rpath', gets, httpversion) <- parseFirst firstLine
232+ let (host',rpath) =
233+ if S.null rpath'
234+ then ("","/")
235+ else if "http://" `S.isPrefixOf` rpath'
236+ then S.breakByte 47 $ S.drop 7 rpath' -- '/'
237+ else ("", rpath')
238+ let heads = map parseHeaderNoAttr otherLines
239+ let host = fromMaybe host' $ lookup "host" heads
240+ let len =
241+ case lookup "content-length" heads of
242+ Nothing -> 0
243+ Just bs -> fromIntegral $ B.foldl' (\i c -> i * 10 + C.digitToInt c) 0 $ B.takeWhile C.isDigit bs
244+ let serverName' = takeUntil 58 host -- ':'
245+ -- FIXME isolate takes an Integer instead of Int or Int64. If this is a
246+ -- performance penalty, we may need our own version.
247+ return (len, Request
248+ { requestMethod = method
249+ , httpVersion = httpversion
250+ , pathInfo = H.decodePathSegments rpath
251+ , rawPathInfo = rpath
252+ , rawQueryString = gets
253+ , queryString = H.parseQuery gets
254+ , serverName = serverName'
255+ , serverPort = port
256+ , requestHeaders = heads
257+ , isSecure = False
258+ , remoteHost = remoteHost'
259+ })
260+
261+
262+takeUntil :: Word8 -> ByteString -> ByteString
263+takeUntil c bs =
264+ case S.elemIndex c bs of
265+ Just !idx -> SU.unsafeTake idx bs
266+ Nothing -> bs
267+{-# INLINE takeUntil #-}
268+
269+parseFirst :: ByteString
270+ -> E.Iteratee S.ByteString IO (ByteString, ByteString, ByteString, H.HttpVersion)
271+parseFirst s =
272+ case S.split 32 s of -- ' '
273+ [method, query, http'] -> do
274+ let (hfirst, hsecond) = B.splitAt 5 http'
275+ if hfirst == "HTTP/"
276+ then let (rpath, qstring) = S.breakByte 63 query -- '?'
277+ hv =
278+ case hsecond of
279+ "1.1" -> H.http11
280+ _ -> H.http10
281+ in return (method, rpath, qstring, hv)
282+ else E.throwError NonHttp
283+ _ -> E.throwError $ BadFirstLine $ B.unpack s
284+{-# INLINE parseFirst #-} -- FIXME is this inline necessary? the function is only called from one place and not exported
285+
286+httpBuilder, spaceBuilder, newlineBuilder, transferEncodingBuilder
287+ , colonSpaceBuilder :: Builder
288+httpBuilder = copyByteString "HTTP/"
289+spaceBuilder = fromChar ' '
290+newlineBuilder = copyByteString "\r\n"
291+transferEncodingBuilder = copyByteString "Transfer-Encoding: chunked\r\n\r\n"
292+colonSpaceBuilder = copyByteString ": "
293+
294+headers :: H.HttpVersion -> H.Status -> H.ResponseHeaders -> Bool -> Builder
295+headers !httpversion !status !responseHeaders !isChunked' = {-# SCC "headers" #-}
296+ let !start = httpBuilder
297+ `mappend` (copyByteString $
298+ case httpversion of
299+ H.HttpVersion 1 1 -> "1.1"
300+ _ -> "1.0")
301+ `mappend` spaceBuilder
302+ `mappend` fromShow (H.statusCode status)
303+ `mappend` spaceBuilder
304+ `mappend` copyByteString (H.statusMessage status)
305+ `mappend` newlineBuilder
306+ !start' = foldl' responseHeaderToBuilder start responseHeaders
307+ !end = if isChunked'
308+ then transferEncodingBuilder
309+ else newlineBuilder
310+ in start' `mappend` end
311+
312+responseHeaderToBuilder :: Builder -> H.Header -> Builder
313+responseHeaderToBuilder b (x, y) = b
314+ `mappend` copyByteString (CI.original x)
315+ `mappend` colonSpaceBuilder
316+ `mappend` copyByteString y
317+ `mappend` newlineBuilder
318+
319+checkPersist :: Request -> Bool
320+checkPersist req
321+ | ver == H.http11 = checkPersist11 conn
322+ | otherwise = checkPersist10 conn
323+ where
324+ ver = httpVersion req
325+ conn = lookup "connection" $ requestHeaders req
326+ checkPersist11 (Just x)
327+ | CI.foldCase x == "close" = False
328+ checkPersist11 _ = True
329+ checkPersist10 (Just x)
330+ | CI.foldCase x == "keep-alive" = True
331+ checkPersist10 _ = False
332+
333+isChunked :: H.HttpVersion -> Bool
334+isChunked = (==) H.http11
335+
336+hasBody :: H.Status -> Request -> Bool
337+hasBody s req = s /= (H.Status 204 "") && requestMethod req /= "HEAD"
338+
339+sendResponse :: T.Handle
340+ -> Request -> Socket -> Response -> IO Bool
341+sendResponse th req socket (ResponseFile s hs fp mpart) = do
342+ (hs', cl) <-
343+ case (readInt `fmap` lookup "content-length" hs, mpart) of
344+ (Just cl, _) -> return (hs, cl)
345+ (Nothing, Nothing) -> do
346+ cl <- P.fileSize `fmap` P.getFileStatus fp
347+ return (("Content-Length", B.pack $ show cl):hs, fromIntegral cl)
348+ (Nothing, Just part) -> do
349+ let cl = filePartByteCount part
350+ return (("Content-Length", B.pack $ show cl):hs, fromIntegral cl)
351+ Sock.sendMany socket $ L.toChunks $ toLazyByteString $ headers (httpVersion req) s hs' False
352+ let isPersist= checkPersist req
353+ if hasBody s req
354+ then do
355+ case mpart of
356+ Nothing -> sendfile socket fp PartOfFile {
357+ rangeOffset = 0
358+ , rangeLength = cl
359+ } (T.tickle th)
360+ Just part -> sendfile socket fp PartOfFile {
361+ rangeOffset = filePartOffset part
362+ , rangeLength = filePartByteCount part
363+ } (T.tickle th)
364+ T.tickle th
365+ return isPersist
366+ else return isPersist
367+sendResponse th req socket (ResponseBuilder s hs b)
368+ | hasBody s req = do
369+ toByteStringIO (\bs -> do
370+ Sock.sendAll socket bs
371+ T.tickle th) b'
372+ return isKeepAlive
373+ | otherwise = do
374+ Sock.sendMany socket
375+ $ L.toChunks
376+ $ toLazyByteString
377+ $ headers (httpVersion req) s hs False
378+ T.tickle th
379+ return True
380+ where
381+ headers' = headers (httpVersion req) s hs isChunked'
382+ b' = if isChunked'
383+ then headers'
384+ `mappend` chunkedTransferEncoding b
385+ `mappend` chunkedTransferTerminator
386+ else headers (httpVersion req) s hs False `mappend` b
387+ hasLength = lookup "content-length" hs /= Nothing
388+ isChunked' = isChunked (httpVersion req) && not hasLength
389+ isPersist = checkPersist req
390+ isKeepAlive = isPersist && (isChunked' || hasLength)
391+sendResponse th req socket (ResponseEnumerator res) =
392+ res go
393+ where
394+ -- FIXME perhaps alloca a buffer per thread and reuse that in all functiosn below. Should lessen greatly the GC burden (I hope)
395+ go s hs | not (hasBody s req) = do
396+ liftIO $ Sock.sendMany socket
397+ $ L.toChunks $ toLazyByteString
398+ $ headers (httpVersion req) s hs False
399+ return True
400+ go s hs = chunk'
401+ $ E.enumList 1 [headers (httpVersion req) s hs isChunked']
402+ $$ E.joinI $ builderToByteString -- FIXME unsafeBuilderToByteString
403+ $$ (iterSocket th socket >> return isKeepAlive)
404+ where
405+ hasLength = lookup "content-length" hs /= Nothing
406+ isChunked' = isChunked (httpVersion req) && not hasLength
407+ isPersist = checkPersist req
408+ isKeepAlive = isPersist && (isChunked' || hasLength)
409+ chunk' i = if isChunked'
410+ then E.joinI $ chunk $$ i
411+ else i
412+ chunk :: E.Enumeratee Builder Builder IO Bool
413+ chunk = E.checkDone $ E.continue . step
414+ step k E.EOF = k (E.Chunks [chunkedTransferTerminator]) >>== return
415+ step k (E.Chunks []) = E.continue $ step k
416+ step k (E.Chunks [x]) = k (E.Chunks [chunkedTransferEncoding x]) >>== chunk
417+ step k (E.Chunks xs) = k (E.Chunks [chunkedTransferEncoding $ mconcat xs]) >>== chunk
418+
419+parseHeaderNoAttr :: ByteString -> H.Header
420+parseHeaderNoAttr s =
421+ let (k, rest) = S.breakByte 58 s -- ':'
422+ restLen = S.length rest
423+ -- FIXME check for colon without following space?
424+ rest' = if restLen > 1 && SU.unsafeTake 2 rest == ": "
425+ then SU.unsafeDrop 2 rest
426+ else rest
427+ in (CI.mk k, rest')
428+
429+enumSocket :: T.Handle -> Int -> Socket -> E.Enumerator ByteString IO a
430+enumSocket th len socket =
431+ inner
432+ where
433+ inner (E.Continue k) = do
434+ bs <- liftIO $ Sock.recv socket len
435+ liftIO $ T.tickle th
436+ if S.null bs
437+ then E.continue k
438+ else k (E.Chunks [bs]) >>== inner
439+ inner step = E.returnI step
440+------ The functions below are not warp-specific and could be split out into a
441+--separate package.
442+
443+iterSocket :: T.Handle
444+ -> Socket
445+ -> E.Iteratee B.ByteString IO ()
446+iterSocket th sock =
447+ E.continue step
448+ where
449+ -- We pause timeouts before passing control back to user code. This ensures
450+ -- that a timeout will only ever be executed when Warp is in control. We
451+ -- also make sure to resume the timeout after the completion of user code
452+ -- so that we can kill idle connections.
453+ step E.EOF = liftIO (T.resume th) >> E.yield () E.EOF
454+ step (E.Chunks []) = E.continue step
455+ step (E.Chunks xs) = do
456+ liftIO $ T.resume th
457+ liftIO $ Sock.sendMany sock xs
458+ liftIO $ T.pause th
459+ E.continue step
460+
461+-- | Various Warp server settings. This is purposely kept as an abstract data
462+-- type so that new settings can be added without breaking backwards
463+-- compatibility. In order to create a 'Settings' value, use 'defaultSettings'
464+-- and record syntax to modify individual records. For example:
465+--
466+-- > defaultSettings { settingsTimeout = 20 }
467+data Settings = Settings
468+ { settingsPort :: Int -- ^ Port to listen on. Default value: 3000
469+ , settingsHost :: String -- ^ Host to bind to, or * for all. Default value: *
470+ , 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.
471+ , settingsTimeout :: Int -- ^ Timeout value in seconds. Default value: 30
472+ }
473+
474+-- | The default settings for the Warp server. See the individual settings for
475+-- the default value.
476+defaultSettings :: Settings
477+defaultSettings = Settings
478+ { settingsPort = 3000
479+ , settingsHost = "*"
480+ , settingsOnException = \e ->
481+ case fromException e of
482+ Just x -> go x
483+ Nothing ->
484+ if go' $ fromException e
485+ then hPutStrLn stderr $ show e
486+ else return ()
487+ , settingsTimeout = 30
488+ }
489+ where
490+ go :: InvalidRequest -> IO ()
491+ go _ = return ()
492+ go' (Just ThreadKilled) = False
493+ go' _ = True
494+
495+takeHeaders :: E.Iteratee ByteString IO [ByteString]
496+takeHeaders = do
497+ !x <- forceHead
498+ takeHeaders' 0 id id x
499+
500+{-# INLINE takeHeaders #-}
501+
502+takeHeaders' :: Int
503+ -> ([ByteString] -> [ByteString])
504+ -> ([ByteString] -> [ByteString])
505+ -> ByteString
506+ -> E.Iteratee S.ByteString IO [ByteString]
507+takeHeaders' !len _ _ _ | len > maxTotalHeaderLength = E.throwError OverLargeHeader
508+takeHeaders' !len !lines !prepend !bs = do
509+ let !bsLen = {-# SCC "takeHeaders'.bsLen" #-} S.length bs
510+ !mnl = {-# SCC "takeHeaders'.mnl" #-} S.elemIndex 10 bs
511+ case mnl of
512+ -- no newline. prepend entire bs to next line
513+ !Nothing -> {-# SCC "takeHeaders'.noNewline" #-} do
514+ let !len' = len + bsLen
515+ !more <- forceHead
516+ takeHeaders' len' lines (prepend . (:) bs) more
517+ Just !nl -> {-# SCC "takeHeaders'.newline" #-} do
518+ let !end = nl
519+ !start = nl + 1
520+ !line = {-# SCC "takeHeaders'.line" #-}
521+ if end > 0
522+ -- line data included in this chunk
523+ then S.concat $! prepend [SU.unsafeTake (checkCR bs end) bs]
524+ --then S.concat $! prepend [SU.unsafeTake (end-1) bs]
525+ -- no line data in this chunk (all in prepend, or empty line)
526+ else S.concat $! prepend []
527+ if S.null line
528+ -- no more headers
529+ then {-# SCC "takeHeaders'.noMoreHeaders" #-} do
530+ let !lines' = {-# SCC "takeHeaders'.noMoreHeaders.lines'" #-} lines []
531+ if start < bsLen
532+ then {-# SCC "takeHeaders'.noMoreHeaders.yield" #-} do
533+ let !rest = {-# SCC "takeHeaders'.noMoreHeaders.yield.rest" #-} SU.unsafeDrop start bs
534+ E.yield lines' $! E.Chunks [rest]
535+ else return lines'
536+
537+ -- more headers
538+ else {-# SCC "takeHeaders'.moreHeaders" #-} do
539+ let !len' = len + start
540+ !lines' = {-# SCC "takeHeaders.lines'" #-} lines . (:) line
541+ !more <- {-# SCC "takeHeaders'.more" #-}
542+ if start < bsLen
543+ then return $! SU.unsafeDrop start bs
544+ else forceHead
545+ {-# SCC "takeHeaders'.takeMore" #-} takeHeaders' len' lines' id more
546+{-# INLINE takeHeaders' #-}
547+
548+forceHead :: E.Iteratee ByteString IO ByteString
549+forceHead = do
550+ !mx <- EL.head
551+ case mx of
552+ !Nothing -> E.throwError IncompleteHeaders
553+ Just !x -> return x
554+{-# INLINE forceHead #-}
555+
556+checkCR :: ByteString -> Int -> Int
557+checkCR bs pos =
558+ let !p = pos - 1
559+ in if '\r' == B.index bs p
560+ then p
561+ else pos
562+{-# INLINE checkCR #-}
563+
564+-- Note: This function produces garbage on invalid input. But serving an
565+-- invalid content-length is a bad idea, mkay?
566+readInt :: S.ByteString -> Integer
567+readInt = S.foldl' (\x w -> x * 10 + fromIntegral w - 48) 0
568+
569+-- | Call the inner function with a timeout manager.
570+withManager :: Int -- ^ timeout in microseconds
571+ -> (Manager -> IO a)
572+ -> IO a
573+withManager timeout f = do
574+ -- FIXME when stopManager is available, use it
575+ man <- T.initialize timeout
576+ f man