-- |
--
-- Copyright:
--   This file is part of the package vimeta. It is subject to the
--   license terms in the LICENSE file found in the top-level
--   directory of this distribution and at:
--
--     https://github.com/pjones/vimeta
--
--   No part of this package, including this file, may be copied,
--   modified, propagated, or distributed except according to the terms
--   contained in the LICENSE file.
--
-- License: BSD-2-Clause
--
-- Caching functions.
module Vimeta.Core.Cache
  ( cacheTMDBConfig,
  )
where

import Data.Aeson as Aeson
import Data.Time.Calendar
import Data.Time.Clock
import qualified Network.API.TheMovieDB as TheMovieDB
import System.Directory
  ( XdgDirectory (..),
    createDirectoryIfMissing,
    doesFileExist,
    getModificationTime,
    getXdgDirectory,
  )
import System.FilePath (takeDirectory, (</>))

-- | Manage cache file expiration.
newtype Age
  = -- | Cap to N days.
    MaxDays Int

ageAsTime :: Age -> UTCTime -> UTCTime
ageAsTime :: Age -> UTCTime -> UTCTime
ageAsTime (MaxDays Int
days) UTCTime
now =
  UTCTime
now {utctDay :: Day
utctDay = Integer -> Day -> Day
addDays (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (- Int
days)) (UTCTime -> Day
utctDay UTCTime
now)}

-- | The file name for catching @TheMovieDB.Configuration@.
tmdbCacheFile :: IO FilePath
tmdbCacheFile :: IO FilePath
tmdbCacheFile =
  XdgDirectory -> FilePath -> IO FilePath
getXdgDirectory XdgDirectory
XdgCache FilePath
"vimeta"
    IO FilePath -> (FilePath -> FilePath) -> IO FilePath
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (FilePath -> FilePath -> FilePath
</> FilePath
"tmdb-config.json")

-- | Produce a cached version of @TheMovieDB.Configuration@ or use
-- the given action to create a cache a new value.
cacheTMDBConfig ::
  (MonadIO m) =>
  m (Either e TheMovieDB.Configuration) ->
  m (Either e TheMovieDB.Configuration)
cacheTMDBConfig :: m (Either e Configuration) -> m (Either e Configuration)
cacheTMDBConfig m (Either e Configuration)
action = do
  FilePath
file <- IO FilePath -> m FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO FilePath
tmdbCacheFile
  FilePath
-> Age -> m (Either e Configuration) -> m (Either e Configuration)
forall (m :: * -> *) a e.
(MonadIO m, FromJSON a, ToJSON a) =>
FilePath -> Age -> m (Either e a) -> m (Either e a)
cache FilePath
file (Int -> Age
MaxDays Int
3) m (Either e Configuration)
action

-- | Generic cache reader.
readCache :: (MonadIO m, FromJSON a) => FilePath -> Age -> m (Maybe a)
readCache :: FilePath -> Age -> m (Maybe a)
readCache FilePath
filename Age
age = do
  Bool
exists <- IO Bool -> m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FilePath -> IO Bool
doesFileExist FilePath
filename)
  if Bool -> Bool
not Bool
exists then Maybe a -> m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing else m (Maybe a)
go
  where
    go :: m (Maybe a)
go = do
      UTCTime
now <- IO UTCTime -> m UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
      UTCTime
modtime <- IO UTCTime -> m UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FilePath -> IO UTCTime
getModificationTime FilePath
filename)

      if UTCTime -> UTCTime -> Bool
fresh UTCTime
now UTCTime
modtime
        then ByteString -> Maybe a
forall a. FromJSON a => ByteString -> Maybe a
Aeson.decode' (ByteString -> Maybe a) -> m ByteString -> m (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> m ByteString
forall (m :: * -> *). MonadIO m => FilePath -> m ByteString
readFileLBS FilePath
filename
        else Maybe a -> m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
    fresh :: UTCTime -> UTCTime -> Bool
    fresh :: UTCTime -> UTCTime -> Bool
fresh UTCTime
now UTCTime
modtime = Age -> UTCTime -> UTCTime
ageAsTime Age
age UTCTime
now UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
<= UTCTime
modtime

-- | Generic cache writer.
writeCache :: (MonadIO m, ToJSON a) => FilePath -> a -> m ()
writeCache :: FilePath -> a -> m ()
writeCache FilePath
filename a
value = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
  Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True (FilePath -> FilePath
takeDirectory FilePath
filename)
  FilePath -> ByteString -> IO ()
forall (m :: * -> *). MonadIO m => FilePath -> ByteString -> m ()
writeFileLBS FilePath
filename (a -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode a
value)

-- | Generic caching function.
cache ::
  (MonadIO m, FromJSON a, ToJSON a) =>
  -- | Cache file.
  FilePath ->
  -- | Age of cache file.
  Age ->
  -- | Action to generate new value.
  m (Either e a) ->
  -- | Cached or new value.
  m (Either e a)
cache :: FilePath -> Age -> m (Either e a) -> m (Either e a)
cache FilePath
file Age
age m (Either e a)
action = do
  Maybe a
cached <- IO (Maybe a) -> m (Maybe a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FilePath -> Age -> IO (Maybe a)
forall (m :: * -> *) a.
(MonadIO m, FromJSON a) =>
FilePath -> Age -> m (Maybe a)
readCache FilePath
file Age
age)

  case Maybe a
cached of
    Just a
c -> Either e a -> m (Either e a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Either e a
forall a b. b -> Either a b
Right a
c)
    Maybe a
Nothing -> do
      Either e a
result <- m (Either e a)
action
      (e -> m ()) -> (a -> m ()) -> Either e a -> m ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (m () -> e -> m ()
forall a b. a -> b -> a
const (m () -> e -> m ()) -> m () -> e -> m ()
forall a b. (a -> b) -> a -> b
$ () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (FilePath -> a -> m ()
forall (m :: * -> *) a.
(MonadIO m, ToJSON a) =>
FilePath -> a -> m ()
writeCache FilePath
file) Either e a
result
      Either e a -> m (Either e a)
forall (m :: * -> *) a. Monad m => a -> m a
return Either e a
result