expiring-cache-map 0.0.6.0 → 0.0.6.1
raw patch · 16 files changed
+2235/−1896 lines, 16 filesdep ~basePVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependency ranges changed: base
API changes (from Hackage documentation)
- Caching.ExpiringCacheMap.Internal.Internal: getStatsString :: (Show t3, Monad m) => ECM m t t1 t2 t3 t4 -> m String
+ Caching.ExpiringCacheMap.Internal.Internal: getStatsString :: (Show t1, Monad m) => ECM m t4 t3 t2 t1 t -> m String
Files
- Caching/ExpiringCacheMap/HashECM.hs +375/−370
- Caching/ExpiringCacheMap/OrdECM.hs +371/−366
- expiring-cache-map.cabal +108/−74
- tests/InvalidateCacheTest.hs +11/−0
- tests/InvalidateCacheTestCommon.hs +59/−0
- tests/InvalidateCacheTestHashECM.hs +27/−0
- tests/InvalidateCacheTestOrdECM.hs +27/−0
- tests/InvalidateTest.hs +11/−0
- tests/InvalidateTestCommon.hs +60/−0
- tests/InvalidateTestHashECM.hs +50/−0
- tests/InvalidateTestOrdECM.hs +50/−0
- tests/TestECMWithTestSequenceCommonInvalidating.hs +683/−683
- tests/TestHashECMWithTestSequenceInvalidating.hs +85/−85
- tests/TestHashECMWithThreadsInvalidating.hs +118/−118
- tests/TestOrdECMWithTestSequenceInvalidating.hs +84/−84
- tests/TestOrdECMWithThreadsInvalidating.hs +116/−116
Caching/ExpiringCacheMap/HashECM.hs view
@@ -1,370 +1,375 @@-{-# LANGUAGE OverloadedStrings #-} --- | --- Module : Caching.ExpiringCacheMap.HashECM --- Copyright: (c) 2014 Edward L. Blake --- License: BSD-style --- Maintainer: Edward L. Blake <edwardlblake@gmail.com> --- Stability: experimental --- Portability: portable --- --- A cache that holds values for a length of time that uses '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 <edwardlblake@gmail.com>+-- 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)+
Caching/ExpiringCacheMap/OrdECM.hs view
@@ -1,366 +1,371 @@-{-# LANGUAGE OverloadedStrings #-} --- | --- Module : Caching.ExpiringCacheMap.OrdECM --- Copyright: (c) 2014 Edward L. Blake --- License: BSD-style --- Maintainer: Edward L. Blake <edwardlblake@gmail.com> --- Stability: experimental --- Portability: portable --- --- A cache that holds values for a length of time that uses 'Ord' keys with --- "Data.Map.Strict". --- --- An example of creating a cache for accessing files: --- --- > {-# LANGUAGE OverloadedStrings #-} --- > --- > import Caching.ExpiringCacheMap.OrdECM (newECMIO, lookupECM, CacheSettings(..), consistentDuration) --- > --- > import qualified Data.Time.Clock.POSIX as POSIX (POSIXTime, getPOSIXTime) --- > import qualified Data.ByteString.Char8 as BS --- > import System.IO (withFile, IOMode(ReadMode)) --- > --- > example = do --- > filecache <- newECMIO --- > (consistentDuration 100 -- Duration between access and expiry time of each item --- > (\state id -> do BS.putStrLn "Reading a file again..." --- > withFile (case id :: BS.ByteString of --- > "file1" -> "file1.txt" --- > "file2" -> "file2.txt") --- > ReadMode $ --- > \fh -> do content <- BS.hGetContents fh --- > return $! (state, content))) --- > (do time <- POSIX.getPOSIXTime --- > return (round (time * 100))) --- > 1 -- Time check frequency: (accumulator `mod` this_number) == 0. --- > (CacheWithLRUList --- > 6 -- Expected size of key-value map when removing elements. --- > 6 -- Size of map when to remove items from key-value map. --- > 12 -- Size of list when to compact --- > ) --- > --- > -- Use lookupECM whenever the contents of "file1" is needed. --- > b <- lookupECM filecache "file1" --- > BS.putStrLn b --- > return () --- > --- - -module Caching.ExpiringCacheMap.OrdECM ( - -- * Create cache - newECMIO, - newECMForM, - consistentDuration, - - -- * Request value from cache - lookupECM, - - -- * Value request function state - 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 <edwardlblake@gmail.com>+-- Stability: experimental+-- Portability: portable+--+-- A cache that holds values for a length of time that uses 'Ord' keys with +-- "Data.Map.Strict".+-- +-- An example of creating a cache for accessing files:+--+-- > {-# LANGUAGE OverloadedStrings #-}+-- > +-- > import Caching.ExpiringCacheMap.OrdECM (newECMIO, lookupECM, CacheSettings(..), consistentDuration)+-- > +-- > import qualified Data.Time.Clock.POSIX as POSIX (POSIXTime, getPOSIXTime)+-- > import qualified Data.ByteString.Char8 as BS+-- > import System.IO (withFile, IOMode(ReadMode))+-- > +-- > example = do+-- > filecache <- newECMIO+-- > (consistentDuration 100 -- Duration between access and expiry time of each item+-- > (\state id -> do BS.putStrLn "Reading a file again..."+-- > withFile (case id :: BS.ByteString of+-- > "file1" -> "file1.txt"+-- > "file2" -> "file2.txt")+-- > ReadMode $+-- > \fh -> do content <- BS.hGetContents fh+-- > return $! (state, content)))+-- > (do time <- POSIX.getPOSIXTime+-- > return (round (time * 100)))+-- > 1 -- Time check frequency: (accumulator `mod` this_number) == 0.+-- > (CacheWithLRUList+-- > 6 -- Expected size of key-value map when removing elements.+-- > 6 -- Size of map when to remove items from key-value map.+-- > 12 -- Size of list when to compact+-- > )+-- > +-- > -- Use lookupECM whenever the contents of "file1" is needed.+-- > b <- lookupECM filecache "file1"+-- > BS.putStrLn b+-- > return ()+-- > +--++module Caching.ExpiringCacheMap.OrdECM (+ -- * Create cache+ newECMIO,+ newECMForM,+ consistentDuration,+ + -- * Request value from cache+ lookupECM,+ + -- * Value request function state+ 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)+
expiring-cache-map.cabal view
@@ -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
+ tests/InvalidateCacheTest.hs view
@@ -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
+ tests/InvalidateCacheTestCommon.hs view
@@ -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"
+ tests/InvalidateCacheTestHashECM.hs view
@@ -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 ()
+ tests/InvalidateCacheTestOrdECM.hs view
@@ -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 ()
+ tests/InvalidateTest.hs view
@@ -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
+ tests/InvalidateTestCommon.hs view
@@ -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"
+ tests/InvalidateTestHashECM.hs view
@@ -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 ()
+ tests/InvalidateTestOrdECM.hs view
@@ -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 ()
tests/TestECMWithTestSequenceCommonInvalidating.hs view
@@ -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
tests/TestHashECMWithTestSequenceInvalidating.hs view
@@ -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) +
tests/TestHashECMWithThreadsInvalidating.hs view
@@ -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 +
tests/TestOrdECMWithTestSequenceInvalidating.hs view
@@ -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)
tests/TestOrdECMWithThreadsInvalidating.hs view
@@ -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