@@ -3,11 +3,12 @@
33module Network.Wai.Handler.Warp.FileInfoCache (
44 -- * Types
55 FileInfo(..)
6− -- * Starter
7− , fileCacheInit
6+ -- * Functions
7+ , withFileInfoCache
88 ) where
99
1010import Control.Exception as E
11+import Control.Monad (void)
1112import Control.Reaper
1213import Data.ByteString (ByteString)
1314import Data.HashMap.Strict (HashMap)
@@ -20,63 +21,75 @@ import Data.Time (UTCTime)
2021import Network.Wai.Handler.Warp.Date (uToH)
2122#endif
2223
24+----------------------------------------------------------------
25+
2326data FileInfo = FileInfo {
2427 fileInfoName :: !FilePath
2528 , fileInfoSize :: !Integer
26− , fileInfoTime :: !HTTPDate -- ^ Modification time
27− , fileInfoDate :: !ByteString -- ^ Modification time in the GMT format
29+ , fileInfoTime :: HTTPDate -- ^ Modification time
30+ , fileInfoDate :: ByteString -- ^ Modification time in the GMT format
2831 } deriving (Eq, Show)
2932
3033data Entry = Negative | Positive FileInfo
3134type Cache = HashMap FilePath Entry
32−type FileCache = Reaper Cache (FilePath,Entry)
35+type FileInfoCache = Reaper Cache (FilePath,Entry)
3336
34−fileInfo :: FileCache -> FilePath -> IO FileInfo
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
37+----------------------------------------------------------------
4138
42−register :: FileCache -> FilePath -> IO FileInfo
43−register reaper path = do
39+getInfo :: FilePath -> IO FileInfo
40+getInfo path = do
4441 fs <- getFileStatus path -- file access
4542 let regular = not (isDirectory fs)
4643 readable = fileMode fs `intersectFileModes` ownerReadMode /= 0
47− if regular && readable then
48− positive reaper fs path
44+ if regular && readable then do
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
4955 else
50− throwIO (userError "go to negative")
56+ throwIO (userError "FileInfoCache:getInfo")
57+
58+----------------------------------------------------------------
5159
52−positive :: FileCache -> FileStatus -> FilePath -> IO FileInfo
53−positive Reaper{..} fs path = do
54− reaperAdd (path,entry)
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+
68+positive :: FileInfoCache -> FilePath -> IO FileInfo
69+positive Reaper{..} path = do
70+ info <- getInfo path
71+ reaperAdd (path, Positive info)
5572 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
6673
67−negative :: FileCache -> FilePath -> IO FileInfo
74+negative :: FileInfoCache -> FilePath -> IO FileInfo
6875negative Reaper{..} path = do
6976 reaperAdd (path,Negative)
70− throwIO (userError "fileInfo")
77+ throwIO (userError "FileInfoCache:negative")
7178
7279----------------------------------------------------------------
7380
74−fileCacheInit :: IO (FilePath -> IO FileInfo)
75−fileCacheInit = mkReaper settings >>= return . 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
88+initialize duration = mkReaper settings
7689 where
7790 settings = defaultReaperSettings {
7891 reaperAction = override
79− , reaperDelay = 10000000 -- 10 seconds -- hard-coding: fixme
92+ , reaperDelay = duration * 1000000
8093 , reaperCons = uncurry M.insert
8194 , reaperNull = M.null
8295 , reaperEmpty = M.empty
@@ -84,3 +97,6 @@ fileCacheInit = mkReaper settings >>= return . fileInfo
8497
8598override :: Cache -> IO (Cache -> Cache)
8699override _ = return $ const M.empty
100+
101+terminate :: FileInfoCache -> IO ()
102+terminate x = void $ reaperStop x