    {-# LANGUAGE CPP #-}
    {-# LANGUAGE RecordWildCards #-}

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

    import Control.Exception (bracket, onException, throwIO)
    import Control.Reaper
    import Network.HTTP.Date
    #if WINDOWS
    import System.PosixCompat.Files
    #else
    import System.Posix.Files
    #endif

    import Network.Wai.Handler.Warp.HashMap (HashMap)
    import qualified Network.Wai.Handler.Warp.HashMap as M
    import Network.Wai.Handler.Warp.Imports

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

    -- | File information.
    data FileInfo = FileInfo
        { FileInfo -> FilePath
    fileInfoName :: !FilePath
        , FileInfo -> Integer
    fileInfoSize :: !Integer
        , FileInfo -> HTTPDate
    fileInfoTime :: HTTPDate
        -- ^ Modification time
        , FileInfo -> ByteString
    fileInfoDate :: ByteString
        -- ^ Modification time in the GMT format
        }
        deriving (FileInfo -> FileInfo -> Bool
    (FileInfo -> FileInfo -> Bool)
    -> (FileInfo -> FileInfo -> Bool) -> Eq FileInfo
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    $c== :: FileInfo -> FileInfo -> Bool
    == :: FileInfo -> FileInfo -> Bool
    $c/= :: FileInfo -> FileInfo -> Bool
    /= :: FileInfo -> FileInfo -> Bool
    Eq, Int -> FileInfo -> ShowS
    [FileInfo] -> ShowS
    FileInfo -> FilePath
    (Int -> FileInfo -> ShowS)
    -> (FileInfo -> FilePath) -> ([FileInfo] -> ShowS) -> Show FileInfo
    forall a.
    (Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
    $cshowsPrec :: Int -> FileInfo -> ShowS
    showsPrec :: Int -> FileInfo -> ShowS
    $cshow :: FileInfo -> FilePath
    show :: FileInfo -> FilePath
    $cshowList :: [FileInfo] -> ShowS
    showList :: [FileInfo] -> ShowS
    Show)

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

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

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

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

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

    getAndRegisterInfo :: FileInfoCache -> FilePath -> IO FileInfo
    getAndRegisterInfo :: FileInfoCache -> FilePath -> IO FileInfo
    getAndRegisterInfo FileInfoCache
    reaper FilePath
    path = do
        cache <- FileInfoCache -> IO Cache
    forall workload item. Reaper workload item -> IO workload
    reaperRead FileInfoCache
    reaper
        case M.lookup path cache of
            Just Entry
    Negative -> IOError -> IO FileInfo
    forall e a. (HasCallStack, Exception e) => e -> IO a
    throwIO (FilePath -> IOError
    userError FilePath
    "FileInfoCache:getAndRegisterInfo")
            Just (Positive FileInfo
    x) -> FileInfo -> IO FileInfo
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return FileInfo
    x
            Maybe Entry
    Nothing ->
                FileInfoCache -> FilePath -> IO FileInfo
    positive FileInfoCache
    reaper FilePath
    path
                    IO FileInfo -> IO FileInfo -> IO FileInfo
    forall a b. IO a -> IO b -> IO a
    `onException` FileInfoCache -> FilePath -> IO FileInfo
    negative FileInfoCache
    reaper FilePath
    path

    positive :: FileInfoCache -> FilePath -> IO FileInfo
    positive :: FileInfoCache -> FilePath -> IO FileInfo
    positive FileInfoCache
    reaper FilePath
    path = do
        info <- FilePath -> IO FileInfo
    getInfo FilePath
    path
        reaperAdd reaper (path, Positive info)
        return info

    negative :: FileInfoCache -> FilePath -> IO FileInfo
    negative :: FileInfoCache -> FilePath -> IO FileInfo
    negative FileInfoCache
    reaper FilePath
    path = do
        FileInfoCache -> (FilePath, Entry) -> IO ()
    forall workload item. Reaper workload item -> item -> IO ()
    reaperAdd FileInfoCache
    reaper (FilePath
    path, Entry
    Negative)
        IOError -> IO FileInfo
    forall e a. (HasCallStack, Exception e) => e -> IO a
    throwIO (FilePath -> IOError
    userError FilePath
    "FileInfoCache:negative")

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

    -- | Creating a file information cache
    --   and executing the action in the second argument.
    --   The first argument is a cache duration in microseconds.
    withFileInfoCache
        :: Int
        -> ((FilePath -> IO FileInfo) -> IO a)
        -> IO a
    withFileInfoCache :: forall a. Int -> ((FilePath -> IO FileInfo) -> IO a) -> IO a
    withFileInfoCache Int
    0 (FilePath -> IO FileInfo) -> IO a
    action = (FilePath -> IO FileInfo) -> IO a
    action FilePath -> IO FileInfo
    getInfoNaive
    withFileInfoCache Int
    duration (FilePath -> IO FileInfo) -> IO a
    action =
        IO FileInfoCache
    -> (FileInfoCache -> IO ()) -> (FileInfoCache -> IO a) -> IO a
    forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
    bracket
            (Int -> IO FileInfoCache
    initialize Int
    duration)
            FileInfoCache -> IO ()
    terminate
            ((FilePath -> IO FileInfo) -> IO a
    action ((FilePath -> IO FileInfo) -> IO a)
    -> (FileInfoCache -> FilePath -> IO FileInfo)
    -> FileInfoCache
    -> IO a
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . FileInfoCache -> FilePath -> IO FileInfo
    getAndRegisterInfo)

    initialize :: Int -> IO FileInfoCache
    initialize :: Int -> IO FileInfoCache
    initialize Int
    duration = ReaperSettings Cache (FilePath, Entry) -> IO FileInfoCache
    forall workload item.
    ReaperSettings workload item -> IO (Reaper workload item)
    mkReaper ReaperSettings Cache (FilePath, Entry)
    settings
      where
        settings :: ReaperSettings Cache (FilePath, Entry)
    settings =
            ReaperSettings [ZonkAny 0] (ZonkAny 0)
    forall item. ReaperSettings [item] item
    defaultReaperSettings
                { reaperAction = override
                , reaperDelay = duration
                , reaperCons = \(FilePath
    path, Entry
    v) -> FilePath -> Entry -> Cache -> Cache
    forall v. FilePath -> v -> HashMap v -> HashMap v
    M.insert FilePath
    path Entry
    v
                , reaperNull = M.isEmpty
                , reaperEmpty = M.empty
                , reaperThreadName = "File info cacher (Reaper)"
                }

    override :: Cache -> IO (Cache -> Cache)
    override :: Cache -> IO (Cache -> Cache)
    override Cache
    _ = (Cache -> Cache) -> IO (Cache -> Cache)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ((Cache -> Cache) -> IO (Cache -> Cache))
    -> (Cache -> Cache) -> IO (Cache -> Cache)
    forall a b. (a -> b) -> a -> b
    $ Cache -> Cache -> Cache
    forall a b. a -> b -> a
    const Cache
    forall v. HashMap v
    M.empty

    terminate :: FileInfoCache -> IO ()
    terminate :: FileInfoCache -> IO ()
    terminate FileInfoCache
    x = IO Cache -> IO ()
    forall (f :: * -> *) a. Functor f => f a -> f ()
    void (IO Cache -> IO ()) -> IO Cache -> IO ()
    forall a b. (a -> b) -> a -> b
    $ FileInfoCache -> IO Cache
    forall workload item. Reaper workload item -> IO workload
    reaperStop FileInfoCache
    x