{-# LANGUAGE NumericUnderscores #-}
-- | Store results of named computations.
module Data.Cache
( create
, cached
, enforce
, Store(..)
, EvictionPolicy(..)
, Cache
, MaxBytes(..)
, MaxAgeDays(..)
)
where
import Control.Exception (try, throwIO, fromException, SomeAsyncException(..))
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad (void)
import Data.ByteString.Lazy (ByteString)
import Data.Time.Clock (UTCTime(..))
import Data.Traversable (for)
import Data.Foldable (traverse_)
import Data.List (isPrefixOf, find, intercalate, sortOn)
import Data.Maybe (mapMaybe, fromMaybe)
import Control.Concurrent.MVar (MVar)
import Data.Map.Strict (Map)
import System.FilePath.Posix ((</>))
import System.Directory (listDirectory, removeFile, getFileSize)
import Text.Read (readMaybe)
import qualified Data.Time.Clock as Time
import qualified Data.Time.Calendar as Time
import qualified Data.ByteString.Lazy as ByteString
import qualified Control.Concurrent.MVar as MVar
import qualified Data.Map.Strict as Map
import qualified Data.Hashable as Hashable
data Cache = Cache
{ cache_eviction :: EvictionPolicy
, cache_inFlight :: MVar (Map Hash (UTCTime, MVar ByteString))
}
newtype Store = Store FilePath
newtype Hash = Hash Int
deriving newtype (Show, Eq, Ord)
data EvictionPolicy
= Evict MaxBytes MaxAgeDays Store
| NoStorage
data MaxBytes = MaxBytes Integer | NoMaxBytes
data MaxAgeDays = MaxAgeDays Int | NoMaxAge
data Entry = Entry
{ entry_hash :: Hash
, entry_time :: UTCTime
}
deriving (Show, Eq)
newtype SerialisedEntry = SerialisedEntry String
deriving Show
create :: MonadIO m => EvictionPolicy -> m Cache
create policy = Cache policy <$> liftIO (MVar.newMVar mempty)
-- | Try to get result from cache. If not present, run computation.
cached :: MonadIO m => Cache -> String -> m ByteString -> m ByteString
cached cache name act = do
now <- liftIO Time.getCurrentTime
let entry = toEntry name now
mcontent <- retrieve cache entry
case mcontent of
Just content -> return content
Nothing -> do
var <- liftIO MVar.newEmptyMVar
liftIO
$ MVar.modifyMVar_ (cache_inFlight cache)
$ return . Map.insert (entry_hash entry) (now, var)
content <- act
liftIO $ MVar.putMVar var content
save cache entry content
return content
enforce :: MonadIO m => EvictionPolicy -> m ()
enforce = \case
NoStorage -> return ()
Evict maxSize maxAge store -> liftIO $ do
serialised <- readEntriesFrom store
let entries = sortOn entry_time $ mapMaybe deserialise serialised
oversize <- overLimit store maxSize entries
overage <- overAge maxAge entries
traverse_ (remove store) $ oversize ++ overage
where
overLimit :: Store -> MaxBytes -> [Entry] -> IO [Entry]
overLimit _ _ [] = return []
overLimit _ NoMaxBytes _ = return []
overLimit store (MaxBytes bytes) (entry:rest) = do
s <- fromMaybe 0 <$> size store entry
let remaining = bytes - s
if remaining >= 0
then overLimit store (MaxBytes remaining) rest
else (entry:) <$> overLimit store (MaxBytes bytes) rest
overAge :: MaxAgeDays -> [Entry] -> IO [Entry]
overAge NoMaxAge _ = return []
overAge (MaxAgeDays days) entries = do
now <- Time.getCurrentTime
let threshold = Time.addUTCTime (-Time.nominalDay * fromIntegral days) now
return $ filter (olderThan threshold) entries
olderThan :: UTCTime -> Entry -> Bool
olderThan threshold (Entry _ time) =
time < threshold
remove :: Store -> Entry -> IO ()
remove store = void . trySync . removeFile . location store
size :: Store -> Entry -> IO (Maybe Integer)
size store = trySync. getFileSize . location store
-- | Catch synchronous exceptions and return Nothing
-- Asynchronous exceptions will kill the action
trySync :: IO a -> IO (Maybe a)
trySync act = do
res <- try act
case res of
Left e | Just (SomeAsyncException _) <- fromException e -> throwIO e
| otherwise -> return Nothing
Right r -> return $ Just r
location :: Store -> Entry -> FilePath
location store = fileName store . serialise
fileName :: Store -> SerialisedEntry -> FilePath
fileName (Store path) (SerialisedEntry s) = path </> s
storePath :: Cache -> Maybe Store
storePath Cache{..} =
case cache_eviction of
Evict _ _ store -> Just store
NoStorage -> Nothing
save :: MonadIO m => Cache -> Entry -> ByteString -> m ()
save cache entry content
| Just store <- storePath cache
= liftIO $ ByteString.writeFile (location store entry) content
| otherwise
= return ()
toEntry :: String -> UTCTime -> Entry
toEntry name time = Entry
{ entry_hash = hash
, entry_time = time
}
where
hash = Hash $ abs $ Hashable.hash name
serialise :: Entry -> SerialisedEntry
serialise (Entry (Hash hash) (UTCTime day offset)) = SerialisedEntry
$ intercalate [separator]
[ show hash, Time.showGregorian day, show (Time.diffTimeToPicoseconds offset) ]
separator :: Char
separator = '-'
deserialise :: SerialisedEntry -> Maybe Entry
deserialise (SerialisedEntry str) =
case mapMaybe readMaybe $ splitBy separator str of
[h, year, month, day, offset] ->
let days = Time.fromGregorian (toInteger year) month day
diff = Time.picosecondsToDiffTime $ toInteger offset
in
return $ Entry (Hash h) (UTCTime days diff)
_ -> Nothing
where
splitBy _ [] = []
splitBy x xs = case drop 1 <$> break (== x) xs of
([] , rest) -> splitBy x rest
(part, rest) -> part : splitBy x rest
-- | Whether an entry an a serialised entry point to the same content.
matches :: SerialisedEntry -> SerialisedEntry -> Bool
matches (SerialisedEntry a) (SerialisedEntry b) =
takeWhile (/= separator) a `isPrefixOf` b
retrieve :: MonadIO m => Cache -> Entry -> m (Maybe ByteString)
retrieve Cache{..} entry@(Entry hash _) = liftIO $ do
inFlight <- fromInFlight
case inFlight of
Just res -> return $ Just res
Nothing -> fromStorage
where
fromInFlight = do
inFlight <- MVar.readMVar cache_inFlight
case Map.lookup hash inFlight of
Just (_, mvar) -> Just <$> MVar.readMVar mvar
Nothing -> return Nothing
fromStorage = case cache_eviction of
Evict _ _ path -> readFrom path
NoStorage -> return Nothing
readFrom store = do
stored <- readEntriesFrom store
for (find (matches $ serialise entry) stored) $ \found ->
ByteString.readFile (fileName store found)
readEntriesFrom :: MonadIO m => Store -> m [SerialisedEntry]
readEntriesFrom (Store path) =
fmap (fmap SerialisedEntry) $ liftIO $ listDirectory path