{-#LANGUAGE NoImplicitPrelude #-}
{-#LANGUAGE ScopedTypeVariables #-}
{-#LANGUAGE OverloadedStrings #-}
module Web.Sprinkles.Cache.Filesystem
where
import Web.Sprinkles.Prelude
import Data.Char (isAlphaNum, ord, isDigit, isAlpha, chr)
import Prelude (read)
import Web.Sprinkles.Cache
import System.IO (IOMode (..), withFile)
import System.IO.Error (catchIOError)
import System.Directory (removeFile, getDirectoryContents)
import System.FilePath (takeFileName)
import System.PosixCompat.Files (getFileStatus, modificationTime)
import Data.Time.Clock.POSIX
import Data.Char (isAsciiLower, isAsciiUpper, isDigit)
ignoreNonexisting :: a -> IOError -> IO a
ignoreNonexisting r err =
if isDoesNotExistError err
then return r
else ioError err
ignoreNonexisting_ :: IOError -> IO ()
ignoreNonexisting_ = ignoreNonexisting ()
filesystemCache :: (k -> String)
-> (Handle -> v -> IO ())
-> (Handle -> IO v)
-> FilePath
-> POSIXTime
-> Cache k v
filesystemCache serializeKey writeValue readValue cacheDir maxAge =
Cache
{ cacheGet = \key -> do
let filename = keyToFilename key
catchIOError
(do
status <- getFileStatus filename
body <- System.IO.withFile filename ReadMode readValue
return $ Just body
)
(ignoreNonexisting Nothing)
, cachePut = \key val -> do
let filename = keyToFilename key
System.IO.withFile filename WriteMode (\h -> writeValue h val)
, cacheDelete = \key -> do
let filename = keyToFilename key
removeFile filename `catchIOError` ignoreNonexisting_
, cacheVacuum = do
filenames <- map (cacheDir </>) . filter (".cache" `isSuffixOf`) <$> getDirectoryContents cacheDir
timestamped <- forM filenames $ \filename -> do
status <- getFileStatus filename
let ts = realToFrac $ modificationTime status
return (filename, ts)
now <- getPOSIXTime
let expirationTS = now - maxAge
expired = map fst . filter (\(_, ts) -> ts < expirationTS) $ timestamped
forM_ expired $ \filename ->
removeFile filename
`catchIOError` ignoreNonexisting_
return $ length expired
}
where
keyToFilename key = cacheDir </> encodeFilename (serializeKey key) <> ".cache"
encodeFilename :: String -> FilePath
encodeFilename =
concatMap encodeChar
where
encodeChar :: Char -> FilePath
encodeChar c
| isAsciiLower c ||
isAsciiUpper c ||
isDigit c = [c]
| otherwise = '_' : show (ord c)
decodeFilename :: FilePath -> String
decodeFilename "" = ""
decodeFilename ('_':xs) =
let (intpart, remainder) = span isDigit xs
in chr (read intpart):decodeFilename remainder
decodeFilename ('.':xs) = ""
decodeFilename (x:xs)
| isAlpha x = x:decodeFilename xs
| otherwise = decodeFilename xs