@@ -0,0 +1,86 @@
1+{-# LANGUAGE RecordWildCards, CPP #-}
2+
3+module Network.Wai.Handler.Warp.FileInfoCache (
4+ -- * Types
5+ FileInfo(..)
6+ -- * Starter
7+ , fileCacheInit
8+ ) where
9+
10+import Control.Exception as E
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+data FileInfo = FileInfo {
24+ fileInfoName :: !FilePath
25+ , fileInfoSize :: !Integer
26+ , fileInfoTime :: !HTTPDate -- ^ Modification time
27+ , fileInfoDate :: !ByteString -- ^ Modification time in the GMT format
28+ } deriving (Eq, Show)
29+
30+data Entry = Negative | Positive FileInfo
31+type Cache = HashMap FilePath Entry
32+type FileCache = Reaper Cache (FilePath,Entry)
33+
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
41+
42+register :: FileCache -> FilePath -> IO FileInfo
43+register reaper path = do
44+ fs <- getFileStatus path -- file access
45+ let regular = not (isDirectory fs)
46+ readable = fileMode fs `intersectFileModes` ownerReadMode /= 0
47+ if regular && readable then
48+ positive reaper fs path
49+ else
50+ throwIO (userError "go to negative")
51+
52+positive :: FileCache -> FileStatus -> FilePath -> IO FileInfo
53+positive Reaper{..} fs path = do
54+ reaperAdd (path,entry)
55+ 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
66+
67+negative :: FileCache -> FilePath -> IO FileInfo
68+negative Reaper{..} path = do
69+ reaperAdd (path,Negative)
70+ throwIO (userError "fileInfo")
71+
72+----------------------------------------------------------------
73+
74+fileCacheInit :: IO (FilePath -> IO FileInfo)
75+fileCacheInit = mkReaper settings >>= return . fileInfo
76+ where
77+ settings = defaultReaperSettings {
78+ reaperAction = override
79+ , reaperDelay = 10000000 -- 10 seconds -- hard-coding: fixme
80+ , reaperCons = uncurry M.insert
81+ , reaperNull = M.null
82+ , reaperEmpty = M.empty
83+ }
84+
85+override :: Cache -> IO (Cache -> Cache)
86+override _ = return $ const M.empty