2ccadb9 · typeable/wai

git.iko.soy/typeable/wai

on master help sign in

running the file info cache with reaper and register it to vault.

2ccadb9Kazu Yamamoto11 years ago

warp/Network/Wai/Handler/Warp/FileInfoCache.hs+51−35

compare with master

unifiedsplit

@@ -3,11 +3,12 @@

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

4 -- * Types

5 FileInfo(..)

6− -- * Starter

6+ -- * Functions

7− , fileCacheInit

7+ , withFileInfoCache

8 ) where

10import Control.Exception as E

11+import Control.Monad (void)

11import Control.Reaper

12import Control.Reaper

12import Data.ByteString (ByteString)

13import Data.ByteString (ByteString)

13import Data.HashMap.Strict (HashMap)

14import Data.HashMap.Strict (HashMap)

@@ -20,63 +21,75 @@ import Data.Time (UTCTime)

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

21import Network.Wai.Handler.Warp.Date (uToH)

21#endif

22#endif

24+----------------------------------------------------------------

25+

23data FileInfo = FileInfo {

26data FileInfo = FileInfo {

24 fileInfoName :: !FilePath

27 fileInfoName :: !FilePath

25 , fileInfoSize :: !Integer

28 , fileInfoSize :: !Integer

26− , fileInfoTime :: !HTTPDate -- ^ Modification time

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

27− , fileInfoDate :: !ByteString -- ^ Modification time in the GMT format

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

28 } deriving (Eq, Show)

31 } deriving (Eq, Show)

30data Entry = Negative | Positive FileInfo

33data Entry = Negative | Positive FileInfo

31type Cache = HashMap FilePath Entry

34type Cache = HashMap FilePath Entry

32−type FileCache = Reaper Cache (FilePath,Entry)

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

34−fileInfo :: FileCache -> FilePath -> IO FileInfo

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

35−fileInfo reaper@Reaper{..} path = do

36− cache <- reaperRead

37− case M.lookup path cache of

38− Just Negative -> throwIO (userError "fileInfo")

39− Just (Positive x) -> return x

40− Nothing -> register reaper path `E.onException` negative reaper path

42−register :: FileCache -> FilePath -> IO FileInfo

39+getInfo :: FilePath -> IO FileInfo

43−register reaper path = do

40+getInfo path = do

44 fs <- getFileStatus path -- file access

41 fs <- getFileStatus path -- file access

45 let regular = not (isDirectory fs)

42 let regular = not (isDirectory fs)

46 readable = fileMode fs `intersectFileModes` ownerReadMode /= 0

43 readable = fileMode fs `intersectFileModes` ownerReadMode /= 0

47− if regular && readable then

44+ if regular && readable then do

48− positive reaper fs path

45+ let time = epochTimeToHTTPDate $ modificationTime fs

46+ date = formatHTTPDate time

47+ size = fromIntegral $ fileSize fs

48+ info = FileInfo {

49+ fileInfoName = path

50+ , fileInfoSize = size

51+ , fileInfoTime = time

52+ , fileInfoDate = date

53+ }

54+ return info

49 else

55 else

50− throwIO (userError "go to negative")

56+ throwIO (userError "FileInfoCache:getInfo")

57+

58+----------------------------------------------------------------

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

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

62+ cache <- reaperRead

63+ case M.lookup path cache of

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

65+ Just (Positive x) -> return x

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

67+

52−positive :: FileCache -> FileStatus -> FilePath -> IO FileInfo

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

53−positive Reaper{..} fs path = do

69+positive Reaper{..} path = do

70+ info <- getInfo path

54− reaperAdd (path,entry)

71+ reaperAdd (path, Positive info)

55 return info

72 return info

56− where

57− info = FileInfo {

58− fileInfoName = path

59− , fileInfoSize = size fs

60− , fileInfoTime = time

61− , fileInfoDate = formatHTTPDate time

62− }

63− size = fromIntegral . fileSize

64− time = epochTimeToHTTPDate (modificationTime fs)

65− entry = Positive info

67−negative :: FileCache -> FilePath -> IO FileInfo

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

68negative Reaper{..} path = do

75negative Reaper{..} path = do

69 reaperAdd (path,Negative)

76 reaperAdd (path,Negative)

70− throwIO (userError "fileInfo")

77+ throwIO (userError "FileInfoCache:negative")

72----------------------------------------------------------------

79----------------------------------------------------------------

74−fileCacheInit :: IO (FilePath -> IO FileInfo)

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

82+withFileInfoCache 0 action = action getInfo

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

84+ terminate

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

86+

87+initialize :: Int -> IO FileInfoCache

75−fileCacheInit = mkReaper settings >>= return . fileInfo

88+initialize duration = mkReaper settings

76 where

89 where

77 settings = defaultReaperSettings {

90 settings = defaultReaperSettings {

78 reaperAction = override

91 reaperAction = override

79− , reaperDelay = 10000000 -- 10 seconds -- hard-coding: fixme

92+ , reaperDelay = duration * 1000000

80 , reaperCons = uncurry M.insert

93 , reaperCons = uncurry M.insert

81 , reaperNull = M.null

94 , reaperNull = M.null

82 , reaperEmpty = M.empty

95 , reaperEmpty = M.empty

@@ -84,3 +97,6 @@ fileCacheInit = mkReaper settings >>= return . fileInfo

85override :: Cache -> IO (Cache -> Cache)

98override :: Cache -> IO (Cache -> Cache)

86override _ = return $ const M.empty

99override _ = return $ const M.empty

100+

101+terminate :: FileInfoCache -> IO ()

102+terminate x = void $ reaperStop x

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

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

83 , isSecure = False

84 , remoteHost = addr

85 , requestBody = rbody'

86− , vault = Vault.insert pauseTimeoutKey

86+ , vault = vaultValue

87− (Timeout.pause th)

88− Vault.empty

89 , requestBodyLength = bodyLength

87 , requestBodyLength = bodyLength

90 , requestHeaderHost = idxhdr ! idxHost

88 , requestHeaderHost = idxhdr ! idxHost

91 , requestHeaderRange = idxhdr ! idxRange

89 , requestHeaderRange = idxhdr ! idxRange

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

93 return (req, remainingRef, idxhdr, rbodyFlush)

91 return (req, remainingRef, idxhdr, rbodyFlush)

94 where

92 where

95 th = threadHandle ii

93 th = threadHandle ii

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

95+ $ Vault.insert getFileInfoKey (fileInfo ii)

96+ Vault.empty

97----------------------------------------------------------------

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

warp/Network/Wai/Handler/Warp/Response.hs+1−1

@@ -80,7 +80,7 @@ fileRange :: H.Status -> H.ResponseHeaders -> FilePath

80 -> IO (Either IOException

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

82fileRange s0 hs0 path Nothing mRange =

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

83+ fmap (fileRangeSized s0 hs0 Nothing mRange) <$> tryGetFileSize path -- fixme: using fileInfo

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

85 return . Right $ fileRangeSized s0 hs0 mPart mRange size

86 where

warp/Network/Wai/Handler/Warp/Run.hs+17−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,12 +238,16 @@ 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 10 $ \get -> -- fixme: hard-coding

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

247 withTimeoutManager f = case settingsManager set of

252 withTimeoutManager f = case settingsManager set of

248 Just tm -> f tm

253 Just tm -> f tm

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

267acceptConnection :: Settings

272acceptConnection :: Settings

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

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

269 -> ServeConnection

274 -> ServeConnection

270− -> D.DateCache

271− -> Maybe F.MutableFdCache

272− -> T.Manager

273 -> Counter

275 -> Counter

276+ -> InternalInfo

274 -> IO ()

277 -> IO ()

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

278+acceptConnection set getConnMaker serveConn counter ii0 = do

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

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

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

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

278 -- acceptNewConnection and the registering of connClose.

281 -- acceptNewConnection and the registering of connClose.

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

294 case mx of

297 case mx of

295 Nothing -> return ()

298 Nothing -> return ()

296 Just (mkConn, addr) -> do

299 Just (mkConn, addr) -> do

297− fork set mkConn addr serveConn dc fc tm counter

300+ fork set mkConn addr serveConn counter ii0

298 acceptLoop

301 acceptLoop

299

302

300 acceptNewConnection = do

303 acceptNewConnection = do

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

319 -> IO (Connection, Transport)

322 -> IO (Connection, Transport)

320 -> SockAddr

323 -> SockAddr

321 -> ServeConnection

324 -> ServeConnection

322− -> D.DateCache

323− -> Maybe F.MutableFdCache

324− -> T.Manager

325 -> Counter

326+ -> InternalInfo

326 -> IO ()

327 -> IO ()

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

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

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

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

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

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

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

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

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

339

340

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

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

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

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

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

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

343

344

344− let ii = InternalInfo th tm fc dc

345+ let ii = ii0 { threadHandle = th }

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

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

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

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

347 -- again allow async exceptions.

348 -- again allow async exceptions.

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

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