{-# 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 -> EvictionPolicy
cache_eviction :: EvictionPolicy
  , Cache -> MVar (Map Hash (UTCTime, MVar ByteString))
cache_inFlight :: MVar (Map Hash (UTCTime, MVar ByteString))
  }

newtype Store = Store FilePath
newtype Hash = Hash Int
  deriving newtype (MonthOfYear -> Hash -> ShowS
[Hash] -> ShowS
Hash -> String
forall a.
(MonthOfYear -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Hash] -> ShowS
$cshowList :: [Hash] -> ShowS
show :: Hash -> String
$cshow :: Hash -> String
showsPrec :: MonthOfYear -> Hash -> ShowS
$cshowsPrec :: MonthOfYear -> Hash -> ShowS
Show, Hash -> Hash -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Hash -> Hash -> Bool
$c/= :: Hash -> Hash -> Bool
== :: Hash -> Hash -> Bool
$c== :: Hash -> Hash -> Bool
Eq, Eq Hash
Hash -> Hash -> Bool
Hash -> Hash -> Ordering
Hash -> Hash -> Hash
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Hash -> Hash -> Hash
$cmin :: Hash -> Hash -> Hash
max :: Hash -> Hash -> Hash
$cmax :: Hash -> Hash -> Hash
>= :: Hash -> Hash -> Bool
$c>= :: Hash -> Hash -> Bool
> :: Hash -> Hash -> Bool
$c> :: Hash -> Hash -> Bool
<= :: Hash -> Hash -> Bool
$c<= :: Hash -> Hash -> Bool
< :: Hash -> Hash -> Bool
$c< :: Hash -> Hash -> Bool
compare :: Hash -> Hash -> Ordering
$ccompare :: Hash -> Hash -> Ordering
Ord)

data EvictionPolicy
  = Evict MaxBytes MaxAgeDays Store
  | NoStorage

data MaxBytes   = MaxBytes Integer | NoMaxBytes
data MaxAgeDays = MaxAgeDays Int | NoMaxAge

data Entry = Entry
  { Entry -> Hash
entry_hash :: Hash
  , Entry -> UTCTime
entry_time :: UTCTime
  }
  deriving (MonthOfYear -> Entry -> ShowS
[Entry] -> ShowS
Entry -> String
forall a.
(MonthOfYear -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Entry] -> ShowS
$cshowList :: [Entry] -> ShowS
show :: Entry -> String
$cshow :: Entry -> String
showsPrec :: MonthOfYear -> Entry -> ShowS
$cshowsPrec :: MonthOfYear -> Entry -> ShowS
Show, Entry -> Entry -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Entry -> Entry -> Bool
$c/= :: Entry -> Entry -> Bool
== :: Entry -> Entry -> Bool
$c== :: Entry -> Entry -> Bool
Eq)

newtype SerialisedEntry = SerialisedEntry String
  deriving MonthOfYear -> SerialisedEntry -> ShowS
[SerialisedEntry] -> ShowS
SerialisedEntry -> String
forall a.
(MonthOfYear -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SerialisedEntry] -> ShowS
$cshowList :: [SerialisedEntry] -> ShowS
show :: SerialisedEntry -> String
$cshow :: SerialisedEntry -> String
showsPrec :: MonthOfYear -> SerialisedEntry -> ShowS
$cshowsPrec :: MonthOfYear -> SerialisedEntry -> ShowS
Show

create :: MonadIO m => EvictionPolicy -> m Cache
create :: forall (m :: * -> *). MonadIO m => EvictionPolicy -> m Cache
create EvictionPolicy
policy = EvictionPolicy
-> MVar (Map Hash (UTCTime, MVar ByteString)) -> Cache
Cache EvictionPolicy
policy forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall a. a -> IO (MVar a)
MVar.newMVar forall a. Monoid a => a
mempty)

-- | Try to get result from cache. If not present, run computation.
cached :: MonadIO m => Cache -> String -> m ByteString -> m ByteString
cached :: forall (m :: * -> *).
MonadIO m =>
Cache -> String -> m ByteString -> m ByteString
cached Cache
cache String
name m ByteString
act = do
  UTCTime
now <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
Time.getCurrentTime
  let entry :: Entry
entry = String -> UTCTime -> Entry
toEntry String
name UTCTime
now
  Maybe ByteString
mcontent <- forall (m :: * -> *).
MonadIO m =>
Cache -> Entry -> m (Maybe ByteString)
retrieve Cache
cache Entry
entry
  case Maybe ByteString
mcontent of
    Just ByteString
content -> forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
content
    Maybe ByteString
Nothing -> do
      MVar ByteString
var <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a. IO (MVar a)
MVar.newEmptyMVar
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
        forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> (a -> IO a) -> IO ()
MVar.modifyMVar_ (Cache -> MVar (Map Hash (UTCTime, MVar ByteString))
cache_inFlight Cache
cache)
        forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (Entry -> Hash
entry_hash Entry
entry) (UTCTime
now, MVar ByteString
var)
      ByteString
content <- m ByteString
act
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> a -> IO ()
MVar.putMVar MVar ByteString
var ByteString
content
      forall (m :: * -> *).
MonadIO m =>
Cache -> Entry -> ByteString -> m ()
save Cache
cache Entry
entry ByteString
content
      return ByteString
content

enforce :: MonadIO m => EvictionPolicy -> m ()
enforce :: forall (m :: * -> *). MonadIO m => EvictionPolicy -> m ()
enforce = \case
  EvictionPolicy
NoStorage -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
  Evict MaxBytes
maxSize MaxAgeDays
maxAge Store
store -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
    [SerialisedEntry]
serialised <- forall (m :: * -> *). MonadIO m => Store -> m [SerialisedEntry]
readEntriesFrom Store
store
    let entries :: [Entry]
entries = forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn Entry -> UTCTime
entry_time forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe SerialisedEntry -> Maybe Entry
deserialise [SerialisedEntry]
serialised
    [Entry]
oversize <- Store -> MaxBytes -> [Entry] -> IO [Entry]
overLimit Store
store MaxBytes
maxSize [Entry]
entries
    [Entry]
overage  <- MaxAgeDays -> [Entry] -> IO [Entry]
overAge MaxAgeDays
maxAge [Entry]
entries
    forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Store -> Entry -> IO ()
remove Store
store) forall a b. (a -> b) -> a -> b
$ [Entry]
oversize forall a. [a] -> [a] -> [a]
++ [Entry]
overage
  where
    overLimit :: Store -> MaxBytes -> [Entry] -> IO [Entry]
    overLimit :: Store -> MaxBytes -> [Entry] -> IO [Entry]
overLimit Store
_ MaxBytes
_ [] = forall (m :: * -> *) a. Monad m => a -> m a
return []
    overLimit Store
_ MaxBytes
NoMaxBytes [Entry]
_ = forall (m :: * -> *) a. Monad m => a -> m a
return []
    overLimit Store
store (MaxBytes Integer
bytes) (Entry
entry:[Entry]
rest) = do
      Integer
s <- forall a. a -> Maybe a -> a
fromMaybe Integer
0 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Store -> Entry -> IO (Maybe Integer)
size Store
store Entry
entry
      let remaining :: Integer
remaining = Integer
bytes forall a. Num a => a -> a -> a
- Integer
s
      if Integer
remaining forall a. Ord a => a -> a -> Bool
>= Integer
0
        then Store -> MaxBytes -> [Entry] -> IO [Entry]
overLimit Store
store (Integer -> MaxBytes
MaxBytes Integer
remaining) [Entry]
rest
        else (Entry
entryforall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Store -> MaxBytes -> [Entry] -> IO [Entry]
overLimit Store
store (Integer -> MaxBytes
MaxBytes Integer
bytes) [Entry]
rest

    overAge :: MaxAgeDays -> [Entry] -> IO [Entry]
    overAge :: MaxAgeDays -> [Entry] -> IO [Entry]
overAge MaxAgeDays
NoMaxAge [Entry]
_ = forall (m :: * -> *) a. Monad m => a -> m a
return []
    overAge (MaxAgeDays MonthOfYear
days) [Entry]
entries = do
      UTCTime
now <- IO UTCTime
Time.getCurrentTime
      let threshold :: UTCTime
threshold = NominalDiffTime -> UTCTime -> UTCTime
Time.addUTCTime (-NominalDiffTime
Time.nominalDay forall a. Num a => a -> a -> a
* forall a b. (Integral a, Num b) => a -> b
fromIntegral MonthOfYear
days) UTCTime
now
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (UTCTime -> Entry -> Bool
olderThan UTCTime
threshold) [Entry]
entries

    olderThan :: UTCTime -> Entry -> Bool
    olderThan :: UTCTime -> Entry -> Bool
olderThan UTCTime
threshold (Entry Hash
_ UTCTime
time) =
      UTCTime
time forall a. Ord a => a -> a -> Bool
< UTCTime
threshold

    remove :: Store -> Entry -> IO ()
    remove :: Store -> Entry -> IO ()
remove Store
store = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IO a -> IO (Maybe a)
trySync forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
removeFile forall b c a. (b -> c) -> (a -> b) -> a -> c
. Store -> Entry -> String
location Store
store

    size :: Store -> Entry -> IO (Maybe Integer)
    size :: Store -> Entry -> IO (Maybe Integer)
size Store
store = forall a. IO a -> IO (Maybe a)
trySyncforall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO Integer
getFileSize forall b c a. (b -> c) -> (a -> b) -> a -> c
. Store -> Entry -> String
location Store
store

-- | Catch synchronous exceptions and return Nothing
-- Asynchronous exceptions will kill the action
trySync :: IO a -> IO (Maybe a)
trySync :: forall a. IO a -> IO (Maybe a)
trySync IO a
act = do
  Either SomeException a
res <- forall e a. Exception e => IO a -> IO (Either e a)
try IO a
act
  case Either SomeException a
res of
    Left SomeException
e | Just (SomeAsyncException e
_) <- forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e -> forall e a. Exception e => e -> IO a
throwIO SomeException
e
           | Bool
otherwise -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    Right a
r -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just a
r

location :: Store -> Entry -> FilePath
location :: Store -> Entry -> String
location Store
store = Store -> SerialisedEntry -> String
fileName Store
store forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entry -> SerialisedEntry
serialise

fileName :: Store -> SerialisedEntry -> FilePath
fileName :: Store -> SerialisedEntry -> String
fileName (Store String
path) (SerialisedEntry String
s) = String
path String -> ShowS
</> String
s

storePath :: Cache -> Maybe Store
storePath :: Cache -> Maybe Store
storePath Cache{MVar (Map Hash (UTCTime, MVar ByteString))
EvictionPolicy
cache_inFlight :: MVar (Map Hash (UTCTime, MVar ByteString))
cache_eviction :: EvictionPolicy
cache_inFlight :: Cache -> MVar (Map Hash (UTCTime, MVar ByteString))
cache_eviction :: Cache -> EvictionPolicy
..} =
  case EvictionPolicy
cache_eviction of
    Evict MaxBytes
_ MaxAgeDays
_ Store
store -> forall a. a -> Maybe a
Just Store
store
    EvictionPolicy
NoStorage       -> forall a. Maybe a
Nothing

save :: MonadIO m => Cache -> Entry -> ByteString -> m ()
save :: forall (m :: * -> *).
MonadIO m =>
Cache -> Entry -> ByteString -> m ()
save Cache
cache Entry
entry ByteString
content
  | Just Store
store <- Cache -> Maybe Store
storePath Cache
cache
  = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> ByteString -> IO ()
ByteString.writeFile (Store -> Entry -> String
location Store
store Entry
entry) ByteString
content
  | Bool
otherwise
  = forall (m :: * -> *) a. Monad m => a -> m a
return ()

toEntry :: String -> UTCTime -> Entry
toEntry :: String -> UTCTime -> Entry
toEntry String
name UTCTime
time = Entry
  { entry_hash :: Hash
entry_hash = Hash
hash
  , entry_time :: UTCTime
entry_time = UTCTime
time
  }
  where
    hash :: Hash
hash = MonthOfYear -> Hash
Hash forall a b. (a -> b) -> a -> b
$ forall a. Num a => a -> a
abs forall a b. (a -> b) -> a -> b
$ forall a. Hashable a => a -> MonthOfYear
Hashable.hash String
name

serialise :: Entry -> SerialisedEntry
serialise :: Entry -> SerialisedEntry
serialise (Entry (Hash MonthOfYear
hash) (UTCTime Day
day DiffTime
offset)) = String -> SerialisedEntry
SerialisedEntry
  forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [[a]] -> [a]
intercalate [Char
separator]
  [ forall a. Show a => a -> String
show MonthOfYear
hash, Day -> String
Time.showGregorian Day
day, forall a. Show a => a -> String
show (DiffTime -> Integer
Time.diffTimeToPicoseconds DiffTime
offset) ]

separator :: Char
separator :: Char
separator = Char
'-'

deserialise :: SerialisedEntry -> Maybe Entry
deserialise :: SerialisedEntry -> Maybe Entry
deserialise (SerialisedEntry String
str) =
  case forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall a. Read a => String -> Maybe a
readMaybe forall a b. (a -> b) -> a -> b
$ forall {t}. Eq t => t -> [t] -> [[t]]
splitBy Char
separator String
str of
  [MonthOfYear
h, MonthOfYear
year, MonthOfYear
month, MonthOfYear
day, MonthOfYear
offset] ->
    let days :: Day
days = Integer -> MonthOfYear -> MonthOfYear -> Day
Time.fromGregorian (forall a. Integral a => a -> Integer
toInteger MonthOfYear
year) MonthOfYear
month MonthOfYear
day
        diff :: DiffTime
diff = Integer -> DiffTime
Time.picosecondsToDiffTime forall a b. (a -> b) -> a -> b
$ forall a. Integral a => a -> Integer
toInteger MonthOfYear
offset
    in
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Hash -> UTCTime -> Entry
Entry (MonthOfYear -> Hash
Hash MonthOfYear
h) (Day -> DiffTime -> UTCTime
UTCTime Day
days DiffTime
diff)
  [MonthOfYear]
_ -> forall a. Maybe a
Nothing
  where
    splitBy :: t -> [t] -> [[t]]
splitBy t
_ [] = []
    splitBy t
x [t]
xs = case forall a. MonthOfYear -> [a] -> [a]
drop MonthOfYear
1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (a -> Bool) -> [a] -> ([a], [a])
break (forall a. Eq a => a -> a -> Bool
== t
x) [t]
xs of
      ([]  , [t]
rest) -> t -> [t] -> [[t]]
splitBy t
x [t]
rest
      ([t]
part, [t]
rest) -> [t]
part forall a. a -> [a] -> [a]
: t -> [t] -> [[t]]
splitBy t
x [t]
rest

-- | Whether an entry an a serialised entry point to the same content.
matches :: SerialisedEntry -> SerialisedEntry -> Bool
matches :: SerialisedEntry -> SerialisedEntry -> Bool
matches (SerialisedEntry String
a) (SerialisedEntry String
b) =
  forall a. (a -> Bool) -> [a] -> [a]
takeWhile (forall a. Eq a => a -> a -> Bool
/= Char
separator) String
a forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
b

retrieve :: MonadIO m => Cache -> Entry -> m (Maybe ByteString)
retrieve :: forall (m :: * -> *).
MonadIO m =>
Cache -> Entry -> m (Maybe ByteString)
retrieve Cache{MVar (Map Hash (UTCTime, MVar ByteString))
EvictionPolicy
cache_inFlight :: MVar (Map Hash (UTCTime, MVar ByteString))
cache_eviction :: EvictionPolicy
cache_inFlight :: Cache -> MVar (Map Hash (UTCTime, MVar ByteString))
cache_eviction :: Cache -> EvictionPolicy
..} entry :: Entry
entry@(Entry Hash
hash UTCTime
_) = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
  Maybe ByteString
inFlight <- IO (Maybe ByteString)
fromInFlight
  case Maybe ByteString
inFlight of
    Just ByteString
res -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just ByteString
res
    Maybe ByteString
Nothing -> IO (Maybe ByteString)
fromStorage
  where
    fromInFlight :: IO (Maybe ByteString)
fromInFlight = do
      Map Hash (UTCTime, MVar ByteString)
inFlight <- forall a. MVar a -> IO a
MVar.readMVar MVar (Map Hash (UTCTime, MVar ByteString))
cache_inFlight
      case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Hash
hash Map Hash (UTCTime, MVar ByteString)
inFlight of
        Just (UTCTime
_, MVar ByteString
mvar) -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. MVar a -> IO a
MVar.readMVar MVar ByteString
mvar
        Maybe (UTCTime, MVar ByteString)
Nothing        -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

    fromStorage :: IO (Maybe ByteString)
fromStorage = case EvictionPolicy
cache_eviction of
      Evict MaxBytes
_ MaxAgeDays
_ Store
path -> Store -> IO (Maybe ByteString)
readFrom Store
path
      EvictionPolicy
NoStorage      -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

    readFrom :: Store -> IO (Maybe ByteString)
readFrom Store
store = do
      [SerialisedEntry]
stored <- forall (m :: * -> *). MonadIO m => Store -> m [SerialisedEntry]
readEntriesFrom Store
store
      forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (SerialisedEntry -> SerialisedEntry -> Bool
matches forall a b. (a -> b) -> a -> b
$ Entry -> SerialisedEntry
serialise Entry
entry) [SerialisedEntry]
stored) forall a b. (a -> b) -> a -> b
$ \SerialisedEntry
found ->
        String -> IO ByteString
ByteString.readFile (Store -> SerialisedEntry -> String
fileName Store
store SerialisedEntry
found)

readEntriesFrom :: MonadIO m => Store -> m [SerialisedEntry]
readEntriesFrom :: forall (m :: * -> *). MonadIO m => Store -> m [SerialisedEntry]
readEntriesFrom (Store String
path) =
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> SerialisedEntry
SerialisedEntry) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO [String]
listDirectory String
path