aad53f1 · typeable/wai

warp/Network/Wai/Handler/Warp.hs+41−2

compare with master

unifiedsplit

@@ -66,6 +66,7 @@ module Network.Wai.Handler.Warp (

66 , setTimeout

67 , setManager

68 , setFdCacheDuration

69+ , setFileInfoCacheDuration

69 , setBeforeMainLoop

70 , setBeforeMainLoop

70 , setNoParsePath

71 , setNoParsePath

71 , setInstallShutdownHandler

72 , setInstallShutdownHandler

@@ -95,6 +96,8 @@ module Network.Wai.Handler.Warp (

95 , InvalidRequest (..)

96 , InvalidRequest (..)

96 -- * Utilities

97 -- * Utilities

97 , pauseTimeout

98 , pauseTimeout

99+ , FileInfo(..)

100+ , getFileInfo

98 -- * Internal

101 -- * Internal

99 -- | The following APIs will be removed in Warp 3.2.0. Please use ones exported from Network.Wai.Handler.Warp.Internal.

102 -- | The following APIs will be removed in Warp 3.2.0. Please use ones exported from Network.Wai.Handler.Warp.Internal.

100

103

@@ -136,7 +139,7 @@ module Network.Wai.Handler.Warp (

136 , module Network.Wai.Handler.Warp.Timeout

139 , module Network.Wai.Handler.Warp.Timeout

137 ) where

140 ) where

138

141

139−import Control.Exception (SomeException)

142+import Control.Exception (SomeException, throwIO)

140import Data.ByteString (ByteString)

143import Data.ByteString (ByteString)

141import Data.Maybe (fromMaybe)

144import Data.Maybe (fromMaybe)

142import Data.Streaming.Network (HostPreference)

145import Data.Streaming.Network (HostPreference)

@@ -145,6 +148,7 @@ import Network.Socket (SockAddr)

145import Network.Wai (Request, Response, vault)

148import Network.Wai (Request, Response, vault)

146import Network.Wai.Handler.Warp.Buffer

149import Network.Wai.Handler.Warp.Buffer

147import Network.Wai.Handler.Warp.Date

150import Network.Wai.Handler.Warp.Date

151+import Network.Wai.Handler.Warp.FileInfoCache

148import Network.Wai.Handler.Warp.FdCache

152import Network.Wai.Handler.Warp.FdCache

149import Network.Wai.Handler.Warp.Header

153import Network.Wai.Handler.Warp.Header

150import Network.Wai.Handler.Warp.Request

154import Network.Wai.Handler.Warp.Request

@@ -219,10 +223,26 @@ setManager x y = y { settingsManager = Just x }

219-- Enabling this cache results in drastic performance improvement for file

223-- Enabling this cache results in drastic performance improvement for file

220-- transfers.

224-- transfers.

221--

225--

222−-- Default value: since 3.0.13, default value is 0, was previously 10

226+-- Default value: 0, was previously 10

227+--

228+-- Since 3.0.13

223setFdCacheDuration :: Int -> Settings -> Settings

229setFdCacheDuration :: Int -> Settings -> Settings

224setFdCacheDuration x y = y { settingsFdCacheDuration = x }

230setFdCacheDuration x y = y { settingsFdCacheDuration = x }

225

231

232+-- | Cache duration time of file information in seconds. 0 means that the cache mechanism is not used.

233+--

234+-- The file information cache is an optimization that is useful for servers dealing with

235+-- static files. However, if files are being modified, it can cause incorrect

236+-- results in some cases. Therefore, we disable it by default. If you know that

237+-- your files will be static or you prefer performance to file consistency,

238+-- it's recommended to turn this on; a reasonable value for those cases is 10.

239+-- Enabling this cache results in drastic performance improvement for file

240+-- transfers.

241+--

242+-- Default value: 0

243+setFileInfoCacheDuration :: Int -> Settings -> Settings

244+setFileInfoCacheDuration x y = y { settingsFileInfoCacheDuration = x }

245+

226-- | Code to run after the listening socket is ready but before entering

246-- | Code to run after the listening socket is ready but before entering

227-- the main event loop. Useful for signaling to tests that they can start

247-- the main event loop. Useful for signaling to tests that they can start

228-- running, or to drop permissions after binding to a restricted port.

248-- running, or to drop permissions after binding to a restricted port.

@@ -371,3 +391,22 @@ setHTTP2Disabled y = y { settingsHTTP2Enabled = False }

371-- Since 3.0.10

391-- Since 3.0.10

372pauseTimeout :: Request -> IO ()

392pauseTimeout :: Request -> IO ()

373pauseTimeout = fromMaybe (return ()) . Vault.lookup pauseTimeoutKey . vault

393pauseTimeout = fromMaybe (return ()) . Vault.lookup pauseTimeoutKey . vault

394+

395+-- | Getting file information of the target file.

396+--

397+-- This function first uses a stat(2) or similar system call

398+-- to obtain information of the target file, then registers

399+-- it into the internal cache.

400+-- From the next time, the information is obtained

401+-- from the cache. This reduces the overhead to call the system call.

402+-- The internal cache is refreshed every duration specified by

403+-- 'setFileInfoCacheDuration'.

404+--

405+-- This function throws an 'IO' exception if the information is not

406+-- available. For instance, the target file does not exist.

407+-- If this function is used an a Request generated by a WAI

408+-- backend besides Warp, it also throws an 'IO' exception.

409+--

410+-- Since 3.1.10

411+getFileInfo :: Request -> FilePath -> IO FileInfo

412+getFileInfo = fromMaybe (\_ -> throwIO (userError "getFileInfo")) . Vault.lookup getFileInfoKey . vault

warp/Network/Wai/Handler/Warp/Date.hs+18−14

@@ -5,6 +5,9 @@ module Network.Wai.Handler.Warp.Date (

5 , getDate

6 , DateCache

7 , GMTDate

8+#if WINDOWS

9+ , uToH

10+#endif

8 ) where

11 ) where

9

12

10#if __GLASGOW_HASKELL__ < 709

13#if __GLASGOW_HASKELL__ < 709

@@ -12,16 +15,13 @@ import Control.Applicative

12#endif

15#endif

13import Control.AutoUpdate (defaultUpdateSettings, updateAction, mkAutoUpdate)

16import Control.AutoUpdate (defaultUpdateSettings, updateAction, mkAutoUpdate)

14import Data.ByteString.Char8

17import Data.ByteString.Char8

18+import Network.HTTP.Date

15

19

16#if WINDOWS

20#if WINDOWS

17−import Data.Time (formatTime, getCurrentTime)

21+import Data.Time (UTCTime, formatTime, getCurrentTime)

18−# if MIN_VERSION_time(1,5,0)

22+import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds)

19−import Data.Time (defaultTimeLocale)

23+import Foreign.C.Types (CTime(..))

20−# else

21−import System.Locale (defaultTimeLocale)

22−# endif

23#else

24#else

24−import Network.HTTP.Date

25import System.Posix (epochTime)

26#endif

27

@@ -36,17 +36,21 @@ withDateCache :: (DateCache -> IO a) -> IO a

36withDateCache action = initialize >>= action

37

38initialize :: IO DateCache

39−initialize = mkAutoUpdate defaultUpdateSettings { updateAction = getCurrentGMTDate }

39+initialize = mkAutoUpdate defaultUpdateSettings {

40+ updateAction = formatHTTPDate <$> getCurrentHTTPDate

41+ }

40

42

41−-- | Getting 'GMTDate' based on 'DateCache'.

43+-- | Getting current 'GMTDate' based on 'DateCache'.

42getDate :: DateCache -> IO GMTDate

44getDate :: DateCache -> IO GMTDate

43getDate = id

45getDate = id

44

46

45−getCurrentGMTDate :: IO GMTDate

46#ifdef WINDOWS

47#ifdef WINDOWS

47−getCurrentGMTDate = formatDate <$> getCurrentTime

48+uToH :: UTCTime -> HTTPDate

48− where

49+uToH = epochTimeToHTTPDate . CTime . truncate . utcTimeToPOSIXSeconds

49− formatDate = pack . formatTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S GMT"

50+

51+getCurrentHTTPDate :: IO HTTPDate

52+getCurrentHTTPDate = uToH <$> getCurrentTime

50#else

53#else

54+getCurrentHTTPDate :: IO HTTPDate

51−getCurrentGMTDate = formatHTTPDate . epochTimeToHTTPDate <$> epochTime

55+getCurrentHTTPDate = epochTimeToHTTPDate <$> epochTime

52#endif

56#endif

warp/Network/Wai/Handler/Warp/FileInfoCache.hsnew file+106

@@ -0,0 +1,106 @@

1+{-# LANGUAGE RecordWildCards, CPP #-}

2+

3+module Network.Wai.Handler.Warp.FileInfoCache (

4+ FileInfo(..)

5+ , withFileInfoCache

6+ , getInfo -- test purpose only

7+ ) where

8+

9+import Control.Exception as E

10+import Control.Monad (void)

11+import Control.Reaper

12+import Data.ByteString (ByteString)

13+import Data.HashMap.Strict (HashMap)

14+import qualified Data.HashMap.Strict as M

15+import Network.HTTP.Date

16+import System.PosixCompat.Files

17+

18+#if WINDOWS

19+import Data.Time (UTCTime)

20+import Network.Wai.Handler.Warp.Date (uToH)

21+#endif

22+

23+----------------------------------------------------------------

24+

25+-- | File information.

26+data FileInfo = FileInfo {

27+ fileInfoName :: !FilePath

28+ , fileInfoSize :: !Integer

29+ , fileInfoTime :: HTTPDate -- ^ Modification time

30+ , fileInfoDate :: ByteString -- ^ Modification time in the GMT format

31+ } deriving (Eq, Show)

32+

33+data Entry = Negative | Positive FileInfo

34+type Cache = HashMap FilePath Entry

35+type FileInfoCache = Reaper Cache (FilePath,Entry)

36+

37+----------------------------------------------------------------

38+

39+-- | Getting the file information corresponding to the file.

40+getInfo :: FilePath -> IO FileInfo

41+getInfo path = do

42+ fs <- getFileStatus path -- file access

43+ let regular = not (isDirectory fs)

44+ readable = fileMode fs `intersectFileModes` ownerReadMode /= 0

45+ if regular && readable then do

46+ let time = epochTimeToHTTPDate $ modificationTime fs

47+ date = formatHTTPDate time

48+ size = fromIntegral $ fileSize fs

49+ info = FileInfo {

50+ fileInfoName = path

51+ , fileInfoSize = size

52+ , fileInfoTime = time

53+ , fileInfoDate = date

54+ }

55+ return info

56+ else

57+ throwIO (userError "FileInfoCache:getInfo")

58+

59+----------------------------------------------------------------

60+

61+getAndRegisterInfo :: FileInfoCache -> FilePath -> IO FileInfo

62+getAndRegisterInfo reaper@Reaper{..} path = do

63+ cache <- reaperRead

64+ case M.lookup path cache of

65+ Just Negative -> throwIO (userError "FileInfoCache:getAndRegisterInfo")

66+ Just (Positive x) -> return x

67+ Nothing -> positive reaper path `E.onException` negative reaper path

68+

69+positive :: FileInfoCache -> FilePath -> IO FileInfo

70+positive Reaper{..} path = do

71+ info <- getInfo path

72+ reaperAdd (path, Positive info)

73+ return info

74+

75+negative :: FileInfoCache -> FilePath -> IO FileInfo

76+negative Reaper{..} path = do

77+ reaperAdd (path,Negative)

78+ throwIO (userError "FileInfoCache:negative")

79+

80+----------------------------------------------------------------

81+

82+-- | Creating a file information cache

83+-- and executing the action in the second argument.

84+-- The first argument is a cache duration in second.

85+withFileInfoCache :: Int -> ((FilePath -> IO FileInfo) -> IO a) -> IO a

86+withFileInfoCache 0 action = action getInfo

87+withFileInfoCache duration action = E.bracket (initialize duration)

88+ terminate

89+ (\c -> action (getAndRegisterInfo c))

90+

91+initialize :: Int -> IO FileInfoCache

92+initialize duration = mkReaper settings

93+ where

94+ settings = defaultReaperSettings {

95+ reaperAction = override

96+ , reaperDelay = duration * 1000000

97+ , reaperCons = uncurry M.insert

98+ , reaperNull = M.null

99+ , reaperEmpty = M.empty

100+ }

101+

102+override :: Cache -> IO (Cache -> Cache)

103+override _ = return $ const M.empty

104+

105+terminate :: FileInfoCache -> IO ()

106+terminate x = void $ reaperStop x

warp/Network/Wai/Handler/Warp/Internal.hs+3

@@ -67,6 +67,8 @@ module Network.Wai.Handler.Warp.Internal (

67 , module Network.Wai.Handler.Warp.Timeout

68 -- * File descriptor cache

69 , module Network.Wai.Handler.Warp.FdCache

70+ -- * File information cache

71+ , module Network.Wai.Handler.Warp.FileInfoCache

70 -- * Date

72 -- * Date

71 , module Network.Wai.Handler.Warp.Date

73 , module Network.Wai.Handler.Warp.Date

72 -- * Request and response

74 -- * Request and response

@@ -78,6 +80,7 @@ module Network.Wai.Handler.Warp.Internal (

78import Network.Wai.Handler.Warp.Buffer

80import Network.Wai.Handler.Warp.Buffer

79import Network.Wai.Handler.Warp.Date

81import Network.Wai.Handler.Warp.Date

80import Network.Wai.Handler.Warp.FdCache

82import Network.Wai.Handler.Warp.FdCache

83+import Network.Wai.Handler.Warp.FileInfoCache

81import Network.Wai.Handler.Warp.Header

84import Network.Wai.Handler.Warp.Header

82import Network.Wai.Handler.Warp.Recv

85import Network.Wai.Handler.Warp.Recv

83import Network.Wai.Handler.Warp.Request

86import Network.Wai.Handler.Warp.Request

warp/Network/Wai/Handler/Warp/Request.hs+10−3

@@ -7,6 +7,7 @@ module Network.Wai.Handler.Warp.Request (

7 recvRequest

8 , headerLines

9 , pauseTimeoutKey

10+ , getFileInfoKey

10 ) where

11 ) where

11

12

12import qualified Control.Concurrent as Conc (yield)

13import qualified Control.Concurrent as Conc (yield)

@@ -21,6 +22,7 @@ import qualified Network.HTTP.Types as H

21import Network.Socket (SockAddr)

22import Network.Socket (SockAddr)

22import Network.Wai

23import Network.Wai

23import Network.Wai.Handler.Warp.Conduit

24import Network.Wai.Handler.Warp.Conduit

25+import Network.Wai.Handler.Warp.FileInfoCache

24import Network.Wai.Handler.Warp.Header

26import Network.Wai.Handler.Warp.Header

25import Network.Wai.Handler.Warp.ReadInt

27import Network.Wai.Handler.Warp.ReadInt

26import Network.Wai.Handler.Warp.RequestHeader

28import Network.Wai.Handler.Warp.RequestHeader

@@ -81,9 +83,7 @@ recvRequest settings conn ii addr src = do

81 , isSecure = False

83 , isSecure = False

82 , remoteHost = addr

84 , remoteHost = addr

83 , requestBody = rbody'

85 , requestBody = rbody'

84− , vault = Vault.insert pauseTimeoutKey

86+ , vault = vaultValue

85− (Timeout.pause th)

86− Vault.empty

87 , requestBodyLength = bodyLength

88 , requestHeaderHost = idxhdr ! idxHost

89 , requestHeaderRange = idxhdr ! idxRange

@@ -91,6 +91,9 @@ recvRequest settings conn ii addr src = do

91 return (req, remainingRef, idxhdr, rbodyFlush)

92 where

93 th = threadHandle ii

94+ vaultValue = Vault.insert pauseTimeoutKey (Timeout.pause th)

95+ $ Vault.insert getFileInfoKey (fileInfo ii)

96+ Vault.empty

94

97

95----------------------------------------------------------------

98----------------------------------------------------------------

96

99

@@ -278,3 +281,7 @@ checkCR bs pos = if pos > 0 && 13 == S.index bs p then p else pos -- 13 is CR

278pauseTimeoutKey :: Vault.Key (IO ())

281pauseTimeoutKey :: Vault.Key (IO ())

279pauseTimeoutKey = unsafePerformIO Vault.newKey

282pauseTimeoutKey = unsafePerformIO Vault.newKey

280{-# NOINLINE pauseTimeoutKey #-}

283{-# NOINLINE pauseTimeoutKey #-}

284+

285+getFileInfoKey :: Vault.Key (FilePath -> IO FileInfo)

286+getFileInfoKey = unsafePerformIO Vault.newKey

287+{-# NOINLINE getFileInfoKey #-}

warp/Network/Wai/Handler/Warp/Response.hs+18−10

@@ -57,6 +57,7 @@ import Network.Wai

57import Network.Wai.Handler.Warp.Buffer (toBuilderBuffer)

58import qualified Network.Wai.Handler.Warp.Date as D

59import qualified Network.Wai.Handler.Warp.FdCache as F

60+import qualified Network.Wai.Handler.Warp.FileInfoCache as I

60import Network.Wai.Handler.Warp.Header

61import Network.Wai.Handler.Warp.Header

61import Network.Wai.Handler.Warp.IO (toBufIOWith)

62import Network.Wai.Handler.Warp.IO (toBufIOWith)

62import Network.Wai.Handler.Warp.ResponseHeader

63import Network.Wai.Handler.Warp.ResponseHeader

@@ -77,11 +78,17 @@ import qualified Paths_warp

77

78

78fileRange :: H.Status -> H.ResponseHeaders -> FilePath

79fileRange :: H.Status -> H.ResponseHeaders -> FilePath

79 -> Maybe FilePart -> Maybe HeaderValue

80 -> Maybe FilePart -> Maybe HeaderValue

81+ -> (FilePath -> IO I.FileInfo)

80 -> IO (Either IOException

82 -> IO (Either IOException

81 (H.Status, H.ResponseHeaders, Integer, Integer))

83 (H.Status, H.ResponseHeaders, Integer, Integer))

82−fileRange s0 hs0 path Nothing mRange =

84+fileRange s0 hs0 path Nothing mRange get = do

85+ efinfo <- try (get path)

86+ case efinfo of

87+ Left e -> return $ Left e

88+ Right finfo -> do

83− fmap (fileRangeSized s0 hs0 Nothing mRange) <$> tryGetFileSize path

89+ let ret = fileRangeSized s0 hs0 Nothing mRange $ I.fileInfoSize finfo

90+ return $ Right ret

84−fileRange s0 hs0 _ mPart@(Just part) mRange =

91+fileRange s0 hs0 _ mPart@(Just part) mRange _ =

85 return . Right $ fileRangeSized s0 hs0 mPart mRange size

92 return . Right $ fileRangeSized s0 hs0 mPart mRange size

86 where

93 where

87 size = filePartFileSize part

94 size = filePartFileSize part

@@ -155,7 +162,7 @@ sendResponse defServer conn ii req reqidxhdr src response = do

155 hs <- addServerAndDate hs0

162 hs <- addServerAndDate hs0

156 if hasBody req s then do

163 if hasBody req s then do

157 -- See definition of rsp below for proper body stripping.

164 -- See definition of rsp below for proper body stripping.

158− sendRsp conn mfdc ver s hs rsp

165+ sendRsp conn ii ver s hs rsp

159 T.tickle th

166 T.tickle th

160 return ret

167 return ret

161 else do

168 else do

@@ -169,7 +176,6 @@ sendResponse defServer conn ii req reqidxhdr src response = do

169 rspidxhdr = indexResponseHeader hs0

176 rspidxhdr = indexResponseHeader hs0

170 th = threadHandle ii

177 th = threadHandle ii

171 dc = dateCacher ii

178 dc = dateCacher ii

172− mfdc = fdCacher ii

173 addServerAndDate = addDate dc rspidxhdr . addServer defServer rspidxhdr

179 addServerAndDate = addDate dc rspidxhdr . addServer defServer rspidxhdr

174 mRange = reqidxhdr ! idxRange

180 mRange = reqidxhdr ! idxRange

175 (isPersist,isChunked) = infoFromRequest req reqidxhdr

181 (isPersist,isChunked) = infoFromRequest req reqidxhdr

@@ -220,20 +226,20 @@ data Rsp = RspFile FilePath (Maybe FilePart) (Maybe HeaderValue) (IO ())

220----------------------------------------------------------------

226----------------------------------------------------------------

221

227

222sendRsp :: Connection

228sendRsp :: Connection

223− -> Maybe F.MutableFdCache

229+ -> InternalInfo

224 -> H.HttpVersion

230 -> H.HttpVersion

225 -> H.Status

231 -> H.Status

226 -> H.ResponseHeaders

232 -> H.ResponseHeaders

227 -> Rsp

233 -> Rsp

228 -> IO ()

234 -> IO ()

229−sendRsp conn mfdc ver s0 hs0 (RspFile path mPart mRange hook) = do

235+sendRsp conn ii ver s0 hs0 (RspFile path mPart mRange hook) = do

230− ex <- fileRange s0 hs0 path mPart mRange

236+ ex <- fileRange s0 hs0 path mPart mRange get

231 case ex of

237 case ex of

232 Left _ex ->

238 Left _ex ->

233#ifdef WARP_DEBUG

239#ifdef WARP_DEBUG

234 print _ex >>

240 print _ex >>

235#endif

241#endif

236− sendRsp conn mfdc ver s2 hs2 (RspBuilder body True)

242+ sendRsp conn ii ver s2 hs2 (RspBuilder body True)

237 Right (s, hs, beg, len)

243 Right (s, hs, beg, len)

238 | len >= 0 -> do

244 | len >= 0 -> do

239 lheader <- composeHeader ver s hs

245 lheader <- composeHeader ver s hs

@@ -251,13 +257,15 @@ sendRsp conn mfdc ver s0 hs0 (RspFile path mPart mRange hook) = do

251#endif

257#endif

252 connSendFile conn fid beg len hook' [lheader]

258 connSendFile conn fid beg len hook' [lheader]

253 | otherwise ->

259 | otherwise ->

254− sendRsp conn mfdc ver H.status416

260+ sendRsp conn ii ver H.status416

255 (filter (\(k, _) -> k /= "content-length") hs)

261 (filter (\(k, _) -> k /= "content-length") hs)

256 (RspBuilder mempty True)

262 (RspBuilder mempty True)

257 where

263 where

258 s2 = H.status404

264 s2 = H.status404

259 hs2 = replaceHeader H.hContentType "text/plain; charset=utf-8" hs0

265 hs2 = replaceHeader H.hContentType "text/plain; charset=utf-8" hs0

260 body = byteString "File not found"

266 body = byteString "File not found"

267+ mfdc = fdCacher ii

268+ get = fileInfo ii

261

269

262----------------------------------------------------------------

270----------------------------------------------------------------

263

271

warp/Network/Wai/Handler/Warp/Run.hs+18−16

@@ -29,6 +29,7 @@ import Network.Wai.Handler.Warp.Buffer

29import Network.Wai.Handler.Warp.Counter

30import qualified Network.Wai.Handler.Warp.Date as D

31import qualified Network.Wai.Handler.Warp.FdCache as F

32+import qualified Network.Wai.Handler.Warp.FileInfoCache as I

32import Network.Wai.Handler.Warp.HTTP2 (http2, isHTTP2)

33import Network.Wai.Handler.Warp.HTTP2 (http2, isHTTP2)

33import Network.Wai.Handler.Warp.Header

34import Network.Wai.Handler.Warp.Header

34import Network.Wai.Handler.Warp.ReadInt

35import Network.Wai.Handler.Warp.ReadInt

@@ -237,13 +238,18 @@ runServeSettingsConnectionMakerSecure :: Settings

237runServeSettingsConnectionMakerSecure set getConnMaker serveConn = do

238runServeSettingsConnectionMakerSecure set getConnMaker serveConn = do

238 settingsBeforeMainLoop set

239 settingsBeforeMainLoop set

239 counter <- newCounter

240 counter <- newCounter

240−

241− D.withDateCache $ \dc ->

242− F.withFdCache fdCacheDurationInSeconds $ \fc ->

243− withTimeoutManager $ \tm ->

244− acceptConnection set getConnMaker serveConn dc fc tm counter

241+ withII $ acceptConnection set getConnMaker serveConn counter

245 where

242 where

243+ withII action =

244+ D.withDateCache $ \dc ->

245+ F.withFdCache fdCacheDurationInSeconds $ \fc ->

246+ I.withFileInfoCache fdFileInfoDurationInSeconds $ \get ->

247+ withTimeoutManager $ \tm -> do

248+ let ii0 = InternalInfo undefined tm fc get dc -- fixme: undefined

249+ action ii0

250+

246 fdCacheDurationInSeconds = settingsFdCacheDuration set * 1000000

251 fdCacheDurationInSeconds = settingsFdCacheDuration set * 1000000

252+ fdFileInfoDurationInSeconds = settingsFileInfoCacheDuration set * 1000000

247 withTimeoutManager f = case settingsManager set of

253 withTimeoutManager f = case settingsManager set of

248 Just tm -> f tm

254 Just tm -> f tm

249 Nothing -> bracket

255 Nothing -> bracket

@@ -267,12 +273,10 @@ runServeSettingsConnectionMakerSecure set getConnMaker serveConn = do

267acceptConnection :: Settings

273acceptConnection :: Settings

268 -> IO (IO (Connection, Transport), SockAddr)

274 -> IO (IO (Connection, Transport), SockAddr)

269 -> ServeConnection

275 -> ServeConnection

270− -> D.DateCache

271− -> Maybe F.MutableFdCache

272− -> T.Manager

273 -> Counter

276 -> Counter

277+ -> InternalInfo

274 -> IO ()

278 -> IO ()

275−acceptConnection set getConnMaker serveConn dc fc tm counter = do

279+acceptConnection set getConnMaker serveConn counter ii0 = do

276 -- First mask all exceptions in acceptLoop. This is necessary to

280 -- First mask all exceptions in acceptLoop. This is necessary to

277 -- ensure that no async exception is throw between the call to

281 -- ensure that no async exception is throw between the call to

278 -- acceptNewConnection and the registering of connClose.

282 -- acceptNewConnection and the registering of connClose.

@@ -294,7 +298,7 @@ acceptConnection set getConnMaker serveConn dc fc tm counter = do

294 case mx of

298 case mx of

295 Nothing -> return ()

299 Nothing -> return ()

296 Just (mkConn, addr) -> do

300 Just (mkConn, addr) -> do

297− fork set mkConn addr serveConn dc fc tm counter

301+ fork set mkConn addr serveConn counter ii0

298 acceptLoop

302 acceptLoop

299

303

300 acceptNewConnection = do

304 acceptNewConnection = do

@@ -319,12 +323,10 @@ fork :: Settings

319 -> IO (Connection, Transport)

323 -> IO (Connection, Transport)

320 -> SockAddr

324 -> SockAddr

321 -> ServeConnection

325 -> ServeConnection

322− -> D.DateCache

323− -> Maybe F.MutableFdCache

324− -> T.Manager

325 -> Counter

326 -> Counter

327+ -> InternalInfo

326 -> IO ()

328 -> IO ()

327−fork set mkConn addr serveConn dc fc tm counter = settingsFork set $ \ unmask ->

329+fork set mkConn addr serveConn counter ii0 = settingsFork set $ \ unmask ->

328 -- Run the connection maker to get a new connection, and ensure

330 -- Run the connection maker to get a new connection, and ensure

329 -- that the connection is closed. If the mkConn call throws an

331 -- that the connection is closed. If the mkConn call throws an

330 -- exception, we will leak the connection. If the mkConn call is

332 -- exception, we will leak the connection. If the mkConn call is

@@ -339,9 +341,9 @@ fork set mkConn addr serveConn dc fc tm counter = settingsFork set $ \ unmask ->

339

341

340 -- We need to register a timeout handler for this thread, and

342 -- We need to register a timeout handler for this thread, and

341 -- cancel that handler as soon as we exit.

343 -- cancel that handler as soon as we exit.

342− bracket (T.registerKillThread tm) T.cancel $ \th ->

344+ bracket (T.registerKillThread (timeoutManager ii0)) T.cancel $ \th ->

343

345

344− let ii = InternalInfo th tm fc dc

346+ let ii = ii0 { threadHandle = th }

345 -- We now have fully registered a connection close handler

347 -- We now have fully registered a connection close handler

346 -- in the case of all exceptions, so it is safe to one

348 -- in the case of all exceptions, so it is safe to one

347 -- again allow async exceptions.

349 -- again allow async exceptions.

warp/Network/Wai/Handler/Warp/Settings.hs+2

@@ -48,6 +48,7 @@ data Settings = Settings

48 , settingsTimeout :: Int -- ^ Timeout value in seconds. Default value: 30

49 , settingsManager :: Maybe Manager -- ^ Use an existing timeout manager instead of spawning a new one. If used, 'settingsTimeout' is ignored. Default is 'Nothing'

50 , settingsFdCacheDuration :: Int -- ^ Cache duration time of file descriptors in seconds. 0 means that the cache mechanism is not used. Default value: 0

51+ , settingsFileInfoCacheDuration :: Int -- ^ Cache duration time of file information in seconds. 0 means that the cache mechanism is not used. Default value: 0

51 , settingsBeforeMainLoop :: IO ()

52 , settingsBeforeMainLoop :: IO ()

52 -- ^ Code to run after the listening socket is ready but before entering

53 -- ^ Code to run after the listening socket is ready but before entering

53 -- the main event loop. Useful for signaling to tests that they can start

54 -- the main event loop. Useful for signaling to tests that they can start

@@ -119,6 +120,7 @@ defaultSettings = Settings

119 , settingsTimeout = 30

120 , settingsTimeout = 30

120 , settingsManager = Nothing

121 , settingsManager = Nothing

121 , settingsFdCacheDuration = 0

122 , settingsFdCacheDuration = 0

123+ , settingsFileInfoCacheDuration = 0

122 , settingsBeforeMainLoop = return ()

124 , settingsBeforeMainLoop = return ()

123 , settingsFork = void . forkIOWithUnmask

125 , settingsFork = void . forkIOWithUnmask

124 , settingsNoParsePath = False

126 , settingsNoParsePath = False

warp/Network/Wai/Handler/Warp/Types.hs+2

@@ -13,6 +13,7 @@ import Data.Word (Word16, Word8)

13import Foreign.Ptr (Ptr)

14import qualified Network.Wai.Handler.Warp.Date as D

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

16+import qualified Network.Wai.Handler.Warp.FileInfoCache as I

16import qualified Network.Wai.Handler.Warp.Timeout as T

17import qualified Network.Wai.Handler.Warp.Timeout as T

17

18

18#ifndef WINDOWS

19#ifndef WINDOWS

@@ -118,6 +119,7 @@ data InternalInfo = InternalInfo {

118 threadHandle :: T.Handle

119 threadHandle :: T.Handle

119 , timeoutManager :: T.Manager

120 , timeoutManager :: T.Manager

120 , fdCacher :: Maybe F.MutableFdCache

121 , fdCacher :: Maybe F.MutableFdCache

122+ , fileInfo :: FilePath -> IO I.FileInfo

121 , dateCacher :: D.DateCache

123 , dateCacher :: D.DateCache

122 }

124 }

123

125

warp/test/ResponseSpec.hs+2−1

@@ -9,6 +9,7 @@ import Network (connectTo, PortID (PortNumber))

9import Network.HTTP.Types

10import Network.Wai

11import Network.Wai.Handler.Warp

12+import Network.Wai.Handler.Warp.FileInfoCache

12import Network.Wai.Handler.Warp.Response

13import Network.Wai.Handler.Warp.Response

13import RunSpec (withApp)

14import RunSpec (withApp)

14import System.IO (hClose, hFlush)

15import System.IO (hClose, hFlush)

@@ -76,7 +77,7 @@ testFileRange :: String

76 -> Either String (Status, ResponseHeaders, Integer, Integer)

77 -> Either String (Status, ResponseHeaders, Integer, Integer)

77 -> Spec

78 -> Spec

78testFileRange desc s rsphdr file mPart mRange ans = it desc $ do

79testFileRange desc s rsphdr file mPart mRange ans = it desc $ do

79− eres <- fileRange s rsphdr file mPart mRange

80+ eres <- fileRange s rsphdr file mPart mRange getInfo

80 let res = case eres of

81 let res = case eres of

81 Left e -> Left $ show e

82 Left e -> Left $ show e

82 Right r -> Right r

83 Right r -> Right r

warp/warp.cabal+3−2

@@ -53,6 +53,7 @@ Library

53 , stm >= 2.3

54 , word8

55 , hashable

56+ , unordered-containers

56 if flag(network-bytestring)

57 if flag(network-bytestring)

57 Build-Depends: network >= 2.2.1.5 && < 2.2.3

58 Build-Depends: network >= 2.2.1.5 && < 2.2.3

58 , network-bytestring >= 0.1.3 && < 0.1.4

59 , network-bytestring >= 0.1.3 && < 0.1.4

@@ -65,6 +66,7 @@ Library

65 Network.Wai.Handler.Warp.Counter

66 Network.Wai.Handler.Warp.Counter

66 Network.Wai.Handler.Warp.Date

67 Network.Wai.Handler.Warp.Date

67 Network.Wai.Handler.Warp.FdCache

68 Network.Wai.Handler.Warp.FdCache

69+ Network.Wai.Handler.Warp.FileInfoCache

68 Network.Wai.Handler.Warp.HTTP2

70 Network.Wai.Handler.Warp.HTTP2

69 Network.Wai.Handler.Warp.HTTP2.EncodeFrame

71 Network.Wai.Handler.Warp.HTTP2.EncodeFrame

70 Network.Wai.Handler.Warp.HTTP2.HPACK

72 Network.Wai.Handler.Warp.HTTP2.HPACK

@@ -99,7 +101,6 @@ Library

99 if os(windows)

101 if os(windows)

100 Cpp-Options: -DWINDOWS

102 Cpp-Options: -DWINDOWS

101 Build-Depends: time

103 Build-Depends: time

102− , old-locale

103 else

104 else

104 Build-Depends: unix

105 Build-Depends: unix

105 , http-date

106 , http-date

@@ -152,7 +153,6 @@ Test-Suite spec

152 , QuickCheck

153 , QuickCheck

153 , hspec >= 1.3

154 , hspec >= 1.3

154 , time

155 , time

155− , old-locale

156 , text

157 , streaming-commons >= 0.1.10

158 , async

@@ -164,6 +164,7 @@ Test-Suite spec

164 , http2 >= 1.3

165 , word8

166 , hashable

167+ , unordered-containers

167

168

168 if (os(linux) || os(freebsd) || os(darwin)) && flag(allow-sendfilefd)

169 if (os(linux) || os(freebsd) || os(darwin)) && flag(allow-sendfilefd)

169 Cpp-Options: -DSENDFILEFD

170 Cpp-Options: -DSENDFILEFD