f273fe6 · typeable/wai

git.iko.soy/typeable/wai

integrating FdCache.

commitf273fe660bf6bb4edeaafbea41f78160527ee3ff authorKazu Yamamoto <kazu@iij.ad.jp> dateThu 6 Sep 2012, 15:21 (14 years ago) parente55e81f

5 files changed+65−17

compare with master

unifiedsplit

warp/Network/Wai/Handler/Warp/FdCache.hs+2−1 warp/Network/Wai/Handler/Warp/Response.hs+12−8 warp/Network/Wai/Handler/Warp/Run.hs+27−5 warp/Network/Wai/Handler/Warp/Types.hs+17−1 warp/warp.cabal+7−2

warp/Network/Wai/Handler/Warp/FdCache.hs+2−1

@@ -3,6 +3,7 @@

33module Network.Wai.Handler.Warp.FdCache (

44 initialize

55 , getFd

6+ , MutableFdCache

67 ) where

89import Control.Applicative ((<$>), (<*>))

@@ -89,7 +90,7 @@ initialize = do

8990 old <- swapWithNew mfc

9091 new <- pruneWith old prune

9192 update mfc (merge new)

92− threadDelay 30000000 -- FIXME

93+ threadDelay 10000000 -- FIXME

9394 loop mfc

9495

9596prune :: t -> Some FdEntry -> IO [(t, Some FdEntry)]

warp/Network/Wai/Handler/Warp/Response.hs+12−8

@@ -1,6 +1,7 @@

11{-# LANGUAGE OverloadedStrings #-}

22{-# LANGUAGE ScopedTypeVariables #-}

33{-# LANGUAGE BangPatterns #-}

4+{-# LANGUAGE CPP #-}

56module Network.Wai.Handler.Warp.Response (

67 sendResponse

@@ -30,18 +31,19 @@ import qualified System.PosixCompat.Files as P

3031----------------------------------------------------------------

3132----------------------------------------------------------------

3233

33−sendResponse :: T.Handle

34− -> Request -> Connection -> Response -> ResourceT IO Bool

34+sendResponse :: Cleaner -> Request -> Connection -> Response

35+ -> ResourceT IO Bool

3536

3637----------------------------------------------------------------

3738

38−sendResponse th req conn (ResponseFile s hs fp mpart) =

39+sendResponse cleaner req conn (ResponseFile s hs path mpart) =

3940 headerAndLength >>= sendResponse'

4041 where

42+ th = threadHandle cleaner

4143 headerAndLength = case (readInt <$> checkLength hs, mpart) of

4244 (Just cl, _) -> return $ Right (hs, cl)

4345 (Nothing, Nothing) -> liftIO . try $ do

44− cl <- fromIntegral . P.fileSize <$> P.getFileStatus fp

46+ cl <- fromIntegral . P.fileSize <$> P.getFileStatus path

4547 return (addLength cl hs, cl)

4648 (Nothing, Just part) -> do

4749 let cl = fromIntegral $ filePartByteCount part

@@ -49,7 +51,7 @@ sendResponse th req conn (ResponseFile s hs fp mpart) =

4951

5052 sendResponse' (Right (lengthyHeaders, cl))

5153 | hasBody s req = liftIO $ do

52− connSendFile conn fp beg end (T.tickle th) [lheader]

54+ connSendFile conn path beg end (T.tickle th) [lheader] cleaner

5355 T.tickle th

5456 return isPersist

5557 | otherwise = liftIO $ do

@@ -65,13 +67,13 @@ sendResponse th req conn (ResponseFile s hs fp mpart) =

6567 (isPersist,_) = infoFromRequest req

6668

6769 sendResponse' (Left (_ :: SomeException)) =

68− sendResponse th req conn notFound

70+ sendResponse cleaner req conn notFound

6971 where

7072 notFound = responseLBS H.status404 [(H.hContentType, "text/plain")] "File not found"

7173

7274----------------------------------------------------------------

7375

74−sendResponse th req conn (ResponseBuilder s hs b)

76+sendResponse cleaner req conn (ResponseBuilder s hs b)

7577 | hasBody s req = liftIO $ do

7678 flip toByteStringIO body $ \bs -> do

7779 connSendAll conn bs

@@ -82,6 +84,7 @@ sendResponse th req conn (ResponseBuilder s hs b)

8284 T.tickle th

8385 return isPersist

8486 where

87+ th = threadHandle cleaner

8588 header = composeHeaderBuilder version s hs needsChunked

8689 body

8790 | needsChunked = header `mappend` chunkedTransferEncoding b

@@ -93,7 +96,7 @@ sendResponse th req conn (ResponseBuilder s hs b)

9396

9497----------------------------------------------------------------

9598

96−sendResponse th req conn (ResponseSource s hs bodyFlush)

99+sendResponse cleaner req conn (ResponseSource s hs bodyFlush)

97100 | hasBody s req = do

98101 let src = CL.sourceList [header] `mappend` cbody

99102 src $$ builderToByteString =$ connSink conn th

@@ -103,6 +106,7 @@ sendResponse th req conn (ResponseSource s hs bodyFlush)

103106 T.tickle th

104107 return isPersist

105108 where

109+ th = threadHandle cleaner

106110 header = composeHeaderBuilder version s hs needsChunked

107111 body = mapOutput (\x -> case x of

108112 Flush -> flush

warp/Network/Wai/Handler/Warp/Run.hs+27−5

@@ -40,6 +40,8 @@ import Network.Socket (Socket(..))

4040#if WINDOWS

4141import qualified Control.Concurrent.MVar as MV

4242import Network.Socket (withSocketsDo)

43+#else

44+import qualified Network.Wai.Handler.Warp.FdCache as F

4345#endif

4446

4547-- FIXME come up with good values here

@@ -55,7 +57,7 @@ socketConnection s = Connection

5557#endif

5658 { connSendMany = Sock.sendMany s

5759 , connSendAll = Sock.sendAll s

58− , connSendFile = \fp off len act hdr -> sendfileWithHeader s fp (PartOfFile off len) act hdr

60+ , connSendFile = sendFile s

5961 , connClose = sClose s

6062#ifdef PESSIMISTIC_RECV

6163 , connRecv = threadWaitRead (Fd fd) >> Sock.recv s bytesPerRead

@@ -64,6 +66,16 @@ socketConnection s = Connection

6466#endif

6567 }

6668

69+sendFile :: Socket -> FilePath -> Integer -> Integer -> IO () -> [ByteString] -> Cleaner -> IO ()

70+#if WINDOWS

71+sendFile s path off len act hdr _ =

72+ sendfileWithHeader s path (PartOfFile off len) act hdr

73+#else

74+sendFile s path off len act hdr cleaner = do

75+ (fd, fresher) <- F.getFd (fdCacher cleaner) path

76+ sendfileFdWithHeader s fd (PartOfFile off len) (act>>fresher) hdr

77+#endif

78+

6779#if __GLASGOW_HASKELL__ < 702

6880allowInterrupt :: IO ()

6981allowInterrupt = unblock $ return ()

@@ -113,14 +125,22 @@ runSettingsConnection :: Settings -> IO (Connection, SockAddr) -> Application ->

113125runSettingsConnection set getConn app = do

114126 tm <- maybe (T.initialize $ settingsTimeout set * 1000000) return

115127 $ settingsManager set

128+#if !WINDOWS

129+ fc <- F.initialize

130+#endif

116131 mask $ \restore -> forever $ do

117132 allowInterrupt

118133 (conn, addr) <- getConnLoop

119134 void . forkIO $ do

120135 th <- T.registerKillThread tm

136+#if WINDOWS

137+ let cleaner = Cleaner th

138+#else

139+ let cleaner = Cleaner th fc

140+#endif

121141 let serve = do

122142 onOpen

123− restore $ serveConnection set th port app conn addr

143+ restore $ serveConnection set cleaner port app conn addr

124144 cleanup

125145 cleanup = connClose conn >> T.cancel th >> onClose

126146 handle onE $ (serve `onException` cleanup)

@@ -138,11 +158,13 @@ runSettingsConnection set getConn app = do

138158 onClose = settingsOnClose set

139159

140160serveConnection :: Settings

141− -> T.Handle

161+ -> Cleaner

142162 -> Port -> Application -> Connection -> SockAddr-> IO ()

143−serveConnection settings th port app conn remoteHost' =

163+serveConnection settings cleaner port app conn remoteHost' =

144164 runResourceT serveConnection'

145165 where

166+ th = threadHandle cleaner

167+

146168 serveConnection' :: ResourceT IO ()

147169 serveConnection' = serveConnection'' $ connSource conn th

148170

@@ -155,7 +177,7 @@ serveConnection settings th port app conn remoteHost' =

155177 res <- app env

156178

157179 liftIO $ T.resume th

158− keepAlive <- sendResponse th env conn res

180+ keepAlive <- sendResponse cleaner env conn res

159181

160182 -- flush the rest of the request body

161183 requestBody env $$ CL.sinkNull

warp/Network/Wai/Handler/Warp/Types.hs+17−1

@@ -1,5 +1,6 @@

11{-# LANGUAGE DeriveDataTypeable #-}

22{-# LANGUAGE OverloadedStrings #-}

3+{-# LANGUAGE CPP #-}

45module Network.Wai.Handler.Warp.Types where

@@ -9,6 +10,10 @@ import Data.Typeable (Typeable)

910import Data.Version (showVersion)

1011import Network.HTTP.Types.Header

1112import qualified Paths_warp

13+import qualified Network.Wai.Handler.Warp.Timeout as T

14+#if !WINDOWS

15+import qualified Network.Wai.Handler.Warp.FdCache as F

16+#endif

1217

1318----------------------------------------------------------------

1419

@@ -66,7 +71,18 @@ instance Exception InvalidRequest

6671data Connection = Connection

6772 { connSendMany :: [ByteString] -> IO ()

6873 , connSendAll :: ByteString -> IO ()

69− , connSendFile :: FilePath -> Integer -> Integer -> IO () -> [ByteString] -> IO () -- ^ offset, length

74+ , connSendFile :: FilePath -> Integer -> Integer -> IO () -> [ByteString] -> Cleaner -> IO () -- ^ offset, length

7075 , connClose :: IO ()

7176 , connRecv :: IO ByteString

7277 }

78+

79+----------------------------------------------------------------

80+

81+#if WINDOWS

82+newtype Cleaner = Cleaner { threadHandle :: T.Handle }

83+#else

84+data Cleaner = Cleaner {

85+ threadHandle :: T.Handle

86+ , fdCacher :: F.MutableFdCache

87+ }

88+#endif

warp/warp.cabal+7−2

@@ -32,8 +32,8 @@ Library

3232 , void

3333 , wai >= 1.3 && < 1.4

3434 if flag(network-bytestring)

35− Build-Depends: network >= 2.2.1.5 && < 2.2.3

36− , network-bytestring >= 0.1.3 && < 0.1.4

35+ Build-Depends: network >= 2.2.1.5 && < 2.2.3

36+ , network-bytestring >= 0.1.3 && < 0.1.4

3737 else

3838 Build-Depends: network >= 2.3

3939 Exposed-modules: Network.Wai.Handler.Warp

@@ -50,6 +50,11 @@ Library

5050 Ghc-Options: -Wall

5151 if os(windows)

5252 Cpp-options: -DWINDOWS

53+ else

54+ Build-Depends: unix

55+ , hashable

56+ Other-modules: Network.Wai.Handler.Warp.FdCache

57+ Network.Wai.Handler.Warp.MultiMap

5358

5459Test-Suite spec

5560 Main-Is: Spec.hs