OrdECM.hs

{-# LANGUAGE OverloadedStrings #-}
-- |
-- Module : Caching.ExpiringCacheMap.OrdECM
-- Copyright: (c) 2014 Edward L. Blake
-- License: BSD-style
-- Maintainer: Edward L. Blake <edwardlblake@gmail.com>
-- Stability: experimental
-- Portability: portable
--
-- A cache that holds values for a length of time that uses 'Ord' keys with 
-- "Data.Map.Strict".
-- 
-- An example of creating a cache for accessing files:
--
-- > {-# LANGUAGE OverloadedStrings #-}
-- > 
-- > import Caching.ExpiringCacheMap.OrdECM (newECMIO, lookupECM, CacheSettings(..), consistentDuration)
-- > 
-- > import qualified Data.Time.Clock.POSIX as POSIX (POSIXTime, getPOSIXTime)
-- > import qualified Data.ByteString.Char8 as BS
-- > import System.IO (withFile, IOMode(ReadMode))
-- > 
-- > example = do
-- >   filecache <- newECMIO
-- >         (consistentDuration 100 -- Duration between access and expiry time of each item
-- >           (\state id -> do BS.putStrLn "Reading a file again..."
-- >                            withFile (case id :: BS.ByteString of
-- >                                        "file1" -> "file1.txt"
-- >                                        "file2" -> "file2.txt")
-- >                               ReadMode $
-- >                               \fh -> do content <- BS.hGetContents fh
-- >                                         return $! (state, content)))
-- >         (do time <- POSIX.getPOSIXTime
-- >             return (round (time * 100)))
-- >         1 -- Time check frequency: (accumulator `mod` this_number) == 0.
-- >         (CacheWithLRUList
-- >           6     -- Expected size of key-value map when removing elements.
-- >           6     -- Size of map when to remove items from key-value map.
-- >           12    -- Size of list when to compact
-- >           )
-- >   
-- >   -- Use lookupECM whenever the contents of "file1" is needed.
-- >   b <- lookupECM filecache "file1"
-- >   BS.putStrLn b
-- >   return ()
-- > 
--

module Caching.ExpiringCacheMap.OrdECM (
    -- * Create cache
    newECMIO,
    newECMForM,
    consistentDuration,
    
    -- * Request value from cache
    lookupECM,
    
    -- * Value request function state
    -- putValReqState,
    getValReqState,
    
    -- -- * Clear cache
    -- clearCache,
    
    -- * Type
    ECM,
    CacheSettings(..)
) where

import qualified Control.Concurrent.MVar as MV
import qualified Data.Map.Strict as M
import qualified Data.List as L

import Caching.ExpiringCacheMap.Internal.Internal (updateUses, detECM)
import Caching.ExpiringCacheMap.Types
import Caching.ExpiringCacheMap.Internal.Types

-- | Create a new expiring cache for retrieving uncached values via 'IO'
-- interaction (such as in the case of reading a file from disk), with
-- a shared state lock via an 'MV.MVar' to manage cache state.
--
-- Value request and time check request functions are provided as arguments.
--
-- The time check frequency value has to be 1 or higher, with higher values
-- postponing time checks for longer periods of time.
-- 
-- A cache setting specifies how the cache should remove entries when the
-- cache becomes a certain size. The only constructor for this is
-- 'CacheWithLRUList'.
--
newECMIO :: Ord k => (Maybe s -> k -> IO (TimeUnits, (Maybe s, v))) -> (IO TimeUnits)
  -> ECMIncr 
  -> CacheSettings
    -> IO (ECM IO MV.MVar s M.Map k v)
newECMIO retr gettime timecheckmodulo settings = do
  newECMForM retr gettime timecheckmodulo settings
    MV.newMVar MV.modifyMVar MV.readMVar

-- | Create a new expiring cache along arbitrary monads with provided
-- functions to create cache state in 'Monad' m2, and modify and read
-- cache state in 'Monad' m1.
--
-- 'newECMIO' is just a wrapper to this function with 'MV.MVar' functions:
--
-- @
--  newECMIO retr gettime timecheckmodulo cachesettings =
--    newECMForM retr gettime timecheckmodulo cachesettings
--      'MV.newMVar' 'MV.modifyMVar' 'MV.readMVar'
-- @
--
-- Value request and time check request functions are provided as arguments.
--
-- The time check frequency value has to be 1 or higher, with higher values
-- postponing time checks for longer periods of time.
-- 
-- A cache setting specifies how the cache should remove entries when the
-- cache becomes a certain size. The only constructor for this is
-- 'CacheWithLRUList'.
--
newECMForM :: (Monad m1, Monad m2) => Ord k => (Maybe s -> k -> m1 (TimeUnits, (Maybe s, v))) -> (m1 TimeUnits)
  -> ECMIncr
  -> CacheSettings
  -> ECMNewState m2 mv s M.Map k v
  -> ECMEnterState m1 mv s M.Map k v
  -> ECMReadState m1 mv s M.Map k v
    -> m2 (ECM m1 mv s M.Map k v)
newECMForM retr gettime timecheckmodulo (CacheWithLRUList minimumkeep removalsize compactlistsize)
           newstate enterstate readstate =
  if timecheckmodulo <= 0
    then error "Modulo time check must be 1 or higher."
    else do
      m'maps <- newstate $ CacheState ( Nothing, M.empty, 0, ([], 0), 0 )
      return $ ECM ( m'maps, retr, gettime, minimumkeep, timecheckmodulo, removalsize,
                     compactlistsize, enterstate, readstate )

-- | Request a value associated with a key from the cache.
--
--  * If the value is not in the cache, it will be requested through the 
--    function defined through 'newECM', its computation returned and the
--    value stored in the cache state map.
-- 
--  * If the value is in the cache and has not expired, it will be returned.
--
--  * If the value is in the cache and a new time is computed in the same
--    lookup, and the value has been determined to have since expired, it 
--    will be discarded and a new value will be requested for this computation.
--
-- Every 'lookupECM' computation increments an accumulator in the cache state 
-- which is used to keep track of the succession of key accesses. Based on the
-- parameters provided with the 'CacheWithLRUList' constructor, this history 
-- of key accesses is then used to remove entries from the cache back down to 
-- a minimum size. Also, when the modulo of the accumulator and the modulo 
-- value computes to 0, the time request function is invoked. In some cases
-- the accumulator may get incremented more than once in a 'lookupECM'
-- computation.
--
-- As the accumulator is a bound unsigned integer, when the accumulator
-- increments back to 0, the cache state is completely cleared.
-- 
-- The time request function is invoked in one of two different conditions
-- 
--  * When a new key-value entry is requested, the current time is also
--    requested during the same lookup, as a recent time determination is
--    needed for a new entry in the key-value cache.
-- 
--  * When the modulo of the accumulator and a specified value equals to 0.
--
-- When the current time is determined during a lookup, access times of the
-- entries in the key-value cache are compared with the new time to filter
-- out expired entries from the key-value map.
-- 
lookupECM :: (Monad m, Ord k) => ECM m mv s M.Map k v -> k -> m v
lookupECM ecm id = do
  enter m'maps $
    \(CacheState (retr_state, maps, mapsize, uses, incr)) ->
      let incr' = incr + 1
       in if incr' < incr
            -- Word incrementor has cycled back to 0,
            -- so may as well clear the cache completely.
            then lookupECM' (retr_state, M.empty, 0, ([], 0), 0) (0+1)
            else lookupECM' (retr_state, maps, mapsize, uses, incr) incr'
  where
    
    ECM ( m'maps, retr, gettime, minimumkeep, timecheckmodulo, removalsize,
          compactlistsize, enter, _ro ) = ecm
  
    mnub = M.toList . M.fromList . reverse
    lookupECM' (retr_state, maps, mapsize, uses, incr) incr' = do
      let uses' = updateUses uses id incr' compactlistsize mnub
      (ret, do_again) <- det retr_state maps mapsize uses' incr'
      if do_again
        then do let (CacheState (retr_state', maps', mapsize', uses'', incr''), _) = ret
                    uses''' = updateUses uses'' id incr'' compactlistsize mnub
                (ret', _) <- det retr_state' maps' mapsize' uses''' incr''
                return ret'
        else return ret
    
    det retr_state maps mapsize uses' incr' =
      detECM (M.lookup id maps) retr_state (retr retr_state id)
        ( (\time_r -> M.insert id time_r maps),
          (\time_r keepuses -> M.insert id time_r $! M.intersection maps $ M.fromList keepuses),
          mnub, minimumkeep, removalsize )
        gettime
        M.filter
        mapsize M.size
        uses' incr' timecheckmodulo maps


getValReqState :: (Monad m, Ord k) => ECM m mv s M.Map k v -> k -> m (Maybe s)
getValReqState ecm id = do
  CacheState (retr_state, maps, mapsize, uses, incr) <- read m'maps
  return retr_state
  where
    ECM ( m'maps, _, _, _, _, _, _, _, read ) = ecm


{-

These functions would require inclusion of a enter_ function (like modifyMVar_)

putValReqState :: (Monad m, Ord k) => ECM m mv s M.Map k v -> k -> Maybe s -> m (Maybe s)
putValReqState ecm id new_state = do
  enter_ m'maps $
    \(CacheState (retr_state, maps, mapsize, uses, incr)) ->
      return (CacheState (new_state, maps, mapsize, uses, incr), retr_state)
  where
    
    ECM ( m'maps, _, _, _, _, _, _, _, enter_, _ro ) = ecm


clearCache :: (Monad m, Ord k) => ECM m mv s M.Map k v -> m ()
clearCache ecm = do
  enter_ m'maps $
    \(CacheState (retr_state, maps, mapsize, uses, incr)) ->
      return $ CacheState (retr_state, M.empty, 0, ([], 0), 0)
  where
    ECM ( m'maps, _, _, _, _, _, _, enter, enter_, _ ) = ecm

-}


{-
-- This function differs from 'lookupECM' only in the case that the value
-- being requested also causes a new time to have been computed during the 
-- same lookup, and have been found to be out of date. When the condition 
-- happens, this function returns the old cached value without attempting
-- to request a new value, despite being out of date. However, it does
-- clear the key from the key-value store for the next request.
--
lookupECMUse :: (Monad m, Ord k) => ECM m mv s M.Map k v -> k -> m v
lookupECMUse ecm id = do
  enter m'maps $
    \(CacheState (retr_state, maps, mapsize, uses, incr)) ->
      let incr' = incr + 1
       in if incr' < incr
            -- Word incrementor has cycled back to 0,
            -- so may as well clear the cache completely.
            then lookupECM' (retr_state, M.empty, 0, ([], 0), 0) (0+1)
            else lookupECM' (retr_state, maps, mapsize, uses, incr) incr'
  where
    
    ECM ( m'maps, retr, gettime, minimumkeep, timecheckmodulo, removalsize,
          compactlistsize, enter, _ro ) = ecm
  
    mnub = M.toList . M.fromList . reverse
    lookupECM' (retr_state, maps, mapsize, uses, incr) incr' = do
      let uses' = updateUses uses id incr' compactlistsize mnub
      (ret, _) <-
          detECM (M.lookup id maps) retr_state (retr retr_state id)
            ( (\time_r -> M.insert id time_r maps),
              (\time_r keepuses -> M.insert id time_r $! M.intersection maps $ M.fromList keepuses),
              mnub, minimumkeep, removalsize )
            gettime
            M.filter mapsize M.size
            uses' incr' timecheckmodulo maps
      return ret
-}


-- | Used with 'newECMIO' or 'newECMForM' to provide a consistent duration for requested values.
consistentDuration :: (Monad m, Ord k) => TimeUnits -> (Maybe s -> k -> m (Maybe s, v)) -> (Maybe s -> k -> m (TimeUnits, (Maybe s, v)))
consistentDuration duration fun =
  \state id -> do
    ret <- fun state id
    return (duration, ret)