-- |
-- Formatting time is slow.
-- This package provides mechanisms to cache formatted date.
module System.Date.Cache (
  -- * Types
    DateCacheConf(..)
  , DateCacheGetter
  , DateCacheCloser
  -- * Date cacher
  , ondemandDateCacher
  , clockDateCacher
  ) where

import Control.Applicative
import Control.Concurrent
import Data.ByteString (ByteString)
import Data.IORef

type DateCacheGetter = IO ByteString
type DateCacheCloser = IO ()

data DateCache t = DateCache {
    forall t. DateCache t -> t
timeKey :: !t
  , forall t. DateCache t -> ByteString
formattedDate :: !ByteString
  } deriving (DateCache t -> DateCache t -> Bool
(DateCache t -> DateCache t -> Bool)
-> (DateCache t -> DateCache t -> Bool) -> Eq (DateCache t)
forall t. Eq t => DateCache t -> DateCache t -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall t. Eq t => DateCache t -> DateCache t -> Bool
== :: DateCache t -> DateCache t -> Bool
$c/= :: forall t. Eq t => DateCache t -> DateCache t -> Bool
/= :: DateCache t -> DateCache t -> Bool
Eq, Int -> DateCache t -> ShowS
[DateCache t] -> ShowS
DateCache t -> String
(Int -> DateCache t -> ShowS)
-> (DateCache t -> String)
-> ([DateCache t] -> ShowS)
-> Show (DateCache t)
forall t. Show t => Int -> DateCache t -> ShowS
forall t. Show t => [DateCache t] -> ShowS
forall t. Show t => DateCache t -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall t. Show t => Int -> DateCache t -> ShowS
showsPrec :: Int -> DateCache t -> ShowS
$cshow :: forall t. Show t => DateCache t -> String
show :: DateCache t -> String
$cshowList :: forall t. Show t => [DateCache t] -> ShowS
showList :: [DateCache t] -> ShowS
Show)

data DateCacheConf t = DateCacheConf {
    -- | A function to get a time. E.g 'epochTime' and 'getCurrentTime'.
    forall t. DateCacheConf t -> IO t
getTime :: IO t
    -- | A function to format a time.
  , forall t. DateCacheConf t -> t -> IO ByteString
formatDate :: t -> IO ByteString
  }

newDate :: DateCacheConf t -> t -> IO (DateCache t)
newDate :: forall t. DateCacheConf t -> t -> IO (DateCache t)
newDate DateCacheConf t
setting t
tm = t -> ByteString -> DateCache t
forall t. t -> ByteString -> DateCache t
DateCache t
tm (ByteString -> DateCache t) -> IO ByteString -> IO (DateCache t)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DateCacheConf t -> t -> IO ByteString
forall t. DateCacheConf t -> t -> IO ByteString
formatDate DateCacheConf t
setting t
tm

-- |
-- Date cacher which gets a time and formatted it only when
-- returned getter is executed.
ondemandDateCacher :: Eq t => DateCacheConf t -> IO (DateCacheGetter, DateCacheCloser)
ondemandDateCacher :: forall t.
Eq t =>
DateCacheConf t -> IO (IO ByteString, DateCacheCloser)
ondemandDateCacher DateCacheConf t
setting = do
    ref <- DateCacheConf t -> IO t
forall t. DateCacheConf t -> IO t
getTime DateCacheConf t
setting IO t -> (t -> IO (DateCache t)) -> IO (DateCache t)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= DateCacheConf t -> t -> IO (DateCache t)
forall t. DateCacheConf t -> t -> IO (DateCache t)
newDate DateCacheConf t
setting IO (DateCache t)
-> (DateCache t -> IO (IORef (DateCache t)))
-> IO (IORef (DateCache t))
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= DateCache t -> IO (IORef (DateCache t))
forall a. a -> IO (IORef a)
newIORef
    return $! (getter ref, closer)
  where
    getter :: IORef (DateCache t) -> IO ByteString
getter IORef (DateCache t)
ref = do
        newTm <- DateCacheConf t -> IO t
forall t. DateCacheConf t -> IO t
getTime DateCacheConf t
setting
        cache <- readIORef ref
        let oldTm = DateCache t -> t
forall t. DateCache t -> t
timeKey DateCache t
cache
        if oldTm == newTm then
            return $ formattedDate cache
          else do
            newCache <- newDate setting newTm
            writeIORef ref newCache
            return $ formattedDate newCache
    closer :: DateCacheCloser
closer = () -> DateCacheCloser
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- |
-- Date cacher which gets a time and formatted it every second.
-- This returns a getter.
clockDateCacher :: Eq t => DateCacheConf t -> IO (DateCacheGetter, DateCacheCloser)
clockDateCacher :: forall t.
Eq t =>
DateCacheConf t -> IO (IO ByteString, DateCacheCloser)
clockDateCacher DateCacheConf t
setting = do
    ref <- DateCacheConf t -> IO t
forall t. DateCacheConf t -> IO t
getTime DateCacheConf t
setting IO t -> (t -> IO (DateCache t)) -> IO (DateCache t)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= DateCacheConf t -> t -> IO (DateCache t)
forall t. DateCacheConf t -> t -> IO (DateCache t)
newDate DateCacheConf t
setting IO (DateCache t)
-> (DateCache t -> IO (IORef (DateCache t)))
-> IO (IORef (DateCache t))
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= DateCache t -> IO (IORef (DateCache t))
forall a. a -> IO (IORef a)
newIORef
    tid <- forkIO $ clock ref
    return $! (getter ref, closer tid)
  where
    getter :: IORef (DateCache t) -> IO ByteString
getter IORef (DateCache t)
ref = DateCache t -> ByteString
forall t. DateCache t -> ByteString
formattedDate (DateCache t -> ByteString) -> IO (DateCache t) -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (DateCache t) -> IO (DateCache t)
forall a. IORef a -> IO a
readIORef IORef (DateCache t)
ref
    clock :: IORef (DateCache t) -> IO b
clock IORef (DateCache t)
ref = do
        Int -> DateCacheCloser
threadDelay Int
1000000
        tm <- DateCacheConf t -> IO t
forall t. DateCacheConf t -> IO t
getTime DateCacheConf t
setting
        date <- formatDate setting tm
        let new = DateCache {
                timeKey :: t
timeKey = t
tm
              , formattedDate :: ByteString
formattedDate = ByteString
date
              }
        writeIORef ref new
        clock ref
    closer :: ThreadId -> DateCacheCloser
closer ThreadId
tid = ThreadId -> DateCacheCloser
killThread ThreadId
tid