@@ -36,6 +36,9 @@ module Network.Wai.Handler.Warp
3636 , settingsTimeout
3737 , settingsIntercept
3838 , settingsManager
39+ -- * Connection
40+ , Connection (..)
41+ , runSettingsConnection
3942 -- * Datatypes
4043 , Port
4144 , InvalidRequest (..)
@@ -117,6 +120,7 @@ import qualified Control.Concurrent.MVar as MV
117120import Network.Socket (withSocketsDo)
118121#endif
119122
123+
120124#ifndef MEGA
121125import Data.Version (showVersion)
122126import qualified Paths_warp
@@ -126,6 +130,26 @@ warpVersion = "0.4.6"
126130#endif
127131warpVersion :: String
128132
133+data Connection = Connection
134+ { connSendMany :: [B.ByteString] -> IO ()
135+ , connSendAll :: B.ByteString -> IO ()
136+ , connSendFile :: FilePath -> Integer -> Integer -> IO () -> IO () -- ^ offset, length
137+ , connSink :: T.Handle -> C.Sink B.ByteString IO ()
138+ , connClose :: IO ()
139+ , connSource :: T.Handle -> C.Source IO B.ByteString
140+ }
141+
142+socketConnection :: Socket -> Connection
143+socketConnection s = Connection
144+ { connSendMany = Sock.sendMany s
145+ , connSendAll = Sock.sendAll s
146+ , connSendFile = \fp off len act -> sendfile s fp (PartOfFile off len) act
147+ , connSink = flip sinkSocket s
148+ , connClose = sClose s
149+ , connSource = \th -> C.Source $ return $ sourceSocket th bytesPerRead s
150+ }
151+
152+
129153bindPort :: Int -> String -> IO Socket
130154bindPort p s = do
131155 let hints = defaultHints { addrFlags = [AI_PASSIVE
@@ -185,32 +209,40 @@ type Port = Int
185209-- 'serverPort' record.
186210runSettingsSocket :: Settings -> Socket -> Application -> IO ()
187211runSettingsSocket set socket app = do
212+ runSettingsConnection set getter app
213+ where
214+ getter = do
215+ (conn, sa) <- accept socket
216+ return (socketConnection conn, sa)
217+
218+runSettingsConnection :: Settings -> IO (Connection, SockAddr) -> Application -> IO ()
219+runSettingsConnection set getConn app = do
188220 let onE = settingsOnException set
189221 port = settingsPort set
190222 tm <- maybe (T.initialize $ settingsTimeout set * 1000000) return
191223 $ settingsManager set
192224 forever $ do
193− (conn, sa) <- accept socket
225+ (conn, addr) <- getConn
194226 _ <- forkIO $ do
195227 th <- T.registerKillThread tm
196− serveConnection set th onE port app conn sa
228+ serveConnection set th onE port app conn addr
197229 T.cancel th
198230 return ()
199231
200232serveConnection :: Settings
201233 -> T.Handle
202234 -> (SomeException -> IO ())
203− -> Port -> Application -> Socket -> SockAddr -> IO ()
235+ -> Port -> Application -> Connection -> SockAddr -> IO ()
204236serveConnection settings th onException port app conn remoteHost' = do
205237 catch
206238 (finally
207239 (runResourceT serveConnection')
208− (sClose conn))
240+ (connClose conn))
209241 onException
210242 where
211243 serveConnection' :: ResourceT IO ()
212244 serveConnection' = do
213− fromClient <- C.bufferSource $ sourceSocket th bytesPerRead conn
245+ fromClient <- C.bufferSource $ connSource conn th
214246 env <- parseRequest port remoteHost' fromClient
215247 case settingsIntercept settings env of
216248 Nothing -> do
@@ -371,8 +403,8 @@ hasBody s req = s /= (H.Status 204 "") && s /= H.status304 &&
371403 H.statusCode s >= 200 && requestMethod req /= "HEAD"
372404
373405sendResponse :: T.Handle
374− -> Request -> Socket -> Response -> ResourceT IO Bool
375−sendResponse th req socket r = sendResponse' r
406+ -> Request -> Connection -> Response -> ResourceT IO Bool
407+sendResponse th req conn r = sendResponse' r
376408 where
377409 version = httpVersion req
378410 isPersist = checkPersist req
@@ -392,19 +424,13 @@ sendResponse th req socket r = sendResponse' r
392424 (Nothing, Just part) -> do
393425 let cl = filePartByteCount part
394426 return $ addClToHeaders cl
395− Sock.sendMany socket $ L.toChunks $ toLazyByteString $
427+ connSendMany conn $ L.toChunks $ toLazyByteString $
396428 headers version s lengthyHeaders False
397429
398430 if not (hasBody s req) then return isPersist else do
399431 case mpart of
400− Nothing -> sendfile socket fp PartOfFile {
401− rangeOffset = 0
402− , rangeLength = cl
403− } (T.tickle th)
404− Just part -> sendfile socket fp PartOfFile {
405− rangeOffset = filePartOffset part
406− , rangeLength = filePartByteCount part
407− } (T.tickle th)
432+ Nothing -> connSendFile conn fp 0 cl (T.tickle th)
433+ Just part -> connSendFile conn fp (filePartOffset part) (filePartByteCount part) (T.tickle th)
408434 T.tickle th
409435 return isPersist
410436 where
@@ -413,11 +439,11 @@ sendResponse th req socket r = sendResponse' r
413439 sendResponse' (ResponseBuilder s hs b)
414440 | hasBody s req = liftIO $ do
415441 toByteStringIO (\bs -> do
416− Sock.sendAll socket bs
442+ connSendAll conn bs
417443 T.tickle th) body
418444 return (isKeepAlive hs)
419445 | otherwise = liftIO $ do
420− Sock.sendMany socket
446+ connSendMany conn
421447 $ L.toChunks
422448 $ toLazyByteString
423449 $ headers' False
@@ -440,7 +466,7 @@ sendResponse th req socket r = sendResponse' r
440466 -- functions below. Should lessen greatly the GC burden (I hope)
441467 response
442468 | not (hasBody s req) = do
443− liftIO $ Sock.sendMany socket
469+ liftIO $ connSendMany conn
444470 $ L.toChunks $ toLazyByteString
445471 $ headers' False
446472 return (checkPersist req)
@@ -448,7 +474,7 @@ sendResponse th req socket r = sendResponse' r
448474 let src =
449475 CL.sourceList [headers' needsChunked'] `mappend`
450476 (if needsChunked' then body C.$= chunk else body)
451− src C.$$ builderToByteString C.=$ sinkSocket th socket
477+ src C.$$ builderToByteString C.=$ connSink conn th
452478 return $ isKeepAlive hs
453479 needsChunked' = needsChunked hs
454480 chunk :: C.Conduit Builder IO Builder
@@ -516,7 +542,7 @@ data Settings = Settings
516542 , settingsHost :: String -- ^ Host to bind to, or * for all. Default value: *
517543 , 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.
518544 , settingsTimeout :: Int -- ^ Timeout value in seconds. Default value: 30
519− , settingsIntercept :: Request -> Maybe (C.BufferedSource IO S.ByteString -> Socket -> ResourceT IO ())
545+ , settingsIntercept :: Request -> Maybe (C.BufferedSource IO S.ByteString -> Connection -> ResourceT IO ())
520546 , settingsManager :: Maybe Manager -- ^ Use an existing timeout manager instead of spawning a new one. If used, 'settingsTimeout' is ignored. Default is 'Nothing'
521547 }
522548