@@ -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