diff --git a/Caching/ExpiringCacheMap/HashECM.hs b/Caching/ExpiringCacheMap/HashECM.hs --- a/Caching/ExpiringCacheMap/HashECM.hs +++ b/Caching/ExpiringCacheMap/HashECM.hs @@ -1,370 +1,375 @@ -{-# LANGUAGE OverloadedStrings #-} --- | --- Module : Caching.ExpiringCacheMap.HashECM --- Copyright: (c) 2014 Edward L. Blake --- License: BSD-style --- Maintainer: Edward L. Blake --- Stability: experimental --- Portability: portable --- --- A cache that holds values for a length of time that uses 'Hashable' keys --- with "Data.HashMap.Strict". --- --- An example of creating a cache for accessing files: --- --- > {-# LANGUAGE OverloadedStrings #-} --- > --- > import Caching.ExpiringCacheMap.HashECM (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.HashECM ( - - -- * Create cache - newECMIO, - newECMForM, - consistentDuration, - - -- * Request value from cache - lookupECM, - - -- * Value request function state - getValReqState, - - -- * Invalidate cache - invalidate, - invalidateCache, - - -- * List keys - keysCached, - keysNotExpired, - - -- * Type - ECM, - CacheSettings(..) -) where - -import qualified Control.Concurrent.MVar as MV -import qualified Data.HashMap.Strict as HM -import qualified Data.List as L -import Data.Hashable (Hashable(..)) - -import Caching.ExpiringCacheMap.Internal.Internal (updateUses, detECM, detNotExpired) -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 :: (Eq k, Hashable k) => (Maybe s -> k -> IO (TimeUnits, (Maybe s, v))) -> (IO TimeUnits) - -> ECMIncr - -> CacheSettings - -> IO (ECM IO MV.MVar s HM.HashMap k v) -newECMIO retr gettime timecheckmodulo cachesettings = do - newECMForM retr gettime timecheckmodulo cachesettings - 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) => (Eq k, Hashable k) => (Maybe s -> k -> m1 (TimeUnits, (Maybe s, v))) -> (m1 TimeUnits) - -> ECMIncr - -> CacheSettings - -> ECMNewState m2 mv s HM.HashMap k v - -> ECMEnterState m1 mv s HM.HashMap k v - -> ECMReadState m1 mv s HM.HashMap k v - -> m2 (ECM m1 mv s HM.HashMap 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, HM.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, the value will be requested through the --- function defined when the 'ECM' value was created, 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, Eq k, Hashable k) => ECM m mv s HM.HashMap 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, HM.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 = HM.toList . HM.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 (HM.lookup id maps) retr_state (retr retr_state id) - ( (\time_r -> HM.insert id time_r maps), - (\time_r keepuses -> HM.insert id time_r $! HM.intersection maps $ HM.fromList keepuses), - mnub, minimumkeep, removalsize ) - gettime - HM.filter - mapsize HM.size - uses' incr' timecheckmodulo maps - - -getValReqState :: (Monad m, Eq k, Hashable k) => ECM m mv s HM.HashMap 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 - - --- | Invalidates a key from the cache and returns its value if any. --- Note this is a sequential composition of a read and modify of the --- mutable cache container (readMVar and modifyMVar with newECMIO). --- -invalidate :: (Monad m, Eq k, Hashable k) => ECM m mv s HM.HashMap k v -> k -> m (Maybe v) -invalidate ecm id = do - CacheState (_, maps0, _, _, _) <- read m'maps - case HM.lookup id maps0 of - Just time_prev0 -> do - prev0' <- enter m'maps $ - \(CacheState (retr_state, maps, mapsize, uses, incr)) -> - let (_, _, prev) = - case HM.lookup id maps of - Just time_prev -> time_prev - Nothing -> time_prev0 - maps' = HM.delete id maps - in return (CacheState (retr_state, maps', mapsize, uses, incr), prev) - return $ Just prev0' - Nothing -> return Nothing - where - ECM ( m'maps, _, _, _, _, _, compactlistsize, enter, read ) = ecm - - --- | Invalidates the entire cache and returns the last key and value if any. --- Note this is a sequential composition of a read and modify of the --- mutable cache container (readMVar and modifyMVar with newECMIO). --- -invalidateCache :: (Monad m, Eq k, Hashable k) => ECM m mv s HM.HashMap k v -> m (Maybe (k, v)) -invalidateCache ecm = do - CacheState (_, maps0, _, (uses0, _), _) <- read m'maps - case (HM.toList $ HM.intersection (HM.fromList uses0) maps0) of - [] -> return Nothing - uses0' -> - let (id, _) = L.maximumBy (\(_,a) (_,b) -> compare a b) uses0' in - case HM.lookup id maps0 of - Just time_prev0 -> do - prev0' <- enter m'maps $ - \(CacheState (retr_state, maps, _mapsize, _uses, _incr)) -> - let (_, _, prev) = - case HM.lookup id maps of - Just time_prev -> time_prev - Nothing -> time_prev0 - in return (CacheState (retr_state, HM.empty, 0, ([], 0), 0), prev) - return $ Just (id, prev0') - where - ECM ( m'maps, _, _, _, _, _, compactlistsize, enter, read ) = ecm - - --- | List of keys in the cache map, which can contain expired values, since --- the list is returned without performing a time check. keys are in an --- unspecified order. --- -keysCached :: (Monad m, Eq k, Hashable k) => ECM m mv s HM.HashMap k v -> m [k] -keysCached ecm = do - CacheState (_, maps0, _, _, _) <- read m'maps - return $ HM.keys maps0 - where - ECM ( m'maps, _, _, _, _, _, _, _, read ) = ecm - - --- | List of keys in the cache map that are not expired values. A time check --- is always performed to compare the elapsed time and the cache state is not --- modified. The time check is not performed from within a modifying state --- context, e.g. not within modifyMVar with a newECMIO instance. Keys are in an --- unspecified order. --- -keysNotExpired :: (Monad m, Eq k, Hashable k) => ECM m mv s HM.HashMap k v -> m [k] -keysNotExpired ecm = do - CacheState (_, maps0, _, _, _) <- read m'maps - current_time <- gettime - return $ detNotExpired current_time $ HM.toList maps0 - where - ECM ( m'maps, _, gettime, _, _, _, _, _, read ) = ecm - - - -{- - -These functions would require inclusion of a enter_ function (like modifyMVar_) - -putValReqState :: (Monad m, Eq k, Hashable k) => ECM m mv s HM.HashMap 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, Eq k, Hashable k) => ECM m mv s HM.HashMap k v -> m () -clearCache ecm = do - enter_ m'maps $ - \(CacheState (retr_state, maps, mapsize, uses, incr)) -> - return $ CacheState (retr_state, HM.empty, 0, ([], 0), 0) - where - ECM ( m'maps, _, _, _, _, _, _, _, 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, Eq k, Hashable k) => ECM m mv s HM.HashMap 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, HM.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 = HM.toList . HM.fromList . reverse - lookupECM' (retr_state, maps, mapsize, uses, incr) incr' = do - let uses' = updateUses uses id incr' compactlistsize mnub - (ret, _) <- - detECM (HM.lookup id maps) retr_state (retr retr_state id) - ( (\time_r -> HM.insert id time_r maps), - (\time_r keepuses -> HM.insert id time_r $! HM.intersection maps $ HM.fromList keepuses), - mnub, minimumkeep, removalsize) - gettime - HM.filter mapsize HM.size - uses' incr' timecheckmodulo maps - return ret --} - - --- | Used with 'newECMIO' or 'newECMForM' to provide a consistent duration for requested values. -consistentDuration :: (Monad m, Eq k, Hashable 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) - +{-# LANGUAGE OverloadedStrings #-} +-- | +-- Module : Caching.ExpiringCacheMap.HashECM +-- Copyright: (c) 2014 Edward L. Blake +-- License: BSD-style +-- Maintainer: Edward L. Blake +-- Stability: experimental +-- Portability: portable +-- +-- A cache that holds values for a length of time that uses 'Hashable' keys +-- with "Data.HashMap.Strict". +-- +-- An example of creating a cache for accessing files: +-- +-- > {-# LANGUAGE OverloadedStrings #-} +-- > +-- > import Caching.ExpiringCacheMap.HashECM (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.HashECM ( + + -- * Create cache + newECMIO, + newECMForM, + consistentDuration, + + -- * Request value from cache + lookupECM, + + -- * Value request function state + getValReqState, + + -- * Invalidate cache + invalidate, + invalidateCache, + + -- * List keys + keysCached, + keysNotExpired, + + -- * Type + ECM, + CacheSettings(..) +) where + +import qualified Control.Concurrent.MVar as MV +import qualified Data.HashMap.Strict as HM +import qualified Data.List as L +import Data.Hashable (Hashable(..)) + +import Caching.ExpiringCacheMap.Internal.Internal (updateUses, detECM, detNotExpired) +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 :: (Eq k, Hashable k) => (Maybe s -> k -> IO (TimeUnits, (Maybe s, v))) -> (IO TimeUnits) + -> ECMIncr + -> CacheSettings + -> IO (ECM IO MV.MVar s HM.HashMap k v) +newECMIO retr gettime timecheckmodulo cachesettings = do + newECMForM retr gettime timecheckmodulo cachesettings + 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) => (Eq k, Hashable k) => (Maybe s -> k -> m1 (TimeUnits, (Maybe s, v))) -> (m1 TimeUnits) + -> ECMIncr + -> CacheSettings + -> ECMNewState m2 mv s HM.HashMap k v + -> ECMEnterState m1 mv s HM.HashMap k v + -> ECMReadState m1 mv s HM.HashMap k v + -> m2 (ECM m1 mv s HM.HashMap 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, HM.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, the value will be requested through the +-- function defined when the 'ECM' value was created, 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, Eq k, Hashable k) => ECM m mv s HM.HashMap 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, HM.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 + + -- Reversing the list first before turning into a map, so the higher value + -- which is at the beginning will be at the end. And fromList retains the + -- last value for a key in the list. + mnub = HM.toList . HM.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 (HM.lookup id maps) retr_state (retr retr_state id) + ( (\time_r -> HM.insert id time_r maps), + (\time_r keepuses -> HM.insert id time_r $! HM.intersection maps $ HM.fromList keepuses), + mnub, minimumkeep, removalsize ) + gettime + HM.filter + mapsize HM.size + uses' incr' timecheckmodulo maps + + +getValReqState :: (Monad m, Eq k, Hashable k) => ECM m mv s HM.HashMap 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 + + +-- | Invalidates a key from the cache and returns its value if any. +-- Note that this is a sequential composition of a read and modify of the +-- mutable cache container (e.g. 'MV.readMVar' followed by 'MV.modifyMVar' +-- with 'newECMIO' instances). +-- +invalidate :: (Monad m, Eq k, Hashable k) => ECM m mv s HM.HashMap k v -> k -> m (Maybe v) +invalidate ecm id = do + CacheState (_, maps0, _, _, _) <- read m'maps + case HM.lookup id maps0 of + Just time_prev0 -> do + prev0' <- enter m'maps $ + \(CacheState (retr_state, maps, mapsize, uses, incr)) -> + let (_, _, prev) = + case HM.lookup id maps of + Just time_prev -> time_prev + Nothing -> time_prev0 + maps' = HM.delete id maps + in return (CacheState (retr_state, maps', mapsize, uses, incr), prev) + return $ Just prev0' + Nothing -> return Nothing + where + ECM ( m'maps, _, _, _, _, _, compactlistsize, enter, read ) = ecm + + +-- | Invalidates the entire cache and returns the last key and value if any. +-- Note that this is a sequential composition of a read and modify of the +-- mutable cache container (e.g. 'MV.readMVar' followed by 'MV.modifyMVar' +-- with 'newECMIO' instances). +-- +invalidateCache :: (Monad m, Eq k, Hashable k) => ECM m mv s HM.HashMap k v -> m (Maybe (k, v)) +invalidateCache ecm = do + CacheState (_, maps0, _, (uses0, _), _) <- read m'maps + case (HM.toList $ HM.intersection (HM.fromList $ reverse uses0) maps0) of + [] -> return Nothing + uses0' -> + let (id, _) = L.maximumBy (\(_,a) (_,b) -> compare a b) uses0' in + case HM.lookup id maps0 of + Just time_prev0 -> do + prev0' <- enter m'maps $ + \(CacheState (retr_state, maps, _mapsize, _uses, _incr)) -> + let (_, _, prev) = + case HM.lookup id maps of + Just time_prev -> time_prev + Nothing -> time_prev0 + in return (CacheState (retr_state, HM.empty, 0, ([], 0), 0), prev) + return $ Just (id, prev0') + where + ECM ( m'maps, _, _, _, _, _, compactlistsize, enter, read ) = ecm + + +-- | List of keys in the cache map without performing a time check, returning +-- both stored keys that are expired and keys that are not expired. keys are +-- in an unspecified order. +-- +keysCached :: (Monad m, Eq k, Hashable k) => ECM m mv s HM.HashMap k v -> m [k] +keysCached ecm = do + CacheState (_, maps0, _, _, _) <- read m'maps + return $ HM.keys maps0 + where + ECM ( m'maps, _, _, _, _, _, _, _, read ) = ecm + + +-- | List of keys in the cache map that are not expired values. A time check +-- is always performed to compare with the elapsed time left with each key. +-- The cache state is not modified and the time check is not performed from +-- within a modifying state context, e.g. not within 'MV.modifyMVar' with a +-- 'newECMIO' instance. Keys are in an unspecified order. +-- +keysNotExpired :: (Monad m, Eq k, Hashable k) => ECM m mv s HM.HashMap k v -> m [k] +keysNotExpired ecm = do + CacheState (_, maps0, _, _, _) <- read m'maps + current_time <- gettime + return $ detNotExpired current_time $ HM.toList maps0 + where + ECM ( m'maps, _, gettime, _, _, _, _, _, read ) = ecm + + + +{- + +These functions would require inclusion of a enter_ function (like modifyMVar_) + +putValReqState :: (Monad m, Eq k, Hashable k) => ECM m mv s HM.HashMap 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, Eq k, Hashable k) => ECM m mv s HM.HashMap k v -> m () +clearCache ecm = do + enter_ m'maps $ + \(CacheState (retr_state, maps, mapsize, uses, incr)) -> + return $ CacheState (retr_state, HM.empty, 0, ([], 0), 0) + where + ECM ( m'maps, _, _, _, _, _, _, _, 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, Eq k, Hashable k) => ECM m mv s HM.HashMap 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, HM.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 = HM.toList . HM.fromList . reverse + lookupECM' (retr_state, maps, mapsize, uses, incr) incr' = do + let uses' = updateUses uses id incr' compactlistsize mnub + (ret, _) <- + detECM (HM.lookup id maps) retr_state (retr retr_state id) + ( (\time_r -> HM.insert id time_r maps), + (\time_r keepuses -> HM.insert id time_r $! HM.intersection maps $ HM.fromList keepuses), + mnub, minimumkeep, removalsize) + gettime + HM.filter mapsize HM.size + uses' incr' timecheckmodulo maps + return ret +-} + + +-- | Used with 'newECMIO' or 'newECMForM' to provide a consistent duration for requested values. +consistentDuration :: (Monad m, Eq k, Hashable 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) + diff --git a/Caching/ExpiringCacheMap/OrdECM.hs b/Caching/ExpiringCacheMap/OrdECM.hs --- a/Caching/ExpiringCacheMap/OrdECM.hs +++ b/Caching/ExpiringCacheMap/OrdECM.hs @@ -1,366 +1,371 @@ -{-# LANGUAGE OverloadedStrings #-} --- | --- Module : Caching.ExpiringCacheMap.OrdECM --- Copyright: (c) 2014 Edward L. Blake --- License: BSD-style --- Maintainer: Edward L. Blake --- 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 - getValReqState, - - -- * Invalidate cache - invalidate, - invalidateCache, - - -- * List keys - keysCached, - keysNotExpired, - - -- * 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, detNotExpired) -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 - - --- | Invalidates a key from the cache and returns its value if any. --- Note this is a sequential composition of a read and modify of the --- mutable cache container (readMVar and modifyMVar with newECMIO). --- -invalidate :: (Monad m, Ord k) => ECM m mv s M.Map k v -> k -> m (Maybe v) -invalidate ecm id = do - CacheState (_, maps0, _, _, _) <- read m'maps - case M.lookup id maps0 of - Just time_prev0 -> do - prev0' <- enter m'maps $ - \(CacheState (retr_state, maps, mapsize, uses, incr)) -> - let (_, _, prev) = - case M.lookup id maps of - Just time_prev -> time_prev - Nothing -> time_prev0 - maps' = M.delete id maps - in return (CacheState (retr_state, maps', mapsize, uses, incr), prev) - return $ Just prev0' - Nothing -> return Nothing - where - ECM ( m'maps, _, _, _, _, _, compactlistsize, enter, read ) = ecm - - --- | Invalidates a key from the cache and returns the last key and value if any. --- Note this is a sequential composition of a read and modify of the --- mutable cache container (readMVar and modifyMVar with newECMIO). --- -invalidateCache :: (Monad m, Ord k) => ECM m mv s M.Map k v -> m (Maybe (k, v)) -invalidateCache ecm = do - CacheState (_, maps0, _, (uses0, _), _) <- read m'maps - case (M.toList $ M.intersection (M.fromList uses0) maps0) of - [] -> return Nothing - uses0' -> - let (id, _) = L.maximumBy (\(_,a) (_,b) -> compare a b) uses0' in - case M.lookup id maps0 of - Just time_prev0 -> do - prev0' <- enter m'maps $ - \(CacheState (retr_state, maps, _mapsize, _uses, _incr)) -> - let (_, _, prev) = - case M.lookup id maps of - Just time_prev -> time_prev - Nothing -> time_prev0 - in return (CacheState (retr_state, M.empty, 0, ([], 0), 0), prev) - return $ Just (id, prev0') - where - ECM ( m'maps, _, _, _, _, _, compactlistsize, enter, read ) = ecm - - --- | List of keys in the cache map, which can contain expired values, since --- the list is returned without performing a time check. keys are in an --- unspecified order. --- -keysCached :: (Monad m, Ord k) => ECM m mv s M.Map k v -> m [k] -keysCached ecm = do - CacheState (_, maps0, _, _, _) <- read m'maps - return $ M.keys maps0 - where - ECM ( m'maps, _, _, _, _, _, _, _, read ) = ecm - - --- | List of keys in the cache map that are not expired values. A time check --- is always performed to compare the elapsed time and the cache state is not --- modified. The time check is not performed from within a modifying state --- context, e.g. not within modifyMVar with a newECMIO instance. Keys are in an --- unspecified order. --- -keysNotExpired :: (Monad m, Ord k) => ECM m mv s M.Map k v -> m [k] -keysNotExpired ecm = do - CacheState (_, maps0, _, _, _) <- read m'maps - current_time <- gettime - return $ detNotExpired current_time $ M.toList maps0 - where - ECM ( m'maps, _, gettime, _, _, _, _, _, 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) - +{-# LANGUAGE OverloadedStrings #-} +-- | +-- Module : Caching.ExpiringCacheMap.OrdECM +-- Copyright: (c) 2014 Edward L. Blake +-- License: BSD-style +-- Maintainer: Edward L. Blake +-- 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 + getValReqState, + + -- * Invalidate cache + invalidate, + invalidateCache, + + -- * List keys + keysCached, + keysNotExpired, + + -- * 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, detNotExpired) +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 + + -- Reversing the list first before turning into a map, so the higher value + -- which is at the beginning will be at the end. And fromList retains the + -- last value for a key in the list. + 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 + + +-- | Invalidates a key from the cache and returns its value if any. +-- Note that this is a sequential composition of a read and modify of the +-- mutable cache container (e.g. 'MV.readMVar' followed by 'MV.modifyMVar' +-- with 'newECMIO' instances). +-- +invalidate :: (Monad m, Ord k) => ECM m mv s M.Map k v -> k -> m (Maybe v) +invalidate ecm id = do + CacheState (_, maps0, _, _, _) <- read m'maps + case M.lookup id maps0 of + Just time_prev0 -> do + prev0' <- enter m'maps $ + \(CacheState (retr_state, maps, mapsize, uses, incr)) -> + let (_, _, prev) = + case M.lookup id maps of + Just time_prev -> time_prev + Nothing -> time_prev0 + maps' = M.delete id maps + in return (CacheState (retr_state, maps', mapsize, uses, incr), prev) + return $ Just prev0' + Nothing -> return Nothing + where + ECM ( m'maps, _, _, _, _, _, compactlistsize, enter, read ) = ecm + + +-- | Invalidates the entire cache and returns the last key and value if any. +-- Note that this is a sequential composition of a read and modify of the +-- mutable cache container (e.g. 'MV.readMVar' followed by 'MV.modifyMVar' +-- with 'newECMIO' instances). +-- +invalidateCache :: (Monad m, Ord k) => ECM m mv s M.Map k v -> m (Maybe (k, v)) +invalidateCache ecm = do + CacheState (_, maps0, _, (uses0, _), _) <- read m'maps + case (M.toList $ M.intersection (M.fromList $ reverse uses0) maps0) of + [] -> return Nothing + uses0' -> + let (id, _) = L.maximumBy (\(_,a) (_,b) -> compare a b) uses0' in + case M.lookup id maps0 of + Just time_prev0 -> do + prev0' <- enter m'maps $ + \(CacheState (retr_state, maps, _mapsize, _uses, _incr)) -> + let (_, _, prev) = + case M.lookup id maps of + Just time_prev -> time_prev + Nothing -> time_prev0 + in return (CacheState (retr_state, M.empty, 0, ([], 0), 0), prev) + return $ Just (id, prev0') + where + ECM ( m'maps, _, _, _, _, _, compactlistsize, enter, read ) = ecm + + +-- | List of keys in the cache map without performing a time check, returning +-- both stored keys that are expired and keys that are not expired. keys are +-- in an unspecified order. +-- +keysCached :: (Monad m, Ord k) => ECM m mv s M.Map k v -> m [k] +keysCached ecm = do + CacheState (_, maps0, _, _, _) <- read m'maps + return $ M.keys maps0 + where + ECM ( m'maps, _, _, _, _, _, _, _, read ) = ecm + + +-- | List of keys in the cache map that are not expired values. A time check +-- is always performed to compare with the elapsed time left with each key. +-- The cache state is not modified and the time check is not performed from +-- within a modifying state context, e.g. not within 'MV.modifyMVar' with a +-- 'newECMIO' instance. Keys are in an unspecified order. +-- +keysNotExpired :: (Monad m, Ord k) => ECM m mv s M.Map k v -> m [k] +keysNotExpired ecm = do + CacheState (_, maps0, _, _, _) <- read m'maps + current_time <- gettime + return $ detNotExpired current_time $ M.toList maps0 + where + ECM ( m'maps, _, gettime, _, _, _, _, _, 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) + diff --git a/expiring-cache-map.cabal b/expiring-cache-map.cabal --- a/expiring-cache-map.cabal +++ b/expiring-cache-map.cabal @@ -1,74 +1,108 @@ -name: expiring-cache-map -version: 0.0.6.0 -synopsis: General purpose simple caching. -description: - A simple general purpose shared state cache map with automatic expiration - of values, for caching the results of accessing a resource such as reading - a file. With variations for Ord and Hashable keys using "Data.Map.Strict" - and "Data.HashMap.Strict", respectively. - -homepage: https://github.com/elblake/expiring-cache-map -bug-reports: https://github.com/elblake/expiring-cache-map/issues -license: BSD3 -license-file: LICENSE -author: Edward L. Blake -maintainer: edwardlblake@gmail.com -copyright: (c) 2014 Edward L. Blake -category: Caching -build-type: Simple -cabal-version: >=1.8 - -extra-source-files: - README.md - -library - exposed-modules: - Caching.ExpiringCacheMap.OrdECM - Caching.ExpiringCacheMap.HashECM - Caching.ExpiringCacheMap.Internal.Internal - Caching.ExpiringCacheMap.Internal.Types - Caching.ExpiringCacheMap.Types - Caching.ExpiringCacheMap.Utils.TestSequence - Caching.ExpiringCacheMap.Utils.Types - -- other-modules: - build-depends: - base == 4.*, - containers >= 0.5.0.0, - hashable >= 1.0.1.1, - unordered-containers >= 0.2.0.0 - -test-suite test-threads - type: exitcode-stdio-1.0 - hs-source-dirs: . tests - main-is: TestWithThreads.hs - build-depends: - base, - bytestring >= 0.10.0.0, - time >= 1.0, - containers >= 0.5.0.0, - hashable >= 1.0.1.1, - unordered-containers >= 0.2.0.0 - other-modules: - TestHashECMWithThreads - TestHashECMWithThreadsInvalidating - TestOrdECMWithThreads - TestOrdECMWithThreadsInvalidating - Caching.ExpiringCacheMap.Internal.Internal - -test-suite test-sequence - type: exitcode-stdio-1.0 - hs-source-dirs: . tests - main-is: TestWithTestSequence.hs - build-depends: - base, - bytestring >= 0.10.0.0, - containers >= 0.5.0.0, - hashable >= 1.0.1.1, - unordered-containers >= 0.2.0.0 - other-modules: - TestECMWithTestSequenceCommon - TestECMWithTestSequenceCommonInvalidating - TestHashECMWithTestSequence - TestHashECMWithTestSequenceInvalidating - TestOrdECMWithTestSequence - TestOrdECMWithTestSequenceInvalidating +name: expiring-cache-map +version: 0.0.6.1 +synopsis: General purpose simple caching. +description: + A simple general purpose shared state cache map with automatic expiration + of values, for caching the results of accessing a resource such as reading + a file. With variations for Ord and Hashable keys using "Data.Map.Strict" + and "Data.HashMap.Strict", respectively. + +homepage: https://github.com/elblake/expiring-cache-map +bug-reports: https://github.com/elblake/expiring-cache-map/issues +license: BSD3 +license-file: LICENSE +author: Edward L. Blake +maintainer: edwardlblake@gmail.com +copyright: (c) 2014 Edward L. Blake +category: Caching +build-type: Simple +cabal-version: >=1.8 + +extra-source-files: + README.md + +library + exposed-modules: + Caching.ExpiringCacheMap.OrdECM + Caching.ExpiringCacheMap.HashECM + Caching.ExpiringCacheMap.Internal.Internal + Caching.ExpiringCacheMap.Internal.Types + Caching.ExpiringCacheMap.Types + Caching.ExpiringCacheMap.Utils.TestSequence + Caching.ExpiringCacheMap.Utils.Types + -- other-modules: + build-depends: + base == 4.*, + containers >= 0.5.0.0, + hashable >= 1.0.1.1, + unordered-containers >= 0.2.0.0 + +test-suite test-threads + type: exitcode-stdio-1.0 + hs-source-dirs: . tests + main-is: TestWithThreads.hs + build-depends: + base, + bytestring >= 0.10.0.0, + time >= 1.0, + containers >= 0.5.0.0, + hashable >= 1.0.1.1, + unordered-containers >= 0.2.0.0 + other-modules: + TestHashECMWithThreads + TestHashECMWithThreadsInvalidating + TestOrdECMWithThreads + TestOrdECMWithThreadsInvalidating + Caching.ExpiringCacheMap.Internal.Internal + +test-suite test-sequence + type: exitcode-stdio-1.0 + hs-source-dirs: . tests + main-is: TestWithTestSequence.hs + build-depends: + base, + bytestring >= 0.10.0.0, + containers >= 0.5.0.0, + hashable >= 1.0.1.1, + unordered-containers >= 0.2.0.0 + other-modules: + TestECMWithTestSequenceCommon + TestECMWithTestSequenceCommonInvalidating + TestHashECMWithTestSequence + TestHashECMWithTestSequenceInvalidating + TestOrdECMWithTestSequence + TestOrdECMWithTestSequenceInvalidating + +test-suite invalidate-test + type: exitcode-stdio-1.0 + hs-source-dirs: . tests + main-is: InvalidateTest.hs + build-depends: + base, + bytestring >= 0.10.0.0, + time >= 1.0, + containers >= 0.5.0.0, + hashable >= 1.0.1.1, + unordered-containers >= 0.2.0.0 + other-modules: + InvalidateTestCommon + InvalidateTestHashECM + InvalidateTestOrdECM + Caching.ExpiringCacheMap.Internal.Internal + +test-suite invalidate-cache-test + type: exitcode-stdio-1.0 + hs-source-dirs: . tests + main-is: InvalidateCacheTest.hs + build-depends: + base, + bytestring >= 0.10.0.0, + time >= 1.0, + containers >= 0.5.0.0, + hashable >= 1.0.1.1, + unordered-containers >= 0.2.0.0 + other-modules: + InvalidateCacheTestCommon + InvalidateCacheTestHashECM + InvalidateCacheTestOrdECM + Caching.ExpiringCacheMap.Internal.Internal diff --git a/tests/InvalidateCacheTest.hs b/tests/InvalidateCacheTest.hs new file mode 100644 --- /dev/null +++ b/tests/InvalidateCacheTest.hs @@ -0,0 +1,11 @@ + + +import qualified InvalidateCacheTestHashECM as TestHashECM (tests) +import qualified InvalidateCacheTestOrdECM as TestOrdECM (tests) + +invalidateCacheTests = do + TestHashECM.tests + TestOrdECM.tests + return () + +main = invalidateCacheTests diff --git a/tests/InvalidateCacheTestCommon.hs b/tests/InvalidateCacheTestCommon.hs new file mode 100644 --- /dev/null +++ b/tests/InvalidateCacheTestCommon.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE OverloadedStrings #-} + +module InvalidateCacheTestCommon (test1Common) where + +import qualified Data.ByteString.Char8 as BS + +test1Common lookup3 keysCached3 invalidateCache3 = do + + b <- lookup3 ("file1" :: BS.ByteString) + b <- lookup3 "file2" + b <- lookup3 "file3" + b <- lookup3 "file2" + b <- lookup3 "file3" + shouldBe 3 "file3" + + b <- lookup3 "file1" + b <- lookup3 "file2" + b <- lookup3 "file3" + b <- lookup3 "file1" + shouldBe 3 "file1" + + b <- lookup3 "file1" + b <- lookup3 "file2" + b <- lookup3 "file3" + b <- lookup3 "file4" + b <- lookup3 "file5" + b <- lookup3 "file2" + shouldBe 5 "file2" + + b <- lookup3 "file1" + b <- lookup3 "file2" + b <- lookup3 "file3" + b <- lookup3 "file4" + b <- lookup3 "file5" + b <- lookup3 "file6" + b <- lookup3 "file7" + b <- lookup3 "file8" + b <- lookup3 "file9" + b <- lookup3 "file3" + shouldBe 9 "file3" + + return () + + where + + shouldBe count lastkey = do + l <- keysCached3 + putStrLn $ show l + if count == (length l) + then do + kv <- invalidateCache3 + putStrLn $ show kv + case kv of + Just (k, v) | k == lastkey -> do + l2 <- keysCached3 + if 0 == (length l2) + then return () + else error "Did not fully invalidate" + else error "Wrong length" diff --git a/tests/InvalidateCacheTestHashECM.hs b/tests/InvalidateCacheTestHashECM.hs new file mode 100644 --- /dev/null +++ b/tests/InvalidateCacheTestHashECM.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE OverloadedStrings #-} + +module InvalidateCacheTestHashECM ( + tests +) where + +import Caching.ExpiringCacheMap.HashECM (newECMIO, lookupECM, CacheSettings(..), consistentDuration) +import qualified Caching.ExpiringCacheMap.HashECM as ECM (invalidateCache, keysCached, keysNotExpired) +import qualified Data.ByteString.Char8 as BS + +import InvalidateCacheTestCommon (test1Common) + +tests = test1 + +test1 = do + filecache3 <- newECMIO + (consistentDuration 100 + (\state id -> do BS.putStrLn "Reading a file again..." + return (state, ("file contents" :: BS.ByteString) ))) + (return 1) + 12000 -- Value to modulo with cache state accumulator to determine time check frequency. + (CacheWithLRUList + 100 -- Expected size of key-value map when removing elements. + 100 -- Size at when to remove items from key-value map. + 200 ) + test1Common (lookupECM filecache3) (ECM.keysCached filecache3) (ECM.invalidateCache filecache3) + return () diff --git a/tests/InvalidateCacheTestOrdECM.hs b/tests/InvalidateCacheTestOrdECM.hs new file mode 100644 --- /dev/null +++ b/tests/InvalidateCacheTestOrdECM.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE OverloadedStrings #-} + +module InvalidateCacheTestOrdECM ( + tests +) where + +import Caching.ExpiringCacheMap.HashECM (newECMIO, lookupECM, CacheSettings(..), consistentDuration) +import qualified Caching.ExpiringCacheMap.HashECM as ECM (invalidateCache, keysCached, keysNotExpired) +import qualified Data.ByteString.Char8 as BS + +import InvalidateCacheTestCommon (test1Common) + +tests = test1 + +test1 = do + filecache3 <- newECMIO + (consistentDuration 100 + (\state id -> do BS.putStrLn "Reading a file again..." + return (state, ("file contents" :: BS.ByteString) ))) + (return 1) + 12000 -- Value to modulo with cache state accumulator to determine time check frequency. + (CacheWithLRUList + 100 -- Expected size of key-value map when removing elements. + 100 -- Size at when to remove items from key-value map. + 200 ) + test1Common (lookupECM filecache3) (ECM.keysCached filecache3) (ECM.invalidateCache filecache3) + return () diff --git a/tests/InvalidateTest.hs b/tests/InvalidateTest.hs new file mode 100644 --- /dev/null +++ b/tests/InvalidateTest.hs @@ -0,0 +1,11 @@ + + +import qualified InvalidateTestHashECM as TestHashECM (tests) +import qualified InvalidateTestOrdECM as TestOrdECM (tests) + +invalidateTest = do + TestHashECM.tests + TestOrdECM.tests + return () + +main = invalidateTest diff --git a/tests/InvalidateTestCommon.hs b/tests/InvalidateTestCommon.hs new file mode 100644 --- /dev/null +++ b/tests/InvalidateTestCommon.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE OverloadedStrings #-} + +module InvalidateTestCommon (test1Common, test2Common) where + +import qualified Data.ByteString.Char8 as BS +import Control.Concurrent (threadDelay) + + + +test1Common lookup1 invalidate1 keysCached1 invalidateCache1 = do + + b <- lookup1 ("file1" :: BS.ByteString) + b <- lookup1 "file2" + b <- lookup1 "file3" + listShouldBe 3 + + -- Repeat + b <- lookup1 "file2" + b <- lookup1 "file3" + + listShouldBe 3 + + v <- invalidate1 "file2" + putStrLn $ show v + listShouldBe 2 + + b <- lookup1 "file2" + b <- lookup1 "file3" + listShouldBe 3 + + kv <- invalidateCache1 + putStrLn $ show kv + listShouldBe 0 + return () + + where + listShouldBe count = do + l <- keysCached1 + if (length l) == count + then putStrLn $ show l + else error "Lists not the same length" + + +test2Common lookup2 keysCached2 keysNotExpired2 = do + + b <- lookup2 ("file1" :: BS.ByteString) + b <- lookup2 "file2" + b <- lookup2 "file3" + l <- keysCached2 + listCount 3 l + threadDelay 2 + l <- keysNotExpired2 + listCount 0 l + return () + + where + listCount count l = do + if (length l) == count + then putStrLn $ show l + else error "Not the same length" diff --git a/tests/InvalidateTestHashECM.hs b/tests/InvalidateTestHashECM.hs new file mode 100644 --- /dev/null +++ b/tests/InvalidateTestHashECM.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE OverloadedStrings #-} + +module InvalidateTestHashECM ( + tests +) where + +import Caching.ExpiringCacheMap.HashECM (newECMIO, lookupECM, CacheSettings(..), consistentDuration) +import qualified Caching.ExpiringCacheMap.HashECM as ECM (invalidate, invalidateCache, keysCached, keysNotExpired) + +import InvalidateTestCommon (test1Common, test2Common) + +import qualified Data.Time.Clock.POSIX as POSIX (POSIXTime, getPOSIXTime) +import qualified Data.ByteString.Char8 as BS +import Data.Time.Clock +import Control.Concurrent (threadDelay) + + +tests = do + test1 + test2 + return () + +test1 = do + filecache1 <- newECMIO + (consistentDuration 100 + (\state id -> do BS.putStrLn "Reading a file again..." + return (state, ("file contents" :: BS.ByteString) ))) + (return 1) + 12000 -- Value to modulo with cache state accumulator to determine time check frequency. + (CacheWithLRUList + 100 -- Expected size of key-value map when removing elements. + 100 -- Size at when to remove items from key-value map. + 200 ) + test1Common (lookupECM filecache1) (ECM.invalidate filecache1) (ECM.keysCached filecache1) (ECM.invalidateCache filecache1) + return () + +test2 = do + filecache2 <- newECMIO + (consistentDuration 0 + (\state id -> do BS.putStrLn "Reading a file again..." + return (state, ("file contents" :: BS.ByteString) ))) + (do time <- POSIX.getPOSIXTime + return (round (time * 100))) + 1 -- Value to modulo with cache state accumulator to determine time check frequency. + (CacheWithLRUList + 6 -- Expected size of key-value map when removing elements. + 6 -- Size at when to remove items from key-value map. + 12 ) + test2Common (lookupECM filecache2) (ECM.keysCached filecache2) (ECM.keysNotExpired filecache2) + return () diff --git a/tests/InvalidateTestOrdECM.hs b/tests/InvalidateTestOrdECM.hs new file mode 100644 --- /dev/null +++ b/tests/InvalidateTestOrdECM.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE OverloadedStrings #-} + +module InvalidateTestOrdECM ( + tests +) where + +import Caching.ExpiringCacheMap.OrdECM (newECMIO, lookupECM, CacheSettings(..), consistentDuration) +import qualified Caching.ExpiringCacheMap.OrdECM as ECM (invalidate, invalidateCache, keysCached, keysNotExpired) + +import InvalidateTestCommon (test1Common, test2Common) + +import qualified Data.Time.Clock.POSIX as POSIX (POSIXTime, getPOSIXTime) +import qualified Data.ByteString.Char8 as BS +import Data.Time.Clock +import Control.Concurrent (threadDelay) + + +tests = do + test1 + test2 + return () + +test1 = do + filecache1 <- newECMIO + (consistentDuration 100 + (\state id -> do BS.putStrLn "Reading a file again..." + return (state, ("file contents" :: BS.ByteString) ))) + (return 1) + 12000 -- Value to modulo with cache state accumulator to determine time check frequency. + (CacheWithLRUList + 100 -- Expected size of key-value map when removing elements. + 100 -- Size at when to remove items from key-value map. + 200 ) + test1Common (lookupECM filecache1) (ECM.invalidate filecache1) (ECM.keysCached filecache1) (ECM.invalidateCache filecache1) + return () + +test2 = do + filecache2 <- newECMIO + (consistentDuration 0 + (\state id -> do BS.putStrLn "Reading a file again..." + return (state, ("file contents" :: BS.ByteString) ))) + (do time <- POSIX.getPOSIXTime + return (round (time * 100))) + 1 -- Value to modulo with cache state accumulator to determine time check frequency. + (CacheWithLRUList + 6 -- Expected size of key-value map when removing elements. + 6 -- Size at when to remove items from key-value map. + 12 ) + test2Common (lookupECM filecache2) (ECM.keysCached filecache2) (ECM.keysNotExpired filecache2) + return () diff --git a/tests/TestECMWithTestSequenceCommonInvalidating.hs b/tests/TestECMWithTestSequenceCommonInvalidating.hs --- a/tests/TestECMWithTestSequenceCommonInvalidating.hs +++ b/tests/TestECMWithTestSequenceCommonInvalidating.hs @@ -1,683 +1,683 @@ -{-# LANGUAGE OverloadedStrings #-} - -module TestECMWithTestSequenceCommonInvalidating ( - someEventsOnlyI, - numberEventsOnlyI, - pattern'I, - pattern''I, - pattern'''I, - pattern''''I, - pattern'''''I, - pattern''''''I, - testLookupsI, - printOutEventsI, - printOutFailedPatternI -) where - -import qualified Caching.ExpiringCacheMap.Utils.TestSequence as TestSeq - -import qualified Data.ByteString.Char8 as BS - -printOutFailedPatternI from_where filt_events' filt_events'' filt_events''' filt_events'''' filt_events''''' filt_events'''''' = do - putStrLn $ "Failed sequence test in " ++ from_where ++ ":" - if not (pattern'I (filt_events')) - then putStrLn $ "Failed: pattern 1: " ++ (show filt_events') - else return () - if not (pattern''I (filt_events'')) - then putStrLn $ "Failed: pattern 2: " ++ (show filt_events'') - else return () - if not (pattern'''I (filt_events''')) - then putStrLn $ "Failed: pattern 3: " ++ (show filt_events''') - else return () - if not (pattern''''I (filt_events'''')) - then putStrLn $ "Failed: pattern 4: " ++ (show filt_events'''') - else return () - if not (pattern'''''I (filt_events''''')) - then putStrLn $ "Failed: pattern 5: " ++ (show filt_events''''') - else return () - if not (pattern''''''I (filt_events'''''')) - then putStrLn $ "Failed: pattern 6: " ++ (show filt_events'''''') - else return () - return () - - -printOutEventsI events' events'' events''' events'''' events''''' events'''''' = do - (putStrLn . show . filter someEventsOnlyI . reverse) events' - (putStrLn . show . filter someEventsOnlyI . reverse) events'' - (putStrLn . show . filter someEventsOnlyI . reverse) events''' - (putStrLn . show . filter someEventsOnlyI . reverse) events'''' - (putStrLn . show . filter someEventsOnlyI . reverse) events''''' - (putStrLn . show . filter someEventsOnlyI . reverse) events'''''' - return () - -someEventsOnlyI a = - case a of - TestSeq.GetTime _ -> True - TestSeq.ReadNumber _ -> True - TestSeq.HaveNumber _ -> True - _ -> False - -numberEventsOnlyI a = - case a of - TestSeq.ReadNumber _ -> True - TestSeq.HaveNumber _ -> True - _ -> False - -pattern'I c = - case c of -- - [ TestSeq.ReadNumber numr_4, -- ReadNumber 4,GetTime 7,HaveNumber 4,HaveNumber 4 - TestSeq.GetTime _, - TestSeq.HaveNumber numh_4, - TestSeq.HaveNumber numh_4', - TestSeq.ReadNumber numr_21, -- ReadNumber 21,GetTime 24,HaveNumber 21, - TestSeq.GetTime _, - TestSeq.HaveNumber numh_21, - TestSeq.ReadNumber numr_32, -- ReadNumber 32,GetTime 35,HaveNumber 32, - TestSeq.GetTime _, - TestSeq.HaveNumber numh_32, - TestSeq.HaveNumber numh_21', -- HaveNumber 21, - TestSeq.ReadNumber numr_50, -- ReadNumber 50,GetTime 53,HaveNumber 50,HaveNumber 50, - TestSeq.GetTime _, - TestSeq.HaveNumber numh_50, - TestSeq.HaveNumber numh_50', - - TestSeq.HaveNumber 2, - TestSeq.GetTime _, - TestSeq.HaveNumber 2, - - TestSeq.ReadNumber numr_76, -- ReadNumber 76,GetTime 79,HaveNumber 76,HaveNumber 76, - TestSeq.GetTime _, - TestSeq.HaveNumber numh_76, - TestSeq.HaveNumber numh_76', - - TestSeq.HaveNumber numh_4'', - - TestSeq.HaveNumber numh_76'', -- HaveNumber 76,HaveNumber 32,HaveNumber 32, - TestSeq.HaveNumber numh_32'', - TestSeq.HaveNumber numh_32''', - - TestSeq.HaveNumber 0, - TestSeq.GetTime _, - TestSeq.HaveNumber 0, - - TestSeq.ReadNumber numr_126, -- ReadNumber 126,GetTime 129,HaveNumber 126, - TestSeq.GetTime _, - TestSeq.HaveNumber numh_126, - TestSeq.ReadNumber numr_137, -- ReadNumber 137,GetTime 140,HaveNumber 137, - TestSeq.GetTime _, - TestSeq.HaveNumber numh_137, - TestSeq.ReadNumber numr_148, -- ReadNumber 148,GetTime 151,HaveNumber 148, - TestSeq.GetTime _, - TestSeq.HaveNumber numh_148, - - TestSeq.HaveNumber numh_126', -- HaveNumber 126,HaveNumber 137,HaveNumber 148, - TestSeq.HaveNumber numh_137', - TestSeq.HaveNumber numh_148', - - TestSeq.HaveNumber 3, - TestSeq.GetTime _, - TestSeq.HaveNumber 3] - | numr_4 == numh_4 && - numh_4 == numh_4' && - numh_4 == numh_4'' && - numr_21 == numh_21 && - numh_21 == numh_21' && - numr_32 == numh_32 && - numh_32 == numh_32'' && - numh_32 == numh_32''' && - numr_50 == numh_50 && - numh_50 == numh_50' && - numr_76 == numh_76 && - numh_76 == numh_76' && - numh_76 == numh_76'' && - numr_126 == numh_126 && - numh_126 == numh_126' && - numr_137 == numh_137 && - numh_137 == numh_137' && - numr_148 == numh_148 && - numh_148 == numh_148' && - numh_4 < numh_21 && - numh_21 < numh_32 && - numh_32 < numh_50 && - numh_50 < numh_76 && - numh_76 < numh_126 && - numh_126 < numh_137 && - numh_137 < numh_148 - -> True - _ -> False - -pattern''I c = - case c of -- - [ TestSeq.ReadNumber numr_4, -- ReadNumber 4,GetTime 7,HaveNumber 4,GetTime 15,GetTime 18,HaveNumber 4, - TestSeq.GetTime _, - TestSeq.HaveNumber numh_4, - TestSeq.GetTime _, - TestSeq.GetTime _, - TestSeq.HaveNumber numh_4', - TestSeq.ReadNumber numr_26, -- ReadNumber 26,GetTime 29,HaveNumber 26, - TestSeq.GetTime _, - TestSeq.HaveNumber numh_26, - TestSeq.ReadNumber numr_37, -- ReadNumber 37,GetTime 40,HaveNumber 37, - TestSeq.GetTime _, - TestSeq.HaveNumber numh_37, - TestSeq.HaveNumber numh_26', -- HaveNumber 26, - TestSeq.ReadNumber numr_55, -- ReadNumber 55,GetTime 58,HaveNumber 55,HaveNumber 55, - TestSeq.GetTime _, - TestSeq.HaveNumber numh_55, - TestSeq.HaveNumber numh_55', - - TestSeq.HaveNumber 2, - TestSeq.GetTime _, - TestSeq.HaveNumber 2, - - TestSeq.ReadNumber numr_81, -- ReadNumber 81,GetTime 84,HaveNumber 81,GetTime 92,GetTime 95,HaveNumber 81 - TestSeq.GetTime _, - TestSeq.HaveNumber numh_81, - TestSeq.GetTime _, - TestSeq.GetTime _, - TestSeq.HaveNumber numh_81', - - TestSeq.GetTime _, -- GetTime 103,GetTime 106, - TestSeq.GetTime _, - TestSeq.HaveNumber numh_4'', - - TestSeq.GetTime _, -- GetTime 114,GetTime 117,HaveNumber 81, - TestSeq.GetTime _, - TestSeq.HaveNumber numh_81'', - TestSeq.GetTime _, -- GetTime 125,GetTime 128,HaveNumber 37,HaveNumber 37, - TestSeq.GetTime _, - TestSeq.HaveNumber numh_37', - TestSeq.HaveNumber numh_37'', - - TestSeq.HaveNumber 0, - TestSeq.GetTime _, - TestSeq.HaveNumber 0, - - TestSeq.ReadNumber numr_151, -- ReadNumber 151,GetTime 154,HaveNumber 151, - TestSeq.GetTime _, - TestSeq.HaveNumber numh_151, - TestSeq.ReadNumber numr_162, -- ReadNumber 162,GetTime 165,HaveNumber 162, - TestSeq.GetTime _, - TestSeq.HaveNumber numh_162, - TestSeq.ReadNumber numr_173, -- ReadNumber 173,GetTime 176,HaveNumber 173, - TestSeq.GetTime _, - TestSeq.HaveNumber numh_173, - - TestSeq.GetTime _, -- GetTime 184,GetTime 187,HaveNumber 151, - TestSeq.GetTime _, - TestSeq.HaveNumber numh_151', - TestSeq.GetTime _, -- GetTime 195,GetTime 198,HaveNumber 162, - TestSeq.GetTime _, - TestSeq.HaveNumber numh_162', - TestSeq.GetTime _, -- GetTime 206,GetTime 209,HaveNumber 173, - TestSeq.GetTime _, - TestSeq.HaveNumber numh_173', - - TestSeq.HaveNumber 3, - TestSeq.GetTime _, - TestSeq.HaveNumber 3] - | numr_4 == numh_4 && - numh_4 == numh_4' && - numh_4 == numh_4'' && - numr_26 == numh_26 && - numh_26 == numh_26' && - numr_37 == numh_37 && - numh_37 == numh_37' && - numh_37 == numh_37'' && - numr_55 == numh_55 && - numh_55 == numh_55' && - numr_81 == numh_81 && - numh_81 == numh_81' && - numh_81 == numh_81'' && - numr_151 == numh_151 && - numh_151 == numh_151' && - numr_162 == numh_162 && - numh_162 == numh_162' && - numr_173 == numh_173 && - numh_173 == numh_173' && - numh_4 < numh_26 && - numh_26 < numh_37 && - numh_37 < numh_55 && - numh_55 < numh_81 && - numh_81 < numh_151 && - numh_151 < numh_162 && - numh_162 < numh_173 - -> True - _ -> False - -pattern'''I c = - case c of -- - [ TestSeq.ReadNumber numr_4, -- ReadNumber 4,GetTime 7,HaveNumber 4,HaveNumber 4, - TestSeq.GetTime _, - TestSeq.HaveNumber numh_4, - TestSeq.HaveNumber numh_4', - TestSeq.ReadNumber numr_21, -- ReadNumber 21,GetTime 24,HaveNumber 21, - TestSeq.GetTime _, - TestSeq.HaveNumber numh_21, - TestSeq.ReadNumber numr_32, -- ReadNumber 32,GetTime 35,HaveNumber 32, - TestSeq.GetTime _, - TestSeq.HaveNumber numh_32, - TestSeq.HaveNumber numh_21', -- HaveNumber 21, - TestSeq.ReadNumber numr_50, -- ReadNumber 50,GetTime 53,HaveNumber 50,HaveNumber 50, - TestSeq.GetTime _, - TestSeq.HaveNumber numh_50, - TestSeq.HaveNumber numh_50', - - TestSeq.HaveNumber 2, - TestSeq.GetTime _, - TestSeq.HaveNumber 0, - - TestSeq.ReadNumber numr_76, -- ReadNumber 76,GetTime 79,HaveNumber 76,HaveNumber 76, - TestSeq.GetTime _, - TestSeq.HaveNumber numh_76, - TestSeq.HaveNumber numh_76', - - TestSeq.HaveNumber numh_4'', - - TestSeq.HaveNumber numh_76'', -- HaveNumber 76,HaveNumber 32,HaveNumber 32, - TestSeq.HaveNumber numh_32'', - TestSeq.HaveNumber numh_32''', - - TestSeq.HaveNumber 0, - TestSeq.GetTime _, - TestSeq.HaveNumber 0, - - TestSeq.ReadNumber numr_126, -- ReadNumber 126,GetTime 129,HaveNumber 126, - TestSeq.GetTime _, - TestSeq.HaveNumber numh_126, - TestSeq.ReadNumber numr_137, -- ReadNumber 137,GetTime 140,HaveNumber 137, - TestSeq.GetTime _, - TestSeq.HaveNumber numh_137, - TestSeq.ReadNumber numr_148, -- ReadNumber 148,GetTime 151,HaveNumber 148, - TestSeq.GetTime _, - TestSeq.HaveNumber numh_148, - - TestSeq.HaveNumber numh_126', -- HaveNumber 126,HaveNumber 137,HaveNumber 148, - TestSeq.HaveNumber numh_137', - TestSeq.HaveNumber numh_148', - - TestSeq.HaveNumber 3, - TestSeq.GetTime _, - TestSeq.HaveNumber 0 ] - | numr_4 == numh_4 && - numh_4 == numh_4' && - numh_4 == numh_4'' && - numr_21 == numh_21 && - numh_21 == numh_21' && - numr_32 == numh_32 && - numh_32 == numh_32'' && - numh_32 == numh_32''' && - numr_50 == numh_50 && - numh_50 == numh_50' && - numr_76 == numh_76 && - numh_76' == numh_76'' && - numr_126 == numh_126 && - numh_126 == numh_126' && - numr_137 == numh_137 && - numh_137 == numh_137' && - numr_148 == numh_148 && - numh_148 == numh_148' && - numh_4 < numh_21 && - numh_21 < numh_32 && - numh_32 < numh_50 && - numh_50 < numh_76 && - numh_76 < numh_126 && - numh_126 < numh_137 && - numh_137 < numh_148 - -> True - _ -> False - -pattern''''I c = - case c of -- - [ TestSeq.ReadNumber numr_4, -- ReadNumber 4,GetTime 7,HaveNumber 4,GetTime 15, - TestSeq.GetTime _, - TestSeq.HaveNumber numh_4, - TestSeq.GetTime _, - TestSeq.ReadNumber numr_18, -- ReadNumber 18,GetTime 21,HaveNumber 18, - TestSeq.GetTime _, - TestSeq.HaveNumber numh_18, - TestSeq.ReadNumber numr_29, -- ReadNumber 29,GetTime 32,HaveNumber 29, - TestSeq.GetTime _, - TestSeq.HaveNumber numh_29, - TestSeq.ReadNumber numr_40, -- ReadNumber 40,GetTime 43,HaveNumber 40,HaveNumber 29, - TestSeq.GetTime _, - TestSeq.HaveNumber numh_40, - TestSeq.HaveNumber numh_29', - - TestSeq.ReadNumber numr_58, -- ReadNumber 58,GetTime 61,HaveNumber 58,HaveNumber 58, - TestSeq.GetTime _, - TestSeq.HaveNumber numh_58, - TestSeq.HaveNumber numh_58', - - TestSeq.HaveNumber 2, - TestSeq.GetTime _, - TestSeq.HaveNumber 0, - - TestSeq.ReadNumber numr_84, -- ReadNumber 84,GetTime 87,HaveNumber 84,GetTime 95, - TestSeq.GetTime _, - TestSeq.HaveNumber numh_84, - TestSeq.GetTime _, - TestSeq.ReadNumber numr_98, -- ReadNumber 98,GetTime 101,HaveNumber 98, - TestSeq.GetTime _, - TestSeq.HaveNumber numh_98, - TestSeq.ReadNumber numr_109, -- ReadNumber 109,GetTime 112,HaveNumber 109,GetTime 120, - TestSeq.GetTime _, - TestSeq.HaveNumber numh_109, - TestSeq.GetTime _, - TestSeq.ReadNumber numr_123, -- ReadNumber 123,GetTime 126,HaveNumber 123, - TestSeq.GetTime _, - TestSeq.HaveNumber numh_123, - TestSeq.ReadNumber numr_134, -- ReadNumber 134,GetTime 137,HaveNumber 134,HaveNumber 134, - TestSeq.GetTime _, - TestSeq.HaveNumber numh_134, - TestSeq.HaveNumber numh_134', - - TestSeq.HaveNumber 0, - TestSeq.GetTime _, - TestSeq.HaveNumber 0, - - TestSeq.ReadNumber numr_160, -- ReadNumber 160,GetTime 163,HaveNumber 160, - TestSeq.GetTime _, - TestSeq.HaveNumber numh_160, - TestSeq.ReadNumber numr_171, -- ReadNumber 171,GetTime 174,HaveNumber 171, - TestSeq.GetTime _, - TestSeq.HaveNumber numh_171, - TestSeq.ReadNumber numr_182, -- ReadNumber 182,GetTime 185,HaveNumber 182,GetTime 193, - TestSeq.GetTime _, - TestSeq.HaveNumber numh_182, - TestSeq.GetTime _, - TestSeq.ReadNumber numr_196, -- ReadNumber 196,GetTime 199,HaveNumber 196, - TestSeq.GetTime _, - TestSeq.HaveNumber numh_196, - TestSeq.ReadNumber numr_207, -- ReadNumber 207,GetTime 210,HaveNumber 207, - TestSeq.GetTime _, - TestSeq.HaveNumber numh_207, - TestSeq.ReadNumber numr_218, -- ReadNumber 218,GetTime 221,HaveNumber 218, - TestSeq.GetTime _, - TestSeq.HaveNumber numh_218, - - TestSeq.HaveNumber 3, - TestSeq.GetTime _, - TestSeq.HaveNumber 0 ] - - | numr_4 == numh_4 && - numr_18 == numh_18 && - numr_29 == numh_29 && - numh_29 == numh_29' && - numr_40 == numh_40 && - numr_58 == numh_58 && - numh_58 == numh_58' && - numr_84 == numh_84 && - numr_98 == numh_98 && - numr_109 == numh_109 && - numr_123 == numh_123 && - numr_134 == numh_134 && - numh_134 == numh_134' && - numr_160 == numh_160 && - numr_171 == numh_171 && - numr_182 == numh_182 && - numr_196 == numh_196 && - numr_207 == numh_207 && - numr_218 == numh_218 && - numr_4 < numh_18 && - numh_18 < numh_29 && - numh_29 < numh_40 && - numh_40 < numh_58 && - numh_58 < numh_84 && - numh_84 < numh_98 && - numh_98 < numh_109 && - numh_109 < numh_123 && - numh_123 < numh_134 && - numh_134 < numh_160 && - numh_160 < numh_171 && - numh_171 < numh_182 && - numh_182 < numh_196 && - numh_196 < numh_207 && - numh_207 < numh_218 - -> True - _ -> False - -pattern'''''I c = - case c of -- - [ TestSeq.ReadNumber numr_4, -- ReadNumber 4,GetTime 7,HaveNumber 4,HaveNumber 4, - TestSeq.GetTime _, - TestSeq.HaveNumber numh_4, - TestSeq.HaveNumber numh_4', - TestSeq.ReadNumber numr_21, -- ReadNumber 21,GetTime 24,HaveNumber 21, - TestSeq.GetTime _, - TestSeq.HaveNumber numh_21, - TestSeq.ReadNumber numr_32, -- ReadNumber 32,GetTime 35,HaveNumber 32, - TestSeq.GetTime _, - TestSeq.HaveNumber numh_32, - TestSeq.HaveNumber numh_21', -- HaveNumber 21, - TestSeq.ReadNumber numr_50, -- ReadNumber 50,GetTime 53,HaveNumber 50,HaveNumber 50, - TestSeq.GetTime _, - TestSeq.HaveNumber numh_50, - TestSeq.HaveNumber numh_50', - - TestSeq.HaveNumber 2, - TestSeq.GetTime _, - TestSeq.HaveNumber 1, - - TestSeq.ReadNumber numr_76, -- ReadNumber 76,GetTime 79,HaveNumber 76,HaveNumber 76, - TestSeq.GetTime _, - TestSeq.HaveNumber numh_76, - TestSeq.HaveNumber numh_76', - - TestSeq.HaveNumber numh_4'', - - TestSeq.HaveNumber numh_76'', -- HaveNumber 76,HaveNumber 32,HaveNumber 32, - TestSeq.HaveNumber numh_32'', - TestSeq.HaveNumber numh_32''', - - TestSeq.HaveNumber 0, - TestSeq.GetTime _, - TestSeq.HaveNumber 0, - - TestSeq.ReadNumber numr_126, -- ReadNumber 126,GetTime 129,HaveNumber 126, - TestSeq.GetTime _, - TestSeq.HaveNumber numh_126, - TestSeq.ReadNumber numr_137, -- ReadNumber 137,GetTime 140,HaveNumber 137, - TestSeq.GetTime _, - TestSeq.HaveNumber numh_137, - TestSeq.ReadNumber numr_148, -- ReadNumber 148,GetTime 151,HaveNumber 148, - TestSeq.GetTime _, - TestSeq.HaveNumber numh_148, - - TestSeq.HaveNumber numh_126', -- HaveNumber 126,HaveNumber 137,HaveNumber 148, - TestSeq.HaveNumber numh_137', - TestSeq.HaveNumber numh_148', - - TestSeq.HaveNumber 3, - TestSeq.GetTime _, - TestSeq.HaveNumber 2 ] - - | numr_4 == numh_4 && - numh_4 == numh_4' && - numh_4 == numh_4'' && - numr_21 == numh_21 && - numh_21 == numh_21' && - numr_32 == numh_32 && - numh_32 == numh_32'' && - numh_32 == numh_32''' && - numr_50 == numh_50 && - numh_50 == numh_50' && - numr_76 == numh_76 && - numh_76' == numh_76'' && - numr_126 == numh_126 && - numh_126 == numh_126' && - numr_137 == numh_137 && - numh_137 == numh_137' && - numr_148 == numh_148 && - numh_148 == numh_148' && - numh_4 < numh_21 && - numh_21 < numh_32 && - numh_32 < numh_50 && - numh_50 < numh_76 && - numh_76 < numh_126 && - numh_126 < numh_137 && - numh_137 < numh_148 - - -> True - _ -> False - -pattern''''''I c = - case c of -- - [ TestSeq.ReadNumber numr_4, -- ReadNumber 4,GetTime 7,HaveNumber 4,GetTime 15,GetTime 18,HaveNumber 4, - TestSeq.GetTime _, - TestSeq.HaveNumber numh_4, - TestSeq.GetTime _, - TestSeq.GetTime _, - TestSeq.HaveNumber numh_4', - TestSeq.ReadNumber numr_26, -- ReadNumber 26,GetTime 29,HaveNumber 26, - TestSeq.GetTime _, - TestSeq.HaveNumber numh_26, - TestSeq.ReadNumber numr_37, -- ReadNumber 37,GetTime 40,HaveNumber 37, - TestSeq.GetTime _, - TestSeq.HaveNumber numh_37, - TestSeq.HaveNumber numh_26', -- HaveNumber 26, - TestSeq.ReadNumber numr_55, -- ReadNumber 55,GetTime 58,HaveNumber 55,HaveNumber 55, - TestSeq.GetTime _, - TestSeq.HaveNumber numh_55, - TestSeq.HaveNumber numh_55', - - TestSeq.HaveNumber 2, - TestSeq.GetTime _, - TestSeq.HaveNumber 1, - - TestSeq.ReadNumber numr_81, -- ReadNumber 81,GetTime 84,HaveNumber 81,GetTime 92,GetTime 95,HaveNumber 81, - TestSeq.GetTime _, - TestSeq.HaveNumber numh_81, - TestSeq.GetTime _, - TestSeq.GetTime _, - TestSeq.HaveNumber numh_81', - - TestSeq.ReadNumber numr_103, -- ReadNumber 103,GetTime 106,HaveNumber 103,GetTime 114,GetTime 117,HaveNumber 81, - TestSeq.GetTime _, - TestSeq.HaveNumber numh_103, - TestSeq.GetTime _, - TestSeq.GetTime _, - TestSeq.HaveNumber numh_81'', - - TestSeq.ReadNumber numr_125, -- ReadNumber 125,GetTime 128,HaveNumber 125,HaveNumber 125, - TestSeq.GetTime _, - TestSeq.HaveNumber numh_125, - TestSeq.HaveNumber numh_125', - - TestSeq.HaveNumber 0, - TestSeq.GetTime _, - TestSeq.HaveNumber 0, - - TestSeq.ReadNumber numr_151, -- ReadNumber 151,GetTime 154,HaveNumber 151, - TestSeq.GetTime _, - TestSeq.HaveNumber numh_151, - TestSeq.ReadNumber numr_162, -- ReadNumber 162,GetTime 165,HaveNumber 162, - TestSeq.GetTime _, - TestSeq.HaveNumber numh_162, - TestSeq.ReadNumber numr_173, -- ReadNumber 173,GetTime 176,HaveNumber 173, - TestSeq.GetTime _, - TestSeq.HaveNumber numh_173, - - TestSeq.GetTime _, -- GetTime 184,GetTime 187,HaveNumber 151, - TestSeq.GetTime _, - TestSeq.HaveNumber numh_151', - TestSeq.GetTime _, -- GetTime 195,GetTime 198,HaveNumber 162, - TestSeq.GetTime _, - TestSeq.HaveNumber numh_162', - TestSeq.GetTime _, -- GetTime 206,GetTime 209,HaveNumber 173, - TestSeq.GetTime _, - TestSeq.HaveNumber numh_173', - - TestSeq.HaveNumber 2, - TestSeq.GetTime _, - TestSeq.HaveNumber 1 ] - | numr_4 == numh_4 && - numh_4 == numh_4' && - numr_26 == numh_26 && - numh_26 == numh_26' && - numr_37 == numh_37 && - numr_55 == numh_55 && - numh_55 == numh_55' && - numr_81 == numh_81 && - numh_81 == numh_81' && - numh_81 == numh_81'' && - numr_103 == numh_103 && - numr_125 == numh_125 && - numh_125 == numh_125' && - numr_151 == numh_151 && - numh_151 == numh_151' && - numr_162 == numh_162 && - numh_162 == numh_162' && - numr_173 == numh_173 && - numh_173 == numh_173' && - numh_4 < numh_26 && - numh_26 < numh_37 && - numh_37 < numh_55 && - numh_55 < numh_81 && - numh_81 < numh_103 && - numh_103 < numh_125 && - numh_125 < numh_151 && - numh_151 < numh_162 && - numh_162 < numh_173 - -> True - _ -> False - -testLookupsI lookup invalidate invalidateCache keysCached keysNotExpired = do - b <- lookup ("file1" :: BS.ByteString) - TestSeq.haveNumber b - b <- lookup "file1" - TestSeq.haveNumber b - b <- lookup "file2" - TestSeq.haveNumber b - b <- lookup "file3" - TestSeq.haveNumber b - mb <- invalidate "file2" - case mb of - Just b -> TestSeq.haveNumber b - Nothing -> TestSeq.haveNumber 0 - b <- lookup "file2" - TestSeq.haveNumber b - mb <- invalidate "file2" - case mb of - Just b -> TestSeq.haveNumber b - Nothing -> TestSeq.haveNumber 0 - l <- keysCached - TestSeq.haveNumber (length l) - l <- keysNotExpired - TestSeq.haveNumber (length l) - b <- lookup "file2" - TestSeq.haveNumber b - b <- lookup "file2" - TestSeq.haveNumber b - b <- lookup "file1" - TestSeq.haveNumber b - b <- lookup "file2" - TestSeq.haveNumber b - b <- lookup "file3" - TestSeq.haveNumber b - mk <- invalidateCache - case mk of - Just (_, b) -> TestSeq.haveNumber b - Nothing -> TestSeq.haveNumber 0 - l <- keysCached - TestSeq.haveNumber (length l) - l <- keysNotExpired - TestSeq.haveNumber (length l) - b <- lookup "file1" - TestSeq.haveNumber b - b <- lookup "file2" - TestSeq.haveNumber b - b <- lookup "file3" - TestSeq.haveNumber b - b <- lookup "file1" - TestSeq.haveNumber b - b <- lookup "file2" - TestSeq.haveNumber b - b <- lookup "file3" - TestSeq.haveNumber b - l <- keysCached - TestSeq.haveNumber (length l) - l <- keysNotExpired - TestSeq.haveNumber (length l) - - return b +{-# LANGUAGE OverloadedStrings #-} + +module TestECMWithTestSequenceCommonInvalidating ( + someEventsOnlyI, + numberEventsOnlyI, + pattern'I, + pattern''I, + pattern'''I, + pattern''''I, + pattern'''''I, + pattern''''''I, + testLookupsI, + printOutEventsI, + printOutFailedPatternI +) where + +import qualified Caching.ExpiringCacheMap.Utils.TestSequence as TestSeq + +import qualified Data.ByteString.Char8 as BS + +printOutFailedPatternI from_where filt_events' filt_events'' filt_events''' filt_events'''' filt_events''''' filt_events'''''' = do + putStrLn $ "Failed sequence test in " ++ from_where ++ ":" + if not (pattern'I (filt_events')) + then putStrLn $ "Failed: pattern 1: " ++ (show filt_events') + else return () + if not (pattern''I (filt_events'')) + then putStrLn $ "Failed: pattern 2: " ++ (show filt_events'') + else return () + if not (pattern'''I (filt_events''')) + then putStrLn $ "Failed: pattern 3: " ++ (show filt_events''') + else return () + if not (pattern''''I (filt_events'''')) + then putStrLn $ "Failed: pattern 4: " ++ (show filt_events'''') + else return () + if not (pattern'''''I (filt_events''''')) + then putStrLn $ "Failed: pattern 5: " ++ (show filt_events''''') + else return () + if not (pattern''''''I (filt_events'''''')) + then putStrLn $ "Failed: pattern 6: " ++ (show filt_events'''''') + else return () + return () + + +printOutEventsI events' events'' events''' events'''' events''''' events'''''' = do + (putStrLn . show . filter someEventsOnlyI . reverse) events' + (putStrLn . show . filter someEventsOnlyI . reverse) events'' + (putStrLn . show . filter someEventsOnlyI . reverse) events''' + (putStrLn . show . filter someEventsOnlyI . reverse) events'''' + (putStrLn . show . filter someEventsOnlyI . reverse) events''''' + (putStrLn . show . filter someEventsOnlyI . reverse) events'''''' + return () + +someEventsOnlyI a = + case a of + TestSeq.GetTime _ -> True + TestSeq.ReadNumber _ -> True + TestSeq.HaveNumber _ -> True + _ -> False + +numberEventsOnlyI a = + case a of + TestSeq.ReadNumber _ -> True + TestSeq.HaveNumber _ -> True + _ -> False + +pattern'I c = + case c of -- + [ TestSeq.ReadNumber numr_4, -- ReadNumber 4,GetTime 7,HaveNumber 4,HaveNumber 4 + TestSeq.GetTime _, + TestSeq.HaveNumber numh_4, + TestSeq.HaveNumber numh_4', + TestSeq.ReadNumber numr_21, -- ReadNumber 21,GetTime 24,HaveNumber 21, + TestSeq.GetTime _, + TestSeq.HaveNumber numh_21, + TestSeq.ReadNumber numr_32, -- ReadNumber 32,GetTime 35,HaveNumber 32, + TestSeq.GetTime _, + TestSeq.HaveNumber numh_32, + TestSeq.HaveNumber numh_21', -- HaveNumber 21, + TestSeq.ReadNumber numr_50, -- ReadNumber 50,GetTime 53,HaveNumber 50,HaveNumber 50, + TestSeq.GetTime _, + TestSeq.HaveNumber numh_50, + TestSeq.HaveNumber numh_50', + + TestSeq.HaveNumber 2, + TestSeq.GetTime _, + TestSeq.HaveNumber 2, + + TestSeq.ReadNumber numr_76, -- ReadNumber 76,GetTime 79,HaveNumber 76,HaveNumber 76, + TestSeq.GetTime _, + TestSeq.HaveNumber numh_76, + TestSeq.HaveNumber numh_76', + + TestSeq.HaveNumber numh_4'', + + TestSeq.HaveNumber numh_76'', -- HaveNumber 76,HaveNumber 32,HaveNumber 32, + TestSeq.HaveNumber numh_32'', + TestSeq.HaveNumber numh_32''', + + TestSeq.HaveNumber 0, + TestSeq.GetTime _, + TestSeq.HaveNumber 0, + + TestSeq.ReadNumber numr_126, -- ReadNumber 126,GetTime 129,HaveNumber 126, + TestSeq.GetTime _, + TestSeq.HaveNumber numh_126, + TestSeq.ReadNumber numr_137, -- ReadNumber 137,GetTime 140,HaveNumber 137, + TestSeq.GetTime _, + TestSeq.HaveNumber numh_137, + TestSeq.ReadNumber numr_148, -- ReadNumber 148,GetTime 151,HaveNumber 148, + TestSeq.GetTime _, + TestSeq.HaveNumber numh_148, + + TestSeq.HaveNumber numh_126', -- HaveNumber 126,HaveNumber 137,HaveNumber 148, + TestSeq.HaveNumber numh_137', + TestSeq.HaveNumber numh_148', + + TestSeq.HaveNumber 3, + TestSeq.GetTime _, + TestSeq.HaveNumber 3] + | numr_4 == numh_4 && + numh_4 == numh_4' && + numh_4 == numh_4'' && + numr_21 == numh_21 && + numh_21 == numh_21' && + numr_32 == numh_32 && + numh_32 == numh_32'' && + numh_32 == numh_32''' && + numr_50 == numh_50 && + numh_50 == numh_50' && + numr_76 == numh_76 && + numh_76 == numh_76' && + numh_76 == numh_76'' && + numr_126 == numh_126 && + numh_126 == numh_126' && + numr_137 == numh_137 && + numh_137 == numh_137' && + numr_148 == numh_148 && + numh_148 == numh_148' && + numh_4 < numh_21 && + numh_21 < numh_32 && + numh_32 < numh_50 && + numh_50 < numh_76 && + numh_76 < numh_126 && + numh_126 < numh_137 && + numh_137 < numh_148 + -> True + _ -> False + +pattern''I c = + case c of -- + [ TestSeq.ReadNumber numr_4, -- ReadNumber 4,GetTime 7,HaveNumber 4,GetTime 15,GetTime 18,HaveNumber 4, + TestSeq.GetTime _, + TestSeq.HaveNumber numh_4, + TestSeq.GetTime _, + TestSeq.GetTime _, + TestSeq.HaveNumber numh_4', + TestSeq.ReadNumber numr_26, -- ReadNumber 26,GetTime 29,HaveNumber 26, + TestSeq.GetTime _, + TestSeq.HaveNumber numh_26, + TestSeq.ReadNumber numr_37, -- ReadNumber 37,GetTime 40,HaveNumber 37, + TestSeq.GetTime _, + TestSeq.HaveNumber numh_37, + TestSeq.HaveNumber numh_26', -- HaveNumber 26, + TestSeq.ReadNumber numr_55, -- ReadNumber 55,GetTime 58,HaveNumber 55,HaveNumber 55, + TestSeq.GetTime _, + TestSeq.HaveNumber numh_55, + TestSeq.HaveNumber numh_55', + + TestSeq.HaveNumber 2, + TestSeq.GetTime _, + TestSeq.HaveNumber 2, + + TestSeq.ReadNumber numr_81, -- ReadNumber 81,GetTime 84,HaveNumber 81,GetTime 92,GetTime 95,HaveNumber 81 + TestSeq.GetTime _, + TestSeq.HaveNumber numh_81, + TestSeq.GetTime _, + TestSeq.GetTime _, + TestSeq.HaveNumber numh_81', + + TestSeq.GetTime _, -- GetTime 103,GetTime 106, + TestSeq.GetTime _, + TestSeq.HaveNumber numh_4'', + + TestSeq.GetTime _, -- GetTime 114,GetTime 117,HaveNumber 81, + TestSeq.GetTime _, + TestSeq.HaveNumber numh_81'', + TestSeq.GetTime _, -- GetTime 125,GetTime 128,HaveNumber 37,HaveNumber 37, + TestSeq.GetTime _, + TestSeq.HaveNumber numh_37', + TestSeq.HaveNumber numh_37'', + + TestSeq.HaveNumber 0, + TestSeq.GetTime _, + TestSeq.HaveNumber 0, + + TestSeq.ReadNumber numr_151, -- ReadNumber 151,GetTime 154,HaveNumber 151, + TestSeq.GetTime _, + TestSeq.HaveNumber numh_151, + TestSeq.ReadNumber numr_162, -- ReadNumber 162,GetTime 165,HaveNumber 162, + TestSeq.GetTime _, + TestSeq.HaveNumber numh_162, + TestSeq.ReadNumber numr_173, -- ReadNumber 173,GetTime 176,HaveNumber 173, + TestSeq.GetTime _, + TestSeq.HaveNumber numh_173, + + TestSeq.GetTime _, -- GetTime 184,GetTime 187,HaveNumber 151, + TestSeq.GetTime _, + TestSeq.HaveNumber numh_151', + TestSeq.GetTime _, -- GetTime 195,GetTime 198,HaveNumber 162, + TestSeq.GetTime _, + TestSeq.HaveNumber numh_162', + TestSeq.GetTime _, -- GetTime 206,GetTime 209,HaveNumber 173, + TestSeq.GetTime _, + TestSeq.HaveNumber numh_173', + + TestSeq.HaveNumber 3, + TestSeq.GetTime _, + TestSeq.HaveNumber 3] + | numr_4 == numh_4 && + numh_4 == numh_4' && + numh_4 == numh_4'' && + numr_26 == numh_26 && + numh_26 == numh_26' && + numr_37 == numh_37 && + numh_37 == numh_37' && + numh_37 == numh_37'' && + numr_55 == numh_55 && + numh_55 == numh_55' && + numr_81 == numh_81 && + numh_81 == numh_81' && + numh_81 == numh_81'' && + numr_151 == numh_151 && + numh_151 == numh_151' && + numr_162 == numh_162 && + numh_162 == numh_162' && + numr_173 == numh_173 && + numh_173 == numh_173' && + numh_4 < numh_26 && + numh_26 < numh_37 && + numh_37 < numh_55 && + numh_55 < numh_81 && + numh_81 < numh_151 && + numh_151 < numh_162 && + numh_162 < numh_173 + -> True + _ -> False + +pattern'''I c = + case c of -- + [ TestSeq.ReadNumber numr_4, -- ReadNumber 4,GetTime 7,HaveNumber 4,HaveNumber 4, + TestSeq.GetTime _, + TestSeq.HaveNumber numh_4, + TestSeq.HaveNumber numh_4', + TestSeq.ReadNumber numr_21, -- ReadNumber 21,GetTime 24,HaveNumber 21, + TestSeq.GetTime _, + TestSeq.HaveNumber numh_21, + TestSeq.ReadNumber numr_32, -- ReadNumber 32,GetTime 35,HaveNumber 32, + TestSeq.GetTime _, + TestSeq.HaveNumber numh_32, + TestSeq.HaveNumber numh_21', -- HaveNumber 21, + TestSeq.ReadNumber numr_50, -- ReadNumber 50,GetTime 53,HaveNumber 50,HaveNumber 50, + TestSeq.GetTime _, + TestSeq.HaveNumber numh_50, + TestSeq.HaveNumber numh_50', + + TestSeq.HaveNumber 2, + TestSeq.GetTime _, + TestSeq.HaveNumber 0, + + TestSeq.ReadNumber numr_76, -- ReadNumber 76,GetTime 79,HaveNumber 76,HaveNumber 76, + TestSeq.GetTime _, + TestSeq.HaveNumber numh_76, + TestSeq.HaveNumber numh_76', + + TestSeq.HaveNumber numh_4'', + + TestSeq.HaveNumber numh_76'', -- HaveNumber 76,HaveNumber 32,HaveNumber 32, + TestSeq.HaveNumber numh_32'', + TestSeq.HaveNumber numh_32''', + + TestSeq.HaveNumber 0, + TestSeq.GetTime _, + TestSeq.HaveNumber 0, + + TestSeq.ReadNumber numr_126, -- ReadNumber 126,GetTime 129,HaveNumber 126, + TestSeq.GetTime _, + TestSeq.HaveNumber numh_126, + TestSeq.ReadNumber numr_137, -- ReadNumber 137,GetTime 140,HaveNumber 137, + TestSeq.GetTime _, + TestSeq.HaveNumber numh_137, + TestSeq.ReadNumber numr_148, -- ReadNumber 148,GetTime 151,HaveNumber 148, + TestSeq.GetTime _, + TestSeq.HaveNumber numh_148, + + TestSeq.HaveNumber numh_126', -- HaveNumber 126,HaveNumber 137,HaveNumber 148, + TestSeq.HaveNumber numh_137', + TestSeq.HaveNumber numh_148', + + TestSeq.HaveNumber 3, + TestSeq.GetTime _, + TestSeq.HaveNumber 0 ] + | numr_4 == numh_4 && + numh_4 == numh_4' && + numh_4 == numh_4'' && + numr_21 == numh_21 && + numh_21 == numh_21' && + numr_32 == numh_32 && + numh_32 == numh_32'' && + numh_32 == numh_32''' && + numr_50 == numh_50 && + numh_50 == numh_50' && + numr_76 == numh_76 && + numh_76' == numh_76'' && + numr_126 == numh_126 && + numh_126 == numh_126' && + numr_137 == numh_137 && + numh_137 == numh_137' && + numr_148 == numh_148 && + numh_148 == numh_148' && + numh_4 < numh_21 && + numh_21 < numh_32 && + numh_32 < numh_50 && + numh_50 < numh_76 && + numh_76 < numh_126 && + numh_126 < numh_137 && + numh_137 < numh_148 + -> True + _ -> False + +pattern''''I c = + case c of -- + [ TestSeq.ReadNumber numr_4, -- ReadNumber 4,GetTime 7,HaveNumber 4,GetTime 15, + TestSeq.GetTime _, + TestSeq.HaveNumber numh_4, + TestSeq.GetTime _, + TestSeq.ReadNumber numr_18, -- ReadNumber 18,GetTime 21,HaveNumber 18, + TestSeq.GetTime _, + TestSeq.HaveNumber numh_18, + TestSeq.ReadNumber numr_29, -- ReadNumber 29,GetTime 32,HaveNumber 29, + TestSeq.GetTime _, + TestSeq.HaveNumber numh_29, + TestSeq.ReadNumber numr_40, -- ReadNumber 40,GetTime 43,HaveNumber 40,HaveNumber 29, + TestSeq.GetTime _, + TestSeq.HaveNumber numh_40, + TestSeq.HaveNumber numh_29', + + TestSeq.ReadNumber numr_58, -- ReadNumber 58,GetTime 61,HaveNumber 58,HaveNumber 58, + TestSeq.GetTime _, + TestSeq.HaveNumber numh_58, + TestSeq.HaveNumber numh_58', + + TestSeq.HaveNumber 2, + TestSeq.GetTime _, + TestSeq.HaveNumber 0, + + TestSeq.ReadNumber numr_84, -- ReadNumber 84,GetTime 87,HaveNumber 84,GetTime 95, + TestSeq.GetTime _, + TestSeq.HaveNumber numh_84, + TestSeq.GetTime _, + TestSeq.ReadNumber numr_98, -- ReadNumber 98,GetTime 101,HaveNumber 98, + TestSeq.GetTime _, + TestSeq.HaveNumber numh_98, + TestSeq.ReadNumber numr_109, -- ReadNumber 109,GetTime 112,HaveNumber 109,GetTime 120, + TestSeq.GetTime _, + TestSeq.HaveNumber numh_109, + TestSeq.GetTime _, + TestSeq.ReadNumber numr_123, -- ReadNumber 123,GetTime 126,HaveNumber 123, + TestSeq.GetTime _, + TestSeq.HaveNumber numh_123, + TestSeq.ReadNumber numr_134, -- ReadNumber 134,GetTime 137,HaveNumber 134,HaveNumber 134, + TestSeq.GetTime _, + TestSeq.HaveNumber numh_134, + TestSeq.HaveNumber numh_134', + + TestSeq.HaveNumber 0, + TestSeq.GetTime _, + TestSeq.HaveNumber 0, + + TestSeq.ReadNumber numr_160, -- ReadNumber 160,GetTime 163,HaveNumber 160, + TestSeq.GetTime _, + TestSeq.HaveNumber numh_160, + TestSeq.ReadNumber numr_171, -- ReadNumber 171,GetTime 174,HaveNumber 171, + TestSeq.GetTime _, + TestSeq.HaveNumber numh_171, + TestSeq.ReadNumber numr_182, -- ReadNumber 182,GetTime 185,HaveNumber 182,GetTime 193, + TestSeq.GetTime _, + TestSeq.HaveNumber numh_182, + TestSeq.GetTime _, + TestSeq.ReadNumber numr_196, -- ReadNumber 196,GetTime 199,HaveNumber 196, + TestSeq.GetTime _, + TestSeq.HaveNumber numh_196, + TestSeq.ReadNumber numr_207, -- ReadNumber 207,GetTime 210,HaveNumber 207, + TestSeq.GetTime _, + TestSeq.HaveNumber numh_207, + TestSeq.ReadNumber numr_218, -- ReadNumber 218,GetTime 221,HaveNumber 218, + TestSeq.GetTime _, + TestSeq.HaveNumber numh_218, + + TestSeq.HaveNumber 3, + TestSeq.GetTime _, + TestSeq.HaveNumber 0 ] + + | numr_4 == numh_4 && + numr_18 == numh_18 && + numr_29 == numh_29 && + numh_29 == numh_29' && + numr_40 == numh_40 && + numr_58 == numh_58 && + numh_58 == numh_58' && + numr_84 == numh_84 && + numr_98 == numh_98 && + numr_109 == numh_109 && + numr_123 == numh_123 && + numr_134 == numh_134 && + numh_134 == numh_134' && + numr_160 == numh_160 && + numr_171 == numh_171 && + numr_182 == numh_182 && + numr_196 == numh_196 && + numr_207 == numh_207 && + numr_218 == numh_218 && + numr_4 < numh_18 && + numh_18 < numh_29 && + numh_29 < numh_40 && + numh_40 < numh_58 && + numh_58 < numh_84 && + numh_84 < numh_98 && + numh_98 < numh_109 && + numh_109 < numh_123 && + numh_123 < numh_134 && + numh_134 < numh_160 && + numh_160 < numh_171 && + numh_171 < numh_182 && + numh_182 < numh_196 && + numh_196 < numh_207 && + numh_207 < numh_218 + -> True + _ -> False + +pattern'''''I c = + case c of -- + [ TestSeq.ReadNumber numr_4, -- ReadNumber 4,GetTime 7,HaveNumber 4,HaveNumber 4, + TestSeq.GetTime _, + TestSeq.HaveNumber numh_4, + TestSeq.HaveNumber numh_4', + TestSeq.ReadNumber numr_21, -- ReadNumber 21,GetTime 24,HaveNumber 21, + TestSeq.GetTime _, + TestSeq.HaveNumber numh_21, + TestSeq.ReadNumber numr_32, -- ReadNumber 32,GetTime 35,HaveNumber 32, + TestSeq.GetTime _, + TestSeq.HaveNumber numh_32, + TestSeq.HaveNumber numh_21', -- HaveNumber 21, + TestSeq.ReadNumber numr_50, -- ReadNumber 50,GetTime 53,HaveNumber 50,HaveNumber 50, + TestSeq.GetTime _, + TestSeq.HaveNumber numh_50, + TestSeq.HaveNumber numh_50', + + TestSeq.HaveNumber 2, + TestSeq.GetTime _, + TestSeq.HaveNumber 1, + + TestSeq.ReadNumber numr_76, -- ReadNumber 76,GetTime 79,HaveNumber 76,HaveNumber 76, + TestSeq.GetTime _, + TestSeq.HaveNumber numh_76, + TestSeq.HaveNumber numh_76', + + TestSeq.HaveNumber numh_4'', + + TestSeq.HaveNumber numh_76'', -- HaveNumber 76,HaveNumber 32,HaveNumber 32, + TestSeq.HaveNumber numh_32'', + TestSeq.HaveNumber numh_32''', + + TestSeq.HaveNumber 0, + TestSeq.GetTime _, + TestSeq.HaveNumber 0, + + TestSeq.ReadNumber numr_126, -- ReadNumber 126,GetTime 129,HaveNumber 126, + TestSeq.GetTime _, + TestSeq.HaveNumber numh_126, + TestSeq.ReadNumber numr_137, -- ReadNumber 137,GetTime 140,HaveNumber 137, + TestSeq.GetTime _, + TestSeq.HaveNumber numh_137, + TestSeq.ReadNumber numr_148, -- ReadNumber 148,GetTime 151,HaveNumber 148, + TestSeq.GetTime _, + TestSeq.HaveNumber numh_148, + + TestSeq.HaveNumber numh_126', -- HaveNumber 126,HaveNumber 137,HaveNumber 148, + TestSeq.HaveNumber numh_137', + TestSeq.HaveNumber numh_148', + + TestSeq.HaveNumber 3, + TestSeq.GetTime _, + TestSeq.HaveNumber 2 ] + + | numr_4 == numh_4 && + numh_4 == numh_4' && + numh_4 == numh_4'' && + numr_21 == numh_21 && + numh_21 == numh_21' && + numr_32 == numh_32 && + numh_32 == numh_32'' && + numh_32 == numh_32''' && + numr_50 == numh_50 && + numh_50 == numh_50' && + numr_76 == numh_76 && + numh_76' == numh_76'' && + numr_126 == numh_126 && + numh_126 == numh_126' && + numr_137 == numh_137 && + numh_137 == numh_137' && + numr_148 == numh_148 && + numh_148 == numh_148' && + numh_4 < numh_21 && + numh_21 < numh_32 && + numh_32 < numh_50 && + numh_50 < numh_76 && + numh_76 < numh_126 && + numh_126 < numh_137 && + numh_137 < numh_148 + + -> True + _ -> False + +pattern''''''I c = + case c of -- + [ TestSeq.ReadNumber numr_4, -- ReadNumber 4,GetTime 7,HaveNumber 4,GetTime 15,GetTime 18,HaveNumber 4, + TestSeq.GetTime _, + TestSeq.HaveNumber numh_4, + TestSeq.GetTime _, + TestSeq.GetTime _, + TestSeq.HaveNumber numh_4', + TestSeq.ReadNumber numr_26, -- ReadNumber 26,GetTime 29,HaveNumber 26, + TestSeq.GetTime _, + TestSeq.HaveNumber numh_26, + TestSeq.ReadNumber numr_37, -- ReadNumber 37,GetTime 40,HaveNumber 37, + TestSeq.GetTime _, + TestSeq.HaveNumber numh_37, + TestSeq.HaveNumber numh_26', -- HaveNumber 26, + TestSeq.ReadNumber numr_55, -- ReadNumber 55,GetTime 58,HaveNumber 55,HaveNumber 55, + TestSeq.GetTime _, + TestSeq.HaveNumber numh_55, + TestSeq.HaveNumber numh_55', + + TestSeq.HaveNumber 2, + TestSeq.GetTime _, + TestSeq.HaveNumber 1, + + TestSeq.ReadNumber numr_81, -- ReadNumber 81,GetTime 84,HaveNumber 81,GetTime 92,GetTime 95,HaveNumber 81, + TestSeq.GetTime _, + TestSeq.HaveNumber numh_81, + TestSeq.GetTime _, + TestSeq.GetTime _, + TestSeq.HaveNumber numh_81', + + TestSeq.ReadNumber numr_103, -- ReadNumber 103,GetTime 106,HaveNumber 103,GetTime 114,GetTime 117,HaveNumber 81, + TestSeq.GetTime _, + TestSeq.HaveNumber numh_103, + TestSeq.GetTime _, + TestSeq.GetTime _, + TestSeq.HaveNumber numh_81'', + + TestSeq.ReadNumber numr_125, -- ReadNumber 125,GetTime 128,HaveNumber 125,HaveNumber 125, + TestSeq.GetTime _, + TestSeq.HaveNumber numh_125, + TestSeq.HaveNumber numh_125', + + TestSeq.HaveNumber 0, + TestSeq.GetTime _, + TestSeq.HaveNumber 0, + + TestSeq.ReadNumber numr_151, -- ReadNumber 151,GetTime 154,HaveNumber 151, + TestSeq.GetTime _, + TestSeq.HaveNumber numh_151, + TestSeq.ReadNumber numr_162, -- ReadNumber 162,GetTime 165,HaveNumber 162, + TestSeq.GetTime _, + TestSeq.HaveNumber numh_162, + TestSeq.ReadNumber numr_173, -- ReadNumber 173,GetTime 176,HaveNumber 173, + TestSeq.GetTime _, + TestSeq.HaveNumber numh_173, + + TestSeq.GetTime _, -- GetTime 184,GetTime 187,HaveNumber 151, + TestSeq.GetTime _, + TestSeq.HaveNumber numh_151', + TestSeq.GetTime _, -- GetTime 195,GetTime 198,HaveNumber 162, + TestSeq.GetTime _, + TestSeq.HaveNumber numh_162', + TestSeq.GetTime _, -- GetTime 206,GetTime 209,HaveNumber 173, + TestSeq.GetTime _, + TestSeq.HaveNumber numh_173', + + TestSeq.HaveNumber 2, + TestSeq.GetTime _, + TestSeq.HaveNumber 1 ] + | numr_4 == numh_4 && + numh_4 == numh_4' && + numr_26 == numh_26 && + numh_26 == numh_26' && + numr_37 == numh_37 && + numr_55 == numh_55 && + numh_55 == numh_55' && + numr_81 == numh_81 && + numh_81 == numh_81' && + numh_81 == numh_81'' && + numr_103 == numh_103 && + numr_125 == numh_125 && + numh_125 == numh_125' && + numr_151 == numh_151 && + numh_151 == numh_151' && + numr_162 == numh_162 && + numh_162 == numh_162' && + numr_173 == numh_173 && + numh_173 == numh_173' && + numh_4 < numh_26 && + numh_26 < numh_37 && + numh_37 < numh_55 && + numh_55 < numh_81 && + numh_81 < numh_103 && + numh_103 < numh_125 && + numh_125 < numh_151 && + numh_151 < numh_162 && + numh_162 < numh_173 + -> True + _ -> False + +testLookupsI lookup invalidate invalidateCache keysCached keysNotExpired = do + b <- lookup ("file1" :: BS.ByteString) + TestSeq.haveNumber b + b <- lookup "file1" + TestSeq.haveNumber b + b <- lookup "file2" + TestSeq.haveNumber b + b <- lookup "file3" + TestSeq.haveNumber b + mb <- invalidate "file2" + case mb of + Just b -> TestSeq.haveNumber b + Nothing -> TestSeq.haveNumber 0 + b <- lookup "file2" + TestSeq.haveNumber b + mb <- invalidate "file2" + case mb of + Just b -> TestSeq.haveNumber b + Nothing -> TestSeq.haveNumber 0 + l <- keysCached + TestSeq.haveNumber (length l) + l <- keysNotExpired + TestSeq.haveNumber (length l) + b <- lookup "file2" + TestSeq.haveNumber b + b <- lookup "file2" + TestSeq.haveNumber b + b <- lookup "file1" + TestSeq.haveNumber b + b <- lookup "file2" + TestSeq.haveNumber b + b <- lookup "file3" + TestSeq.haveNumber b + mk <- invalidateCache + case mk of + Just (_, b) -> TestSeq.haveNumber b + Nothing -> TestSeq.haveNumber 0 + l <- keysCached + TestSeq.haveNumber (length l) + l <- keysNotExpired + TestSeq.haveNumber (length l) + b <- lookup "file1" + TestSeq.haveNumber b + b <- lookup "file2" + TestSeq.haveNumber b + b <- lookup "file3" + TestSeq.haveNumber b + b <- lookup "file1" + TestSeq.haveNumber b + b <- lookup "file2" + TestSeq.haveNumber b + b <- lookup "file3" + TestSeq.haveNumber b + l <- keysCached + TestSeq.haveNumber (length l) + l <- keysNotExpired + TestSeq.haveNumber (length l) + + return b diff --git a/tests/TestHashECMWithTestSequenceInvalidating.hs b/tests/TestHashECMWithTestSequenceInvalidating.hs --- a/tests/TestHashECMWithTestSequenceInvalidating.hs +++ b/tests/TestHashECMWithTestSequenceInvalidating.hs @@ -1,85 +1,85 @@ -{-# LANGUAGE OverloadedStrings #-} - -module TestHashECMWithTestSequenceInvalidating ( - testWithTestSequenceInvalidating -) where - -import Caching.ExpiringCacheMap.HashECM (newECMForM, lookupECM, CacheSettings(..), consistentDuration, invalidate, invalidateCache, keysCached, keysNotExpired) -import qualified Caching.ExpiringCacheMap.Utils.TestSequence as TestSeq - -import TestECMWithTestSequenceCommonInvalidating - -import qualified Data.ByteString.Char8 as BS -import System.Exit (exitFailure) - -testWithTestSequenceInvalidating = do - (TestSeq.TestSequenceState (_, events', _), return_value) <- TestSeq.runTestSequence test' - (TestSeq.TestSequenceState (_, events'', _), return_value) <- TestSeq.runTestSequence test'' - (TestSeq.TestSequenceState (_, events''', _), return_value) <- TestSeq.runTestSequence test''' - (TestSeq.TestSequenceState (_, events'''', _), return_value) <- TestSeq.runTestSequence test'''' - (TestSeq.TestSequenceState (_, events''''', _), return_value) <- TestSeq.runTestSequence test''''' - (TestSeq.TestSequenceState (_, events'''''', _), return_value) <- TestSeq.runTestSequence test'''''' - if pattern'I (filt events') && - pattern''I (filt events'') && - pattern'''I (filt events''') && - pattern''''I (filt events'''') && - pattern'''''I (filt events''''') && - pattern''''''I (filt events'''''') - then do - putStrLn "Passed TestHashECMWithTestSequenceInvalidating" - -- printOutEvents events' events'' events''' events'''' - return () - else do - printOutFailedPatternI "TestHashECMWithTestSequenceInvalidating.testWithTestSequenceInvalidating" - (filt events') (filt events'') (filt events''') (filt events'''') (filt events''''') (filt events'''''') - printOutEventsI events' events'' events''' events'''' events''''' events'''''' - exitFailure - where - filt = filter someEventsOnlyI . reverse - commonreadnumber = - (\state _id -> do number <- TestSeq.readNumber - return (state, number)) - - newTestECM valreq timecheck = - newECMForM valreq - (TestSeq.getCurrentTime >>= return) - timecheck - (CacheWithLRUList 6 6 12) - TestSeq.newTestSVar TestSeq.enterTestSVar TestSeq.readTestSVar - - test' = do - filecache <- newTestECM - (consistentDuration 100 commonreadnumber) -- Duration between access and expiry time - 12000 -- Time check frequency - testLookupsI (lookupECM filecache) (invalidate filecache) (invalidateCache filecache) (keysCached filecache) (keysNotExpired filecache) - - test'' = do - filecache <- newTestECM - (consistentDuration 100 commonreadnumber) -- Duration between access and expiry time - 1 -- Time check frequency - testLookupsI (lookupECM filecache) (invalidate filecache) (invalidateCache filecache) (keysCached filecache) (keysNotExpired filecache) - - test''' = do - filecache <- newTestECM - (consistentDuration 1 commonreadnumber) -- Duration between access and expiry time - 12000 -- Time check frequency - testLookupsI (lookupECM filecache) (invalidate filecache) (invalidateCache filecache) (keysCached filecache) (keysNotExpired filecache) - - test'''' = do - filecache <- newTestECM - (consistentDuration 1 commonreadnumber) -- Duration between access and expiry time - 1 -- Time check frequency - testLookupsI (lookupECM filecache) (invalidate filecache) (invalidateCache filecache) (keysCached filecache) (keysNotExpired filecache) - - test''''' = do - filecache <- newTestECM - (consistentDuration 50 commonreadnumber) -- Duration between access and expiry time - 12000 -- Time check frequency - testLookupsI (lookupECM filecache) (invalidate filecache) (invalidateCache filecache) (keysCached filecache) (keysNotExpired filecache) - - test'''''' = do - filecache <- newTestECM - (consistentDuration 50 commonreadnumber) -- Duration between access and expiry time - 1 -- Time check frequency - testLookupsI (lookupECM filecache) (invalidate filecache) (invalidateCache filecache) (keysCached filecache) (keysNotExpired filecache) - +{-# LANGUAGE OverloadedStrings #-} + +module TestHashECMWithTestSequenceInvalidating ( + testWithTestSequenceInvalidating +) where + +import Caching.ExpiringCacheMap.HashECM (newECMForM, lookupECM, CacheSettings(..), consistentDuration, invalidate, invalidateCache, keysCached, keysNotExpired) +import qualified Caching.ExpiringCacheMap.Utils.TestSequence as TestSeq + +import TestECMWithTestSequenceCommonInvalidating + +import qualified Data.ByteString.Char8 as BS +import System.Exit (exitFailure) + +testWithTestSequenceInvalidating = do + (TestSeq.TestSequenceState (_, events', _), return_value) <- TestSeq.runTestSequence test' + (TestSeq.TestSequenceState (_, events'', _), return_value) <- TestSeq.runTestSequence test'' + (TestSeq.TestSequenceState (_, events''', _), return_value) <- TestSeq.runTestSequence test''' + (TestSeq.TestSequenceState (_, events'''', _), return_value) <- TestSeq.runTestSequence test'''' + (TestSeq.TestSequenceState (_, events''''', _), return_value) <- TestSeq.runTestSequence test''''' + (TestSeq.TestSequenceState (_, events'''''', _), return_value) <- TestSeq.runTestSequence test'''''' + if pattern'I (filt events') && + pattern''I (filt events'') && + pattern'''I (filt events''') && + pattern''''I (filt events'''') && + pattern'''''I (filt events''''') && + pattern''''''I (filt events'''''') + then do + putStrLn "Passed TestHashECMWithTestSequenceInvalidating" + -- printOutEvents events' events'' events''' events'''' + return () + else do + printOutFailedPatternI "TestHashECMWithTestSequenceInvalidating.testWithTestSequenceInvalidating" + (filt events') (filt events'') (filt events''') (filt events'''') (filt events''''') (filt events'''''') + printOutEventsI events' events'' events''' events'''' events''''' events'''''' + exitFailure + where + filt = filter someEventsOnlyI . reverse + commonreadnumber = + (\state _id -> do number <- TestSeq.readNumber + return (state, number)) + + newTestECM valreq timecheck = + newECMForM valreq + (TestSeq.getCurrentTime >>= return) + timecheck + (CacheWithLRUList 6 6 12) + TestSeq.newTestSVar TestSeq.enterTestSVar TestSeq.readTestSVar + + test' = do + filecache <- newTestECM + (consistentDuration 100 commonreadnumber) -- Duration between access and expiry time + 12000 -- Time check frequency + testLookupsI (lookupECM filecache) (invalidate filecache) (invalidateCache filecache) (keysCached filecache) (keysNotExpired filecache) + + test'' = do + filecache <- newTestECM + (consistentDuration 100 commonreadnumber) -- Duration between access and expiry time + 1 -- Time check frequency + testLookupsI (lookupECM filecache) (invalidate filecache) (invalidateCache filecache) (keysCached filecache) (keysNotExpired filecache) + + test''' = do + filecache <- newTestECM + (consistentDuration 1 commonreadnumber) -- Duration between access and expiry time + 12000 -- Time check frequency + testLookupsI (lookupECM filecache) (invalidate filecache) (invalidateCache filecache) (keysCached filecache) (keysNotExpired filecache) + + test'''' = do + filecache <- newTestECM + (consistentDuration 1 commonreadnumber) -- Duration between access and expiry time + 1 -- Time check frequency + testLookupsI (lookupECM filecache) (invalidate filecache) (invalidateCache filecache) (keysCached filecache) (keysNotExpired filecache) + + test''''' = do + filecache <- newTestECM + (consistentDuration 50 commonreadnumber) -- Duration between access and expiry time + 12000 -- Time check frequency + testLookupsI (lookupECM filecache) (invalidate filecache) (invalidateCache filecache) (keysCached filecache) (keysNotExpired filecache) + + test'''''' = do + filecache <- newTestECM + (consistentDuration 50 commonreadnumber) -- Duration between access and expiry time + 1 -- Time check frequency + testLookupsI (lookupECM filecache) (invalidate filecache) (invalidateCache filecache) (keysCached filecache) (keysNotExpired filecache) + diff --git a/tests/TestHashECMWithThreadsInvalidating.hs b/tests/TestHashECMWithThreadsInvalidating.hs --- a/tests/TestHashECMWithThreadsInvalidating.hs +++ b/tests/TestHashECMWithThreadsInvalidating.hs @@ -1,118 +1,118 @@ -{-# LANGUAGE OverloadedStrings #-} - --- --- Test HashECM with threads --- - -module TestHashECMWithThreadsInvalidating ( - testWithThreadsInvalidating -) where - -import Control.Concurrent (forkIO, threadDelay, yield) -import qualified Data.Time.Clock.POSIX as POSIX (POSIXTime, getPOSIXTime) -import qualified Data.ByteString.Lazy.Char8 as LBS - -import qualified Control.Concurrent.MVar as MV -import qualified Data.HashMap.Strict as HM -import Data.Hashable (Hashable(..)) - -import Caching.ExpiringCacheMap.HashECM -import Caching.ExpiringCacheMap.Internal.Internal (getStatsString) - -import System.Timeout (timeout) -import System.Exit (exitFailure) - -testWithThreadsInvalidating = do - res <- timeout 60000000 testWithThreadsInvalidating' - case res of - Nothing -> exitFailure - Just () -> return () - -testWithThreadsInvalidating' = do - ecm <- newECMIO - (consistentDuration 10 - (\state id -> do LBS.putStrLn id; return (state, []))) - (do time <- POSIX.getPOSIXTime - return (round (time * 100))) - 120 - (CacheWithLRUList 6 6 12) :: IO (ECM IO MV.MVar () HM.HashMap LBS.ByteString [Int]) - t1 <- MV.newEmptyMVar - forkIO $ do - mapM_ (\a -> do - b <- lookupECM ecm "test.2" - yield - return ()) - [0..500] - MV.putMVar t1 True - t2 <- MV.newEmptyMVar - forkIO $ do - mapM_ (\a -> do - b <- lookupECM ecm "test.3" - yield - return ()) - [0..333] - MV.putMVar t2 True - t3 <- MV.newEmptyMVar - forkIO $ do - mapM_ (\a -> do - b <- invalidate ecm "test.2" - yield - return ()) - [0..200] - MV.putMVar t3 True - t4 <- MV.newEmptyMVar - forkIO $ do - mapM_ (\a -> do - b <- lookupECM ecm "test.7" - yield - return ()) - [0..142] - MV.putMVar t4 True - t5 <- MV.newEmptyMVar - forkIO $ do - mapM_ (\a -> do - b <- invalidate ecm "test.3" - yield - return ()) - [0..90] - MV.putMVar t5 True - t6 <- MV.newEmptyMVar - forkIO $ do - mapM_ (\a -> do - b <- lookupECM ecm "test.13" - yield - return ()) - [0..76] - MV.putMVar t6 True - t7 <- MV.newEmptyMVar - forkIO $ do - mapM_ (\a -> do - b <- invalidate ecm "test.7" - yield - return ()) - [0..58] - MV.putMVar t7 True - t8 <- MV.newEmptyMVar - forkIO $ do - mapM_ (\a -> do - b <- lookupECM ecm "test.19" - yield - return ()) - [0..52] - MV.putMVar t8 True - t9 <- MV.newEmptyMVar - forkIO $ do - mapM_ (\a -> do - b <- invalidate ecm "test.13" - yield - return ()) - [0..43] - MV.putMVar t9 True - untilDone [t1,t2,t3,t4,t5,t6,t7,t8,t9] - c <- getStatsString ecm - putStrLn c - return () - where - untilDone [] = return () - untilDone (t:tr) = MV.takeMVar t >> untilDone tr - +{-# LANGUAGE OverloadedStrings #-} + +-- +-- Test HashECM with threads +-- + +module TestHashECMWithThreadsInvalidating ( + testWithThreadsInvalidating +) where + +import Control.Concurrent (forkIO, threadDelay, yield) +import qualified Data.Time.Clock.POSIX as POSIX (POSIXTime, getPOSIXTime) +import qualified Data.ByteString.Lazy.Char8 as LBS + +import qualified Control.Concurrent.MVar as MV +import qualified Data.HashMap.Strict as HM +import Data.Hashable (Hashable(..)) + +import Caching.ExpiringCacheMap.HashECM +import Caching.ExpiringCacheMap.Internal.Internal (getStatsString) + +import System.Timeout (timeout) +import System.Exit (exitFailure) + +testWithThreadsInvalidating = do + res <- timeout 60000000 testWithThreadsInvalidating' + case res of + Nothing -> exitFailure + Just () -> return () + +testWithThreadsInvalidating' = do + ecm <- newECMIO + (consistentDuration 10 + (\state id -> do LBS.putStrLn id; return (state, []))) + (do time <- POSIX.getPOSIXTime + return (round (time * 100))) + 120 + (CacheWithLRUList 6 6 12) :: IO (ECM IO MV.MVar () HM.HashMap LBS.ByteString [Int]) + t1 <- MV.newEmptyMVar + forkIO $ do + mapM_ (\a -> do + b <- lookupECM ecm "test.2" + yield + return ()) + [0..500] + MV.putMVar t1 True + t2 <- MV.newEmptyMVar + forkIO $ do + mapM_ (\a -> do + b <- lookupECM ecm "test.3" + yield + return ()) + [0..333] + MV.putMVar t2 True + t3 <- MV.newEmptyMVar + forkIO $ do + mapM_ (\a -> do + b <- invalidate ecm "test.2" + yield + return ()) + [0..200] + MV.putMVar t3 True + t4 <- MV.newEmptyMVar + forkIO $ do + mapM_ (\a -> do + b <- lookupECM ecm "test.7" + yield + return ()) + [0..142] + MV.putMVar t4 True + t5 <- MV.newEmptyMVar + forkIO $ do + mapM_ (\a -> do + b <- invalidate ecm "test.3" + yield + return ()) + [0..90] + MV.putMVar t5 True + t6 <- MV.newEmptyMVar + forkIO $ do + mapM_ (\a -> do + b <- lookupECM ecm "test.13" + yield + return ()) + [0..76] + MV.putMVar t6 True + t7 <- MV.newEmptyMVar + forkIO $ do + mapM_ (\a -> do + b <- invalidate ecm "test.7" + yield + return ()) + [0..58] + MV.putMVar t7 True + t8 <- MV.newEmptyMVar + forkIO $ do + mapM_ (\a -> do + b <- lookupECM ecm "test.19" + yield + return ()) + [0..52] + MV.putMVar t8 True + t9 <- MV.newEmptyMVar + forkIO $ do + mapM_ (\a -> do + b <- invalidate ecm "test.13" + yield + return ()) + [0..43] + MV.putMVar t9 True + untilDone [t1,t2,t3,t4,t5,t6,t7,t8,t9] + c <- getStatsString ecm + putStrLn c + return () + where + untilDone [] = return () + untilDone (t:tr) = MV.takeMVar t >> untilDone tr + diff --git a/tests/TestOrdECMWithTestSequenceInvalidating.hs b/tests/TestOrdECMWithTestSequenceInvalidating.hs --- a/tests/TestOrdECMWithTestSequenceInvalidating.hs +++ b/tests/TestOrdECMWithTestSequenceInvalidating.hs @@ -1,84 +1,84 @@ -{-# LANGUAGE OverloadedStrings #-} - -module TestOrdECMWithTestSequenceInvalidating ( - testWithTestSequenceInvalidating -) where - -import Caching.ExpiringCacheMap.OrdECM (newECMForM, lookupECM, CacheSettings(..), consistentDuration, invalidate, invalidateCache, keysCached, keysNotExpired) -import qualified Caching.ExpiringCacheMap.Utils.TestSequence as TestSeq - -import TestECMWithTestSequenceCommonInvalidating - -import qualified Data.ByteString.Char8 as BS -import System.Exit (exitFailure) - -testWithTestSequenceInvalidating = do - (TestSeq.TestSequenceState (_, events', _), return_value) <- TestSeq.runTestSequence test' - (TestSeq.TestSequenceState (_, events'', _), return_value) <- TestSeq.runTestSequence test'' - (TestSeq.TestSequenceState (_, events''', _), return_value) <- TestSeq.runTestSequence test''' - (TestSeq.TestSequenceState (_, events'''', _), return_value) <- TestSeq.runTestSequence test'''' - (TestSeq.TestSequenceState (_, events''''', _), return_value) <- TestSeq.runTestSequence test''''' - (TestSeq.TestSequenceState (_, events'''''', _), return_value) <- TestSeq.runTestSequence test'''''' - if pattern'I (filt events') && - pattern''I (filt events'') && - pattern'''I (filt events''') && - pattern''''I (filt events'''') && - pattern'''''I (filt events''''') && - pattern''''''I (filt events'''''') - then do - putStrLn "Passed TestOrdECMWithTestSequenceInvalidating" - -- printOutEvents events' events'' events''' events'''' - return () - else do - printOutFailedPatternI "TestOrdECMWithTestSequenceInvalidating.testWithTestSequenceInvalidating" - (filt events') (filt events'') (filt events''') (filt events'''') (filt events''''') (filt events'''''') - printOutEventsI events' events'' events''' events'''' events''''' events'''''' - exitFailure - where - filt = filter someEventsOnlyI . reverse - commonreadnumber = - (\state _id -> do number <- TestSeq.readNumber - return (state, number)) - - newTestECM valreq timecheck = - newECMForM valreq - (TestSeq.getCurrentTime >>= return) - timecheck - (CacheWithLRUList 6 6 12) - TestSeq.newTestSVar TestSeq.enterTestSVar TestSeq.readTestSVar - - test' = do - filecache <- newTestECM - (consistentDuration 100 commonreadnumber) -- Duration between access and expiry time - 12000 -- Time check frequency - testLookupsI (lookupECM filecache) (invalidate filecache) (invalidateCache filecache) (keysCached filecache) (keysNotExpired filecache) - - test'' = do - filecache <- newTestECM - (consistentDuration 100 commonreadnumber) -- Duration between access and expiry time - 1 -- Time check frequency - testLookupsI (lookupECM filecache) (invalidate filecache) (invalidateCache filecache) (keysCached filecache) (keysNotExpired filecache) - - test''' = do - filecache <- newTestECM - (consistentDuration 1 commonreadnumber) -- Duration between access and expiry time - 12000 -- Time check frequency - testLookupsI (lookupECM filecache) (invalidate filecache) (invalidateCache filecache) (keysCached filecache) (keysNotExpired filecache) - - test'''' = do - filecache <- newTestECM - (consistentDuration 1 commonreadnumber) -- Duration between access and expiry time - 1 -- Time check frequency - testLookupsI (lookupECM filecache) (invalidate filecache) (invalidateCache filecache) (keysCached filecache) (keysNotExpired filecache) - - test''''' = do - filecache <- newTestECM - (consistentDuration 50 commonreadnumber) -- Duration between access and expiry time - 12000 -- Time check frequency - testLookupsI (lookupECM filecache) (invalidate filecache) (invalidateCache filecache) (keysCached filecache) (keysNotExpired filecache) - - test'''''' = do - filecache <- newTestECM - (consistentDuration 50 commonreadnumber) -- Duration between access and expiry time - 1 -- Time check frequency - testLookupsI (lookupECM filecache) (invalidate filecache) (invalidateCache filecache) (keysCached filecache) (keysNotExpired filecache) +{-# LANGUAGE OverloadedStrings #-} + +module TestOrdECMWithTestSequenceInvalidating ( + testWithTestSequenceInvalidating +) where + +import Caching.ExpiringCacheMap.OrdECM (newECMForM, lookupECM, CacheSettings(..), consistentDuration, invalidate, invalidateCache, keysCached, keysNotExpired) +import qualified Caching.ExpiringCacheMap.Utils.TestSequence as TestSeq + +import TestECMWithTestSequenceCommonInvalidating + +import qualified Data.ByteString.Char8 as BS +import System.Exit (exitFailure) + +testWithTestSequenceInvalidating = do + (TestSeq.TestSequenceState (_, events', _), return_value) <- TestSeq.runTestSequence test' + (TestSeq.TestSequenceState (_, events'', _), return_value) <- TestSeq.runTestSequence test'' + (TestSeq.TestSequenceState (_, events''', _), return_value) <- TestSeq.runTestSequence test''' + (TestSeq.TestSequenceState (_, events'''', _), return_value) <- TestSeq.runTestSequence test'''' + (TestSeq.TestSequenceState (_, events''''', _), return_value) <- TestSeq.runTestSequence test''''' + (TestSeq.TestSequenceState (_, events'''''', _), return_value) <- TestSeq.runTestSequence test'''''' + if pattern'I (filt events') && + pattern''I (filt events'') && + pattern'''I (filt events''') && + pattern''''I (filt events'''') && + pattern'''''I (filt events''''') && + pattern''''''I (filt events'''''') + then do + putStrLn "Passed TestOrdECMWithTestSequenceInvalidating" + -- printOutEvents events' events'' events''' events'''' + return () + else do + printOutFailedPatternI "TestOrdECMWithTestSequenceInvalidating.testWithTestSequenceInvalidating" + (filt events') (filt events'') (filt events''') (filt events'''') (filt events''''') (filt events'''''') + printOutEventsI events' events'' events''' events'''' events''''' events'''''' + exitFailure + where + filt = filter someEventsOnlyI . reverse + commonreadnumber = + (\state _id -> do number <- TestSeq.readNumber + return (state, number)) + + newTestECM valreq timecheck = + newECMForM valreq + (TestSeq.getCurrentTime >>= return) + timecheck + (CacheWithLRUList 6 6 12) + TestSeq.newTestSVar TestSeq.enterTestSVar TestSeq.readTestSVar + + test' = do + filecache <- newTestECM + (consistentDuration 100 commonreadnumber) -- Duration between access and expiry time + 12000 -- Time check frequency + testLookupsI (lookupECM filecache) (invalidate filecache) (invalidateCache filecache) (keysCached filecache) (keysNotExpired filecache) + + test'' = do + filecache <- newTestECM + (consistentDuration 100 commonreadnumber) -- Duration between access and expiry time + 1 -- Time check frequency + testLookupsI (lookupECM filecache) (invalidate filecache) (invalidateCache filecache) (keysCached filecache) (keysNotExpired filecache) + + test''' = do + filecache <- newTestECM + (consistentDuration 1 commonreadnumber) -- Duration between access and expiry time + 12000 -- Time check frequency + testLookupsI (lookupECM filecache) (invalidate filecache) (invalidateCache filecache) (keysCached filecache) (keysNotExpired filecache) + + test'''' = do + filecache <- newTestECM + (consistentDuration 1 commonreadnumber) -- Duration between access and expiry time + 1 -- Time check frequency + testLookupsI (lookupECM filecache) (invalidate filecache) (invalidateCache filecache) (keysCached filecache) (keysNotExpired filecache) + + test''''' = do + filecache <- newTestECM + (consistentDuration 50 commonreadnumber) -- Duration between access and expiry time + 12000 -- Time check frequency + testLookupsI (lookupECM filecache) (invalidate filecache) (invalidateCache filecache) (keysCached filecache) (keysNotExpired filecache) + + test'''''' = do + filecache <- newTestECM + (consistentDuration 50 commonreadnumber) -- Duration between access and expiry time + 1 -- Time check frequency + testLookupsI (lookupECM filecache) (invalidate filecache) (invalidateCache filecache) (keysCached filecache) (keysNotExpired filecache) diff --git a/tests/TestOrdECMWithThreadsInvalidating.hs b/tests/TestOrdECMWithThreadsInvalidating.hs --- a/tests/TestOrdECMWithThreadsInvalidating.hs +++ b/tests/TestOrdECMWithThreadsInvalidating.hs @@ -1,116 +1,116 @@ -{-# LANGUAGE OverloadedStrings #-} - --- --- Test OrdECM with threads --- - -module TestOrdECMWithThreadsInvalidating ( - testWithThreadsInvalidating -) where - -import Control.Concurrent (forkIO, threadDelay, yield) -import qualified Data.Time.Clock.POSIX as POSIX (POSIXTime, getPOSIXTime) -import qualified Data.ByteString.Lazy.Char8 as LBS - -import qualified Control.Concurrent.MVar as MV -import qualified Data.Map as M - -import Caching.ExpiringCacheMap.OrdECM -import Caching.ExpiringCacheMap.Internal.Internal (getStatsString) - -import System.Timeout (timeout) -import System.Exit (exitFailure) - -testWithThreadsInvalidating = do - res <- timeout 60000000 testWithThreadsInvalidating' - case res of - Nothing -> exitFailure - Just () -> return () - -testWithThreadsInvalidating' = do - ecm <- newECMIO - (consistentDuration 10 - (\state id -> do LBS.putStrLn id; return (state, []))) - (do time <- POSIX.getPOSIXTime - return (round (time * 100))) - 120 - (CacheWithLRUList 6 6 12 ) :: IO (ECM IO MV.MVar () M.Map LBS.ByteString [Int]) - t1 <- MV.newEmptyMVar - forkIO $ do - mapM_ (\a -> do - b <- lookupECM ecm "test.2" - yield - return ()) - [0..500] - MV.putMVar t1 True - t2 <- MV.newEmptyMVar - forkIO $ do - mapM_ (\a -> do - b <- lookupECM ecm "test.3" - yield - return ()) - [0..333] - MV.putMVar t2 True - t3 <- MV.newEmptyMVar - forkIO $ do - mapM_ (\a -> do - b <- invalidate ecm "test.2" - yield - return ()) - [0..200] - MV.putMVar t3 True - t4 <- MV.newEmptyMVar - forkIO $ do - mapM_ (\a -> do - b <- lookupECM ecm "test.7" - yield - return ()) - [0..142] - MV.putMVar t4 True - t5 <- MV.newEmptyMVar - forkIO $ do - mapM_ (\a -> do - b <- invalidate ecm "test.3" - yield - return ()) - [0..90] - MV.putMVar t5 True - t6 <- MV.newEmptyMVar - forkIO $ do - mapM_ (\a -> do - b <- lookupECM ecm "test.13" - yield - return ()) - [0..76] - MV.putMVar t6 True - t7 <- MV.newEmptyMVar - forkIO $ do - mapM_ (\a -> do - b <- invalidate ecm "test.7" - yield - return ()) - [0..58] - MV.putMVar t7 True - t8 <- MV.newEmptyMVar - forkIO $ do - mapM_ (\a -> do - b <- lookupECM ecm "test.19" - yield - return ()) - [0..52] - MV.putMVar t8 True - t9 <- MV.newEmptyMVar - forkIO $ do - mapM_ (\a -> do - b <- invalidate ecm "test.13" - yield - return ()) - [0..43] - MV.putMVar t9 True - untilDone [t1,t2,t3,t4,t5,t6,t7,t8,t9] - c <- getStatsString ecm - putStrLn c - return () - where - untilDone [] = return () - untilDone (t:tr) = MV.takeMVar t >> untilDone tr +{-# LANGUAGE OverloadedStrings #-} + +-- +-- Test OrdECM with threads +-- + +module TestOrdECMWithThreadsInvalidating ( + testWithThreadsInvalidating +) where + +import Control.Concurrent (forkIO, threadDelay, yield) +import qualified Data.Time.Clock.POSIX as POSIX (POSIXTime, getPOSIXTime) +import qualified Data.ByteString.Lazy.Char8 as LBS + +import qualified Control.Concurrent.MVar as MV +import qualified Data.Map as M + +import Caching.ExpiringCacheMap.OrdECM +import Caching.ExpiringCacheMap.Internal.Internal (getStatsString) + +import System.Timeout (timeout) +import System.Exit (exitFailure) + +testWithThreadsInvalidating = do + res <- timeout 60000000 testWithThreadsInvalidating' + case res of + Nothing -> exitFailure + Just () -> return () + +testWithThreadsInvalidating' = do + ecm <- newECMIO + (consistentDuration 10 + (\state id -> do LBS.putStrLn id; return (state, []))) + (do time <- POSIX.getPOSIXTime + return (round (time * 100))) + 120 + (CacheWithLRUList 6 6 12 ) :: IO (ECM IO MV.MVar () M.Map LBS.ByteString [Int]) + t1 <- MV.newEmptyMVar + forkIO $ do + mapM_ (\a -> do + b <- lookupECM ecm "test.2" + yield + return ()) + [0..500] + MV.putMVar t1 True + t2 <- MV.newEmptyMVar + forkIO $ do + mapM_ (\a -> do + b <- lookupECM ecm "test.3" + yield + return ()) + [0..333] + MV.putMVar t2 True + t3 <- MV.newEmptyMVar + forkIO $ do + mapM_ (\a -> do + b <- invalidate ecm "test.2" + yield + return ()) + [0..200] + MV.putMVar t3 True + t4 <- MV.newEmptyMVar + forkIO $ do + mapM_ (\a -> do + b <- lookupECM ecm "test.7" + yield + return ()) + [0..142] + MV.putMVar t4 True + t5 <- MV.newEmptyMVar + forkIO $ do + mapM_ (\a -> do + b <- invalidate ecm "test.3" + yield + return ()) + [0..90] + MV.putMVar t5 True + t6 <- MV.newEmptyMVar + forkIO $ do + mapM_ (\a -> do + b <- lookupECM ecm "test.13" + yield + return ()) + [0..76] + MV.putMVar t6 True + t7 <- MV.newEmptyMVar + forkIO $ do + mapM_ (\a -> do + b <- invalidate ecm "test.7" + yield + return ()) + [0..58] + MV.putMVar t7 True + t8 <- MV.newEmptyMVar + forkIO $ do + mapM_ (\a -> do + b <- lookupECM ecm "test.19" + yield + return ()) + [0..52] + MV.putMVar t8 True + t9 <- MV.newEmptyMVar + forkIO $ do + mapM_ (\a -> do + b <- invalidate ecm "test.13" + yield + return ()) + [0..43] + MV.putMVar t9 True + untilDone [t1,t2,t3,t4,t5,t6,t7,t8,t9] + c <- getStatsString ecm + putStrLn c + return () + where + untilDone [] = return () + untilDone (t:tr) = MV.takeMVar t >> untilDone tr