mighttpd2-2.8.4: FileCache.hs

module FileCache (fileCacheInit) where

import Control.Concurrent
import Control.Exception
import Control.Exception.IOChoice
import Control.Monad
import Data.ByteString (ByteString)
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as M
import Data.IORef
import Network.HTTP.Date
import Network.Wai.Application.Classic
import System.Posix.Files
import Utils

data Entry = Negative | Positive FileInfo
type Cache = HashMap ByteString Entry
type GetInfo = Path -> IO FileInfo

fileInfo :: IORef Cache -> GetInfo
fileInfo ref path = do
    cache <- readIORef ref
    case M.lookup bpath cache of
        Just Negative     -> throwIO (userError "fileInfo")
        Just (Positive x) -> return x
        Nothing           -> register ||> negative ref path
  where
    bpath = pathByteString path
    sfile = pathString path
    register = do
        fs <- getFileStatus sfile
        if not (isDirectory fs) then
            positive ref fs path
          else
            goNext

positive :: IORef Cache -> FileStatus -> GetInfo
positive ref fs path = do
    strictAtomicModifyIORef ref $ M.insert 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 :: IORef Cache -> GetInfo
negative ref path = do
    strictAtomicModifyIORef ref $ M.insert bpath Negative
    throwIO (userError "fileInfo")
  where
    bpath = pathByteString path

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

fileCacheInit :: IO GetInfo
fileCacheInit = do
    ref <- newIORef M.empty
    void . forkIO $ remover ref
    return $ fileInfo ref

-- atomicModifyIORef is not necessary here.
remover :: IORef Cache -> IO ()
remover ref = forever $ threadDelay 10000000 >> writeIORef ref M.empty