{-# LANGUAGE RecordWildCards, CPP #-}

module Network.Wai.Handler.Warp.FileInfoCache (
    FileInfo(..)
  , Hash
  , withFileInfoCache
  , getInfo -- test purpose only
  ) where

import Control.Exception as E
import Control.Monad (void)
import Control.Reaper
import Data.ByteString (ByteString)
import Network.HTTP.Date
import Network.Wai.Handler.Warp.HashMap (HashMap)
import qualified Network.Wai.Handler.Warp.HashMap as M
import System.PosixCompat.Files

----------------------------------------------------------------

type Hash = Int

-- | File information.
data FileInfo = FileInfo {
    fileInfoName :: !FilePath
  , fileInfoSize :: !Integer
  , fileInfoTime :: HTTPDate   -- ^ Modification time
  , fileInfoDate :: ByteString -- ^ Modification time in the GMT format
  } deriving (Eq, Show)

data Entry = Negative | Positive FileInfo
type Cache = HashMap FilePath Entry
type FileInfoCache = Reaper Cache (Int,FilePath,Entry)

----------------------------------------------------------------

-- | Getting the file information corresponding to the file.
getInfo :: FilePath -> IO FileInfo
getInfo path = do
    fs <- getFileStatus path -- file access
    let regular = not (isDirectory fs)
        readable = fileMode fs `intersectFileModes` ownerReadMode /= 0
    if regular && readable then do
        let time = epochTimeToHTTPDate $ modificationTime fs
            date = formatHTTPDate time
            size = fromIntegral $ fileSize fs
            info = FileInfo {
                fileInfoName = path
              , fileInfoSize = size
              , fileInfoTime = time
              , fileInfoDate = date
              }
        return info
      else
        throwIO (userError "FileInfoCache:getInfo")

getInfoNaive :: Hash -> FilePath -> IO FileInfo
getInfoNaive _ = getInfo

----------------------------------------------------------------

getAndRegisterInfo :: FileInfoCache -> Hash -> FilePath -> IO FileInfo
getAndRegisterInfo reaper@Reaper{..} h path = do
    cache <- reaperRead
    case M.lookup h path cache of
        Just Negative     -> throwIO (userError "FileInfoCache:getAndRegisterInfo")
        Just (Positive x) -> return x
        Nothing           -> positive reaper h path
                               `E.onException` negative reaper h path

positive :: FileInfoCache -> Hash -> FilePath -> IO FileInfo
positive Reaper{..} h path = do
    info <- getInfo path
    reaperAdd (h, path, Positive info)
    return info

negative :: FileInfoCache -> Hash -> FilePath -> IO FileInfo
negative Reaper{..} h path = do
    reaperAdd (h, path,Negative)
    throwIO (userError "FileInfoCache:negative")

----------------------------------------------------------------

-- | Creating a file information cache
--   and executing the action in the second argument.
--   The first argument is a cache duration in second.
withFileInfoCache :: Int
                  -> ((Hash -> FilePath -> IO FileInfo) -> IO a)
                  -> IO a
withFileInfoCache 0        action = action getInfoNaive
withFileInfoCache duration action =
    E.bracket (initialize duration)
              terminate
              (\r -> action (getAndRegisterInfo r))

initialize :: Hash -> IO FileInfoCache
initialize duration = mkReaper settings
  where
    settings = defaultReaperSettings {
        reaperAction = override
      , reaperDelay  = duration
      , reaperCons   = \(h,k,v) -> M.insert h k v
      , reaperNull   = M.null
      , reaperEmpty  = M.empty
      }

override :: Cache -> IO (Cache -> Cache)
override _ = return $ const M.empty

terminate :: FileInfoCache -> IO ()
terminate x = void $ reaperStop x