module Program.Mighty.FileCache (
GetInfo
, RemoveInfo
, fileCacheInit
) where
import Control.Exception
import Control.Exception.IOChoice
import Control.Reaper
import Data.ByteString (ByteString)
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as M
import Network.HTTP.Date
import Network.Wai.Application.Classic
import System.Posix.Files
data Entry = Negative | Positive FileInfo
type Cache = HashMap ByteString Entry
type GetInfo = Path -> IO FileInfo
type RemoveInfo = IO ()
type FileCache = Reaper Cache (ByteString,Entry)
fileInfo :: FileCache -> GetInfo
fileInfo reaper@Reaper{..} path = do
cache <- reaperRead
case M.lookup bpath cache of
Just Negative -> throwIO (userError "fileInfo")
Just (Positive x) -> return x
Nothing -> register ||> negative reaper path
where
bpath = pathByteString path
sfile = pathString path
register = do
fs <- getFileStatus sfile
let regular = not (isDirectory fs)
readable = fileMode fs `intersectFileModes` ownerReadMode /= 0
if regular && readable then
positive reaper fs path
else
goNext
positive :: FileCache -> FileStatus -> GetInfo
positive Reaper{..} fs path = do
reaperAdd (bpath,entry)
return info
where
info = FileInfo {
fileInfoName = path
, fileInfoSize = size fs
, fileInfoTime = time
, fileInfoDate = formatHTTPDate time
}
size = fromIntegral . fileSize
time = epochTimeToHTTPDate (modificationTime fs)
entry = Positive info
bpath = pathByteString path
negative :: FileCache -> GetInfo
negative Reaper{..} path = do
reaperAdd (bpath,Negative)
throwIO (userError "fileInfo")
where
bpath = pathByteString path
fileCacheInit :: IO GetInfo
fileCacheInit = mkReaper settings >>= return . fileInfo
where
settings = defaultReaperSettings {
reaperAction = override
, reaperDelay = 10000000
, reaperCons = uncurry M.insert
, reaperNull = M.null
, reaperEmpty = M.empty
}
override :: Cache -> IO (Cache -> Cache)
override _ = return $ const M.empty