expiring-cache-map-0.0.6.1/0000755000000000000000000000000012752752732013517 5ustar0000000000000000expiring-cache-map-0.0.6.1/Setup.hs0000644000000000000000000000006012752752732015147 0ustar0000000000000000import Distribution.Simple main = defaultMain expiring-cache-map-0.0.6.1/README.md0000644000000000000000000000037012752752732014776 0ustar0000000000000000 expiring-cache-map ================== A general purpose simple 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. expiring-cache-map-0.0.6.1/LICENSE0000644000000000000000000000302612752752732014525 0ustar0000000000000000Copyright (c) 2014, Edward L. Blake All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of Edward L. Blake nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. expiring-cache-map-0.0.6.1/expiring-cache-map.cabal0000644000000000000000000000631512752752732020151 0ustar0000000000000000name: 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 expiring-cache-map-0.0.6.1/tests/0000755000000000000000000000000012752752732014661 5ustar0000000000000000expiring-cache-map-0.0.6.1/tests/TestWithThreads.hs0000644000000000000000000000077512752752732020314 0ustar0000000000000000-- -- Test with threads -- import qualified TestOrdECMWithThreads as OrdTest import qualified TestHashECMWithThreads as HashTest import qualified TestOrdECMWithThreadsInvalidating as OrdTestInvalidating import qualified TestHashECMWithThreadsInvalidating as HashTestInvalidating testWithThreads = do HashTest.testWithThreads OrdTest.testWithThreads HashTestInvalidating.testWithThreadsInvalidating OrdTestInvalidating.testWithThreadsInvalidating return () main = testWithThreads expiring-cache-map-0.0.6.1/tests/TestWithTestSequence.hs0000644000000000000000000000074212752752732021324 0ustar0000000000000000 import qualified TestOrdECMWithTestSequence as OrdTest import qualified TestHashECMWithTestSequence as HashTest import qualified TestOrdECMWithTestSequenceInvalidating as OrdTestInvalidating import qualified TestHashECMWithTestSequenceInvalidating as HashTestInvalidating main = do HashTest.testWithTestSequence OrdTest.testWithTestSequence HashTestInvalidating.testWithTestSequenceInvalidating OrdTestInvalidating.testWithTestSequenceInvalidating return () expiring-cache-map-0.0.6.1/tests/TestOrdECMWithThreadsInvalidating.hs0000644000000000000000000000541212752752732023631 0ustar0000000000000000{-# 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 expiring-cache-map-0.0.6.1/tests/TestOrdECMWithThreads.hs0000644000000000000000000000555212752752732021304 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} -- -- Test OrdECM with threads -- module TestOrdECMWithThreads ( testWithThreads ) 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) testWithThreads = do res <- timeout 60000000 testWithThreads' case res of Nothing -> exitFailure Just () -> return () testWithThreads' = 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 -- threadDelay 2 return ()) [0..500] MV.putMVar t1 True t2 <- MV.newEmptyMVar forkIO $ do mapM_ (\a -> do b <- lookupECM ecm "test.3" yield -- threadDelay 3 return ()) [0..333] MV.putMVar t2 True t3 <- MV.newEmptyMVar forkIO $ do mapM_ (\a -> do b <- lookupECM ecm "test.5" yield -- threadDelay 5 return ()) [0..200] MV.putMVar t3 True t4 <- MV.newEmptyMVar forkIO $ do mapM_ (\a -> do b <- lookupECM ecm "test.7" yield -- threadDelay 7 return ()) [0..142] MV.putMVar t4 True t5 <- MV.newEmptyMVar forkIO $ do mapM_ (\a -> do b <- lookupECM ecm "test.11" yield -- threadDelay 11 return ()) [0..90] MV.putMVar t5 True t6 <- MV.newEmptyMVar forkIO $ do mapM_ (\a -> do b <- lookupECM ecm "test.13" yield -- threadDelay 13 return ()) [0..76] MV.putMVar t6 True t7 <- MV.newEmptyMVar forkIO $ do mapM_ (\a -> do b <- lookupECM ecm "test.17" yield -- threadDelay 17 return ()) [0..58] MV.putMVar t7 True t8 <- MV.newEmptyMVar forkIO $ do mapM_ (\a -> do b <- lookupECM ecm "test.19" yield -- threadDelay 19 return ()) [0..52] MV.putMVar t8 True t9 <- MV.newEmptyMVar forkIO $ do mapM_ (\a -> do b <- lookupECM ecm "test.23" yield -- threadDelay 23 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 expiring-cache-map-0.0.6.1/tests/TestOrdECMWithTestSequenceInvalidating.hs0000644000000000000000000001024212752752732024644 0ustar0000000000000000{-# 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) expiring-cache-map-0.0.6.1/tests/TestOrdECMWithTestSequence.hs0000644000000000000000000000524312752752732022317 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module TestOrdECMWithTestSequence ( testWithTestSequence ) where import Caching.ExpiringCacheMap.OrdECM (newECMForM, lookupECM, CacheSettings(..), consistentDuration) import qualified Caching.ExpiringCacheMap.Utils.TestSequence as TestSeq import TestECMWithTestSequenceCommon import qualified Data.ByteString.Char8 as BS import System.Exit (exitFailure) testWithTestSequence = 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'''' if pattern' (filt events') && pattern'' (filt events'') && pattern''' (filt events''') && pattern'''' (filt events'''') then do putStrLn "Passed TestOrdECMWithTestSequence" -- printOutEvents events' events'' events''' events'''' return () else do printOutFailedPattern "TestOrdECMWithTestSequence.testWithTestSequence" (filt events') (filt events'') (filt events''') (filt events'''') printOutEvents events' events'' events''' events'''' exitFailure where filt = filter someEventsOnly . 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 testLookups (lookupECM filecache) test'' = do filecache <- newTestECM (consistentDuration 100 commonreadnumber) -- Duration between access and expiry time 1 -- Time check frequency testLookups (lookupECM filecache) test''' = do filecache <- newTestECM (consistentDuration 1 commonreadnumber) -- Duration between access and expiry time 12000 -- Time check frequency testLookups (lookupECM filecache) test'''' = do filecache <- newTestECM (consistentDuration 1 commonreadnumber) -- Duration between access and expiry time 1 -- Time check frequency testLookups (lookupECM filecache) -- main = testWithTestSequence expiring-cache-map-0.0.6.1/tests/TestHashECMWithThreadsInvalidating.hs0000644000000000000000000000551312752752732023772 0ustar0000000000000000{-# 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 expiring-cache-map-0.0.6.1/tests/TestHashECMWithThreads.hs0000644000000000000000000000565112752752732021443 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} -- -- Test HashECM with threads -- module TestHashECMWithThreads ( testWithThreads ) 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) testWithThreads = do res <- timeout 60000000 testWithThreads' case res of Nothing -> exitFailure Just () -> return () testWithThreads' = 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 --threadDelay 2 return ()) [0..500] MV.putMVar t1 True t2 <- MV.newEmptyMVar forkIO $ do mapM_ (\a -> do b <- lookupECM ecm "test.3" yield --threadDelay 3 return ()) [0..333] MV.putMVar t2 True t3 <- MV.newEmptyMVar forkIO $ do mapM_ (\a -> do b <- lookupECM ecm "test.5" yield -- threadDelay 5 return ()) [0..200] MV.putMVar t3 True t4 <- MV.newEmptyMVar forkIO $ do mapM_ (\a -> do b <- lookupECM ecm "test.7" yield -- threadDelay 7 return ()) [0..142] MV.putMVar t4 True t5 <- MV.newEmptyMVar forkIO $ do mapM_ (\a -> do b <- lookupECM ecm "test.11" yield -- threadDelay 11 return ()) [0..90] MV.putMVar t5 True t6 <- MV.newEmptyMVar forkIO $ do mapM_ (\a -> do b <- lookupECM ecm "test.13" yield -- threadDelay 13 return ()) [0..76] MV.putMVar t6 True t7 <- MV.newEmptyMVar forkIO $ do mapM_ (\a -> do b <- lookupECM ecm "test.17" yield -- threadDelay 17 return ()) [0..58] MV.putMVar t7 True t8 <- MV.newEmptyMVar forkIO $ do mapM_ (\a -> do b <- lookupECM ecm "test.19" yield -- threadDelay 19 return ()) [0..52] MV.putMVar t8 True t9 <- MV.newEmptyMVar forkIO $ do mapM_ (\a -> do b <- lookupECM ecm "test.23" yield -- threadDelay 23 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 expiring-cache-map-0.0.6.1/tests/TestHashECMWithTestSequenceInvalidating.hs0000644000000000000000000001026712752752732025012 0ustar0000000000000000{-# 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) expiring-cache-map-0.0.6.1/tests/TestHashECMWithTestSequence.hs0000644000000000000000000000527012752752732022456 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module TestHashECMWithTestSequence ( testWithTestSequence ) where import Caching.ExpiringCacheMap.HashECM (newECMForM, lookupECM, CacheSettings(..), consistentDuration) import qualified Caching.ExpiringCacheMap.Utils.TestSequence as TestSeq import TestECMWithTestSequenceCommon import qualified Data.ByteString.Char8 as BS import System.Exit (exitFailure) testWithTestSequence = 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'''' if pattern' (filt events') && pattern'' (filt events'') && pattern''' (filt events''') && pattern'''' (filt events'''') then do putStrLn "Passed TestHashECMWithTestSequence" -- printOutEvents events' events'' events''' events'''' return () else do printOutFailedPattern "TestHashECMWithTestSequence.testWithTestSequence" (filt events') (filt events'') (filt events''') (filt events'''') printOutEvents events' events'' events''' events'''' exitFailure where filt = filter someEventsOnly . 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 testLookups (lookupECM filecache) test'' = do filecache <- newTestECM (consistentDuration 100 commonreadnumber) -- Duration between access and expiry time 1 -- Time check frequency testLookups (lookupECM filecache) test''' = do filecache <- newTestECM (consistentDuration 1 commonreadnumber) -- Duration between access and expiry time 12000 -- Time check frequency testLookups (lookupECM filecache) test'''' = do filecache <- newTestECM (consistentDuration 1 commonreadnumber) -- Duration between access and expiry time 1 -- Time check frequency testLookups (lookupECM filecache) -- main = testWithTestSequence expiring-cache-map-0.0.6.1/tests/TestECMWithTestSequenceCommonInvalidating.hs0000644000000000000000000005643312752752732025364 0ustar0000000000000000{-# 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 expiring-cache-map-0.0.6.1/tests/TestECMWithTestSequenceCommon.hs0000644000000000000000000000642612752752732023027 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module TestECMWithTestSequenceCommon ( someEventsOnly, numberEventsOnly, pattern', pattern'', pattern''', pattern'''', testLookups, printOutEvents, printOutFailedPattern ) where import qualified Caching.ExpiringCacheMap.Utils.TestSequence as TestSeq import qualified Data.ByteString.Char8 as BS printOutFailedPattern from_where filt_events' filt_events'' filt_events''' filt_events'''' = do putStrLn $ "Failed sequence test in " ++ from_where ++ ":" if not (pattern' (filt_events')) then putStrLn $ "Failed: pattern 1: " ++ (show filt_events') else return () if not (pattern'' (filt_events'')) then putStrLn $ "Failed: pattern 2: " ++ (show filt_events'') else return () if not (pattern''' (filt_events''')) then putStrLn $ "Failed: pattern 3: " ++ (show filt_events''') else return () if not (pattern'''' (filt_events'''')) then putStrLn $ "Failed: pattern 4: " ++ (show filt_events'''') else return () return () printOutEvents events' events'' events''' events'''' = do (putStrLn . show . filter someEventsOnly . reverse) events' (putStrLn . show . filter someEventsOnly . reverse) events'' (putStrLn . show . filter someEventsOnly . reverse) events''' (putStrLn . show . filter someEventsOnly . reverse) events'''' return () someEventsOnly a = case a of TestSeq.GetTime _ -> True TestSeq.ReadNumber _ -> True TestSeq.HaveNumber _ -> True _ -> False numberEventsOnly a = case a of TestSeq.ReadNumber _ -> True TestSeq.HaveNumber _ -> True _ -> False pattern' c = case c of [ TestSeq.ReadNumber numr1, TestSeq.GetTime _, TestSeq.HaveNumber numh1, TestSeq.HaveNumber numh1', TestSeq.ReadNumber numr2, TestSeq.GetTime _, TestSeq.HaveNumber numh2 ] | numr1 == numh1 && numr1 == numh1' && numr2 == numh2 -> True _ -> False pattern'' c = case c of [ TestSeq.ReadNumber numr1, TestSeq.GetTime _, TestSeq.HaveNumber numh1, TestSeq.GetTime _, TestSeq.GetTime _, TestSeq.HaveNumber numh1', TestSeq.ReadNumber numr2, TestSeq.GetTime _, TestSeq.HaveNumber numh2 ] | numr1 == numh1 && numr1 == numh1' && numr2 == numh2 -> True _ -> False pattern''' c = case c of [ TestSeq.ReadNumber numr1, TestSeq.GetTime _, TestSeq.HaveNumber numh1, TestSeq.HaveNumber numh1', TestSeq.ReadNumber numr2, TestSeq.GetTime _, TestSeq.HaveNumber numh2 ] | numr1 == numh1 && numr1 == numh1' && numr2 == numh2 -> True _ -> False pattern'''' c = case c of [ TestSeq.ReadNumber numr1, TestSeq.GetTime _, TestSeq.HaveNumber numh1, TestSeq.GetTime _, TestSeq.ReadNumber numr2, TestSeq.GetTime _, TestSeq.HaveNumber numh2, TestSeq.ReadNumber numr3, TestSeq.GetTime _, TestSeq.HaveNumber numh3 ] | numr1 == numh1 && numr2 == numh2 && numr3 == numh3 -> True _ -> False testLookups lookup = do b <- lookup ("file1" :: BS.ByteString) TestSeq.haveNumber b b <- lookup "file1" TestSeq.haveNumber b b <- lookup "file2" TestSeq.haveNumber b return b expiring-cache-map-0.0.6.1/tests/InvalidateTestOrdECM.hs0000644000000000000000000000365412752752732021137 0ustar0000000000000000{-# 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 () expiring-cache-map-0.0.6.1/tests/InvalidateTestHashECM.hs0000644000000000000000000000365712752752732021301 0ustar0000000000000000{-# 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 () expiring-cache-map-0.0.6.1/tests/InvalidateTestCommon.hs0000644000000000000000000000236412752752732021313 0ustar0000000000000000{-# 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" expiring-cache-map-0.0.6.1/tests/InvalidateTest.hs0000644000000000000000000000033212752752732020133 0ustar0000000000000000 import qualified InvalidateTestHashECM as TestHashECM (tests) import qualified InvalidateTestOrdECM as TestOrdECM (tests) invalidateTest = do TestHashECM.tests TestOrdECM.tests return () main = invalidateTestexpiring-cache-map-0.0.6.1/tests/InvalidateCacheTestOrdECM.hs0000644000000000000000000000203612752752732022054 0ustar0000000000000000{-# 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 () expiring-cache-map-0.0.6.1/tests/InvalidateCacheTestHashECM.hs0000644000000000000000000000203712752752732022214 0ustar0000000000000000{-# 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 () expiring-cache-map-0.0.6.1/tests/InvalidateCacheTestCommon.hs0000644000000000000000000000257312752752732022241 0ustar0000000000000000{-# 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" expiring-cache-map-0.0.6.1/tests/InvalidateCacheTest.hs0000644000000000000000000000037212752752732021063 0ustar0000000000000000 import qualified InvalidateCacheTestHashECM as TestHashECM (tests) import qualified InvalidateCacheTestOrdECM as TestOrdECM (tests) invalidateCacheTests = do TestHashECM.tests TestOrdECM.tests return () main = invalidateCacheTestsexpiring-cache-map-0.0.6.1/Caching/0000755000000000000000000000000012752752732015053 5ustar0000000000000000expiring-cache-map-0.0.6.1/Caching/ExpiringCacheMap/0000755000000000000000000000000012752752732020222 5ustar0000000000000000expiring-cache-map-0.0.6.1/Caching/ExpiringCacheMap/Types.hs0000644000000000000000000000325512752752732021667 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} -- | -- Module : Caching.ExpiringCacheMap.Types -- Copyright: (c) 2014 Edward L. Blake -- License: BSD-style -- Maintainer: Edward L. Blake -- Stability: experimental -- Portability: portable -- -- Types common to "Caching.ExpiringCacheMap.OrdECM" and "Caching.ExpiringCacheMap.HashECM". -- module Caching.ExpiringCacheMap.Types ( -- * Configuration CacheSettings(..), -- * Cache encapsulation ECM, CacheState, -- * Types TimeUnits, ECMMapSize, ECMULength, ECMIncr, -- * Types for state function ECMNewState, ECMEnterState, ECMReadState, ) where import Caching.ExpiringCacheMap.Utils.Types import Caching.ExpiringCacheMap.Internal.Types data CacheSettings = -- | A cache that maintains a key access history list to perform removals -- of /least recently used/ entries. Once the key-value map reaches -- 'removalsize' keys, then a list of keys to keep in the map is determined -- which is no larger than 'mapsize' size. Entries are removed only on -- insertion of a new entry in the key-value map. -- -- Key access history entries are prepended to the head of the LRU list, -- if an existing entry for the key appears close to the head of the list -- it is moved to the head of the list, instead of growing the list. When the -- LRU list reaches 'compactlistsize' items, it is compacted by removing -- duplicate keys, by keeping only the most recent accumulator value for -- that key. -- CacheWithLRUList { mapsize :: ECMMapSize, removalsize :: ECMMapSize, compactlistsize :: ECMULength } expiring-cache-map-0.0.6.1/Caching/ExpiringCacheMap/OrdECM.hs0000644000000000000000000003504712752752732021640 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} -- | -- Module : Caching.ExpiringCacheMap.OrdECM -- Copyright: (c) 2014 Edward L. Blake -- License: BSD-style -- Maintainer: Edward L. Blake -- Stability: experimental -- Portability: portable -- -- A cache that holds values for a length of time that uses 'Ord' keys with -- "Data.Map.Strict". -- -- An example of creating a cache for accessing files: -- -- > {-# LANGUAGE OverloadedStrings #-} -- > -- > import Caching.ExpiringCacheMap.OrdECM (newECMIO, lookupECM, CacheSettings(..), consistentDuration) -- > -- > import qualified Data.Time.Clock.POSIX as POSIX (POSIXTime, getPOSIXTime) -- > import qualified Data.ByteString.Char8 as BS -- > import System.IO (withFile, IOMode(ReadMode)) -- > -- > example = do -- > filecache <- newECMIO -- > (consistentDuration 100 -- Duration between access and expiry time of each item -- > (\state id -> do BS.putStrLn "Reading a file again..." -- > withFile (case id :: BS.ByteString of -- > "file1" -> "file1.txt" -- > "file2" -> "file2.txt") -- > ReadMode $ -- > \fh -> do content <- BS.hGetContents fh -- > return $! (state, content))) -- > (do time <- POSIX.getPOSIXTime -- > return (round (time * 100))) -- > 1 -- Time check frequency: (accumulator `mod` this_number) == 0. -- > (CacheWithLRUList -- > 6 -- Expected size of key-value map when removing elements. -- > 6 -- Size of map when to remove items from key-value map. -- > 12 -- Size of list when to compact -- > ) -- > -- > -- Use lookupECM whenever the contents of "file1" is needed. -- > b <- lookupECM filecache "file1" -- > BS.putStrLn b -- > return () -- > -- module Caching.ExpiringCacheMap.OrdECM ( -- * Create cache newECMIO, newECMForM, consistentDuration, -- * Request value from cache lookupECM, -- * Value request function state getValReqState, -- * Invalidate cache invalidate, invalidateCache, -- * List keys keysCached, keysNotExpired, -- * Type ECM, CacheSettings(..) ) where import qualified Control.Concurrent.MVar as MV import qualified Data.Map.Strict as M import qualified Data.List as L import Caching.ExpiringCacheMap.Internal.Internal (updateUses, detECM, detNotExpired) import Caching.ExpiringCacheMap.Types import Caching.ExpiringCacheMap.Internal.Types -- | Create a new expiring cache for retrieving uncached values via 'IO' -- interaction (such as in the case of reading a file from disk), with -- a shared state lock via an 'MV.MVar' to manage cache state. -- -- Value request and time check request functions are provided as arguments. -- -- The time check frequency value has to be 1 or higher, with higher values -- postponing time checks for longer periods of time. -- -- A cache setting specifies how the cache should remove entries when the -- cache becomes a certain size. The only constructor for this is -- 'CacheWithLRUList'. -- newECMIO :: Ord k => (Maybe s -> k -> IO (TimeUnits, (Maybe s, v))) -> (IO TimeUnits) -> ECMIncr -> CacheSettings -> IO (ECM IO MV.MVar s M.Map k v) newECMIO retr gettime timecheckmodulo settings = do newECMForM retr gettime timecheckmodulo settings MV.newMVar MV.modifyMVar MV.readMVar -- | Create a new expiring cache along arbitrary monads with provided -- functions to create cache state in 'Monad' m2, and modify and read -- cache state in 'Monad' m1. -- -- 'newECMIO' is just a wrapper to this function with 'MV.MVar' functions: -- -- @ -- newECMIO retr gettime timecheckmodulo cachesettings = -- newECMForM retr gettime timecheckmodulo cachesettings -- 'MV.newMVar' 'MV.modifyMVar' 'MV.readMVar' -- @ -- -- Value request and time check request functions are provided as arguments. -- -- The time check frequency value has to be 1 or higher, with higher values -- postponing time checks for longer periods of time. -- -- A cache setting specifies how the cache should remove entries when the -- cache becomes a certain size. The only constructor for this is -- 'CacheWithLRUList'. -- newECMForM :: (Monad m1, Monad m2) => Ord k => (Maybe s -> k -> m1 (TimeUnits, (Maybe s, v))) -> (m1 TimeUnits) -> ECMIncr -> CacheSettings -> ECMNewState m2 mv s M.Map k v -> ECMEnterState m1 mv s M.Map k v -> ECMReadState m1 mv s M.Map k v -> m2 (ECM m1 mv s M.Map k v) newECMForM retr gettime timecheckmodulo (CacheWithLRUList minimumkeep removalsize compactlistsize) newstate enterstate readstate = if timecheckmodulo <= 0 then error "Modulo time check must be 1 or higher." else do m'maps <- newstate $ CacheState ( Nothing, M.empty, 0, ([], 0), 0 ) return $ ECM ( m'maps, retr, gettime, minimumkeep, timecheckmodulo, removalsize, compactlistsize, enterstate, readstate ) -- | Request a value associated with a key from the cache. -- -- * If the value is not in the cache, it will be requested through the -- function defined through 'newECM', its computation returned and the -- value stored in the cache state map. -- -- * If the value is in the cache and has not expired, it will be returned. -- -- * If the value is in the cache and a new time is computed in the same -- lookup, and the value has been determined to have since expired, it -- will be discarded and a new value will be requested for this computation. -- -- Every 'lookupECM' computation increments an accumulator in the cache state -- which is used to keep track of the succession of key accesses. Based on the -- parameters provided with the 'CacheWithLRUList' constructor, this history -- of key accesses is then used to remove entries from the cache back down to -- a minimum size. Also, when the modulo of the accumulator and the modulo -- value computes to 0, the time request function is invoked. In some cases -- the accumulator may get incremented more than once in a 'lookupECM' -- computation. -- -- As the accumulator is a bound unsigned integer, when the accumulator -- increments back to 0, the cache state is completely cleared. -- -- The time request function is invoked in one of two different conditions -- -- * When a new key-value entry is requested, the current time is also -- requested during the same lookup, as a recent time determination is -- needed for a new entry in the key-value cache. -- -- * When the modulo of the accumulator and a specified value equals to 0. -- -- When the current time is determined during a lookup, access times of the -- entries in the key-value cache are compared with the new time to filter -- out expired entries from the key-value map. -- lookupECM :: (Monad m, Ord k) => ECM m mv s M.Map k v -> k -> m v lookupECM ecm id = do enter m'maps $ \(CacheState (retr_state, maps, mapsize, uses, incr)) -> let incr' = incr + 1 in if incr' < incr -- Word incrementor has cycled back to 0, -- so may as well clear the cache completely. then lookupECM' (retr_state, M.empty, 0, ([], 0), 0) (0+1) else lookupECM' (retr_state, maps, mapsize, uses, incr) incr' where ECM ( m'maps, retr, gettime, minimumkeep, timecheckmodulo, removalsize, compactlistsize, enter, _ro ) = ecm -- Reversing the list first before turning into a map, so the higher value -- which is at the beginning will be at the end. And fromList retains the -- last value for a key in the list. mnub = M.toList . M.fromList . reverse lookupECM' (retr_state, maps, mapsize, uses, incr) incr' = do let uses' = updateUses uses id incr' compactlistsize mnub (ret, do_again) <- det retr_state maps mapsize uses' incr' if do_again then do let (CacheState (retr_state', maps', mapsize', uses'', incr''), _) = ret uses''' = updateUses uses'' id incr'' compactlistsize mnub (ret', _) <- det retr_state' maps' mapsize' uses''' incr'' return ret' else return ret det retr_state maps mapsize uses' incr' = detECM (M.lookup id maps) retr_state (retr retr_state id) ( (\time_r -> M.insert id time_r maps), (\time_r keepuses -> M.insert id time_r $! M.intersection maps $ M.fromList keepuses), mnub, minimumkeep, removalsize ) gettime M.filter mapsize M.size uses' incr' timecheckmodulo maps getValReqState :: (Monad m, Ord k) => ECM m mv s M.Map k v -> k -> m (Maybe s) getValReqState ecm id = do CacheState (retr_state, maps, mapsize, uses, incr) <- read m'maps return retr_state where ECM ( m'maps, _, _, _, _, _, _, _, read ) = ecm -- | Invalidates a key from the cache and returns its value if any. -- Note that this is a sequential composition of a read and modify of the -- mutable cache container (e.g. 'MV.readMVar' followed by 'MV.modifyMVar' -- with 'newECMIO' instances). -- invalidate :: (Monad m, Ord k) => ECM m mv s M.Map k v -> k -> m (Maybe v) invalidate ecm id = do CacheState (_, maps0, _, _, _) <- read m'maps case M.lookup id maps0 of Just time_prev0 -> do prev0' <- enter m'maps $ \(CacheState (retr_state, maps, mapsize, uses, incr)) -> let (_, _, prev) = case M.lookup id maps of Just time_prev -> time_prev Nothing -> time_prev0 maps' = M.delete id maps in return (CacheState (retr_state, maps', mapsize, uses, incr), prev) return $ Just prev0' Nothing -> return Nothing where ECM ( m'maps, _, _, _, _, _, compactlistsize, enter, read ) = ecm -- | Invalidates the entire cache and returns the last key and value if any. -- Note that this is a sequential composition of a read and modify of the -- mutable cache container (e.g. 'MV.readMVar' followed by 'MV.modifyMVar' -- with 'newECMIO' instances). -- invalidateCache :: (Monad m, Ord k) => ECM m mv s M.Map k v -> m (Maybe (k, v)) invalidateCache ecm = do CacheState (_, maps0, _, (uses0, _), _) <- read m'maps case (M.toList $ M.intersection (M.fromList $ reverse uses0) maps0) of [] -> return Nothing uses0' -> let (id, _) = L.maximumBy (\(_,a) (_,b) -> compare a b) uses0' in case M.lookup id maps0 of Just time_prev0 -> do prev0' <- enter m'maps $ \(CacheState (retr_state, maps, _mapsize, _uses, _incr)) -> let (_, _, prev) = case M.lookup id maps of Just time_prev -> time_prev Nothing -> time_prev0 in return (CacheState (retr_state, M.empty, 0, ([], 0), 0), prev) return $ Just (id, prev0') where ECM ( m'maps, _, _, _, _, _, compactlistsize, enter, read ) = ecm -- | List of keys in the cache map without performing a time check, returning -- both stored keys that are expired and keys that are not expired. keys are -- in an unspecified order. -- keysCached :: (Monad m, Ord k) => ECM m mv s M.Map k v -> m [k] keysCached ecm = do CacheState (_, maps0, _, _, _) <- read m'maps return $ M.keys maps0 where ECM ( m'maps, _, _, _, _, _, _, _, read ) = ecm -- | List of keys in the cache map that are not expired values. A time check -- is always performed to compare with the elapsed time left with each key. -- The cache state is not modified and the time check is not performed from -- within a modifying state context, e.g. not within 'MV.modifyMVar' with a -- 'newECMIO' instance. Keys are in an unspecified order. -- keysNotExpired :: (Monad m, Ord k) => ECM m mv s M.Map k v -> m [k] keysNotExpired ecm = do CacheState (_, maps0, _, _, _) <- read m'maps current_time <- gettime return $ detNotExpired current_time $ M.toList maps0 where ECM ( m'maps, _, gettime, _, _, _, _, _, read ) = ecm {- These functions would require inclusion of a enter_ function (like modifyMVar_) putValReqState :: (Monad m, Ord k) => ECM m mv s M.Map k v -> k -> Maybe s -> m (Maybe s) putValReqState ecm id new_state = do enter_ m'maps $ \(CacheState (retr_state, maps, mapsize, uses, incr)) -> return (CacheState (new_state, maps, mapsize, uses, incr), retr_state) where ECM ( m'maps, _, _, _, _, _, _, _, enter_, _ro ) = ecm clearCache :: (Monad m, Ord k) => ECM m mv s M.Map k v -> m () clearCache ecm = do enter_ m'maps $ \(CacheState (retr_state, maps, mapsize, uses, incr)) -> return $ CacheState (retr_state, M.empty, 0, ([], 0), 0) where ECM ( m'maps, _, _, _, _, _, _, enter, enter_, _ ) = ecm -} {- -- This function differs from 'lookupECM' only in the case that the value -- being requested also causes a new time to have been computed during the -- same lookup, and have been found to be out of date. When the condition -- happens, this function returns the old cached value without attempting -- to request a new value, despite being out of date. However, it does -- clear the key from the key-value store for the next request. -- lookupECMUse :: (Monad m, Ord k) => ECM m mv s M.Map k v -> k -> m v lookupECMUse ecm id = do enter m'maps $ \(CacheState (retr_state, maps, mapsize, uses, incr)) -> let incr' = incr + 1 in if incr' < incr -- Word incrementor has cycled back to 0, -- so may as well clear the cache completely. then lookupECM' (retr_state, M.empty, 0, ([], 0), 0) (0+1) else lookupECM' (retr_state, maps, mapsize, uses, incr) incr' where ECM ( m'maps, retr, gettime, minimumkeep, timecheckmodulo, removalsize, compactlistsize, enter, _ro ) = ecm mnub = M.toList . M.fromList . reverse lookupECM' (retr_state, maps, mapsize, uses, incr) incr' = do let uses' = updateUses uses id incr' compactlistsize mnub (ret, _) <- detECM (M.lookup id maps) retr_state (retr retr_state id) ( (\time_r -> M.insert id time_r maps), (\time_r keepuses -> M.insert id time_r $! M.intersection maps $ M.fromList keepuses), mnub, minimumkeep, removalsize ) gettime M.filter mapsize M.size uses' incr' timecheckmodulo maps return ret -} -- | Used with 'newECMIO' or 'newECMForM' to provide a consistent duration for requested values. consistentDuration :: (Monad m, Ord k) => TimeUnits -> (Maybe s -> k -> m (Maybe s, v)) -> (Maybe s -> k -> m (TimeUnits, (Maybe s, v))) consistentDuration duration fun = \state id -> do ret <- fun state id return (duration, ret) expiring-cache-map-0.0.6.1/Caching/ExpiringCacheMap/HashECM.hs0000644000000000000000000003561312752752732021776 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} -- | -- Module : Caching.ExpiringCacheMap.HashECM -- Copyright: (c) 2014 Edward L. Blake -- License: BSD-style -- Maintainer: Edward L. Blake -- Stability: experimental -- Portability: portable -- -- A cache that holds values for a length of time that uses 'Hashable' keys -- with "Data.HashMap.Strict". -- -- An example of creating a cache for accessing files: -- -- > {-# LANGUAGE OverloadedStrings #-} -- > -- > import Caching.ExpiringCacheMap.HashECM (newECMIO, lookupECM, CacheSettings(..), consistentDuration) -- > -- > import qualified Data.Time.Clock.POSIX as POSIX (POSIXTime, getPOSIXTime) -- > import qualified Data.ByteString.Char8 as BS -- > import System.IO (withFile, IOMode(ReadMode)) -- > -- > example = do -- > filecache <- newECMIO -- > (consistentDuration 100 -- Duration between access and expiry time of each item -- > (\state id -> do BS.putStrLn "Reading a file again..." -- > withFile (case id :: BS.ByteString of -- > "file1" -> "file1.txt" -- > "file2" -> "file2.txt") -- > ReadMode $ -- > \fh -> do content <- BS.hGetContents fh -- > return $! (state, content))) -- > (do time <- POSIX.getPOSIXTime -- > return (round (time * 100))) -- > 1 -- Time check frequency: (accumulator `mod` this_number) == 0. -- > (CacheWithLRUList -- > 6 -- Expected size of key-value map when removing elements. -- > 6 -- Size of map when to remove items from key-value map. -- > 12 -- Size of list when to compact -- > ) -- > -- > -- Use lookupECM whenever the contents of "file1" is needed. -- > b <- lookupECM filecache "file1" -- > BS.putStrLn b -- > return () -- > -- module Caching.ExpiringCacheMap.HashECM ( -- * Create cache newECMIO, newECMForM, consistentDuration, -- * Request value from cache lookupECM, -- * Value request function state getValReqState, -- * Invalidate cache invalidate, invalidateCache, -- * List keys keysCached, keysNotExpired, -- * Type ECM, CacheSettings(..) ) where import qualified Control.Concurrent.MVar as MV import qualified Data.HashMap.Strict as HM import qualified Data.List as L import Data.Hashable (Hashable(..)) import Caching.ExpiringCacheMap.Internal.Internal (updateUses, detECM, detNotExpired) import Caching.ExpiringCacheMap.Types import Caching.ExpiringCacheMap.Internal.Types -- | Create a new expiring cache for retrieving uncached values via 'IO' -- interaction (such as in the case of reading a file from disk), with -- a shared state lock via an 'MV.MVar' to manage cache state. -- -- Value request and time check request functions are provided as arguments. -- -- The time check frequency value has to be 1 or higher, with higher values -- postponing time checks for longer periods of time. -- -- A cache setting specifies how the cache should remove entries when the -- cache becomes a certain size. The only constructor for this is -- 'CacheWithLRUList'. -- newECMIO :: (Eq k, Hashable k) => (Maybe s -> k -> IO (TimeUnits, (Maybe s, v))) -> (IO TimeUnits) -> ECMIncr -> CacheSettings -> IO (ECM IO MV.MVar s HM.HashMap k v) newECMIO retr gettime timecheckmodulo cachesettings = do newECMForM retr gettime timecheckmodulo cachesettings MV.newMVar MV.modifyMVar MV.readMVar -- | Create a new expiring cache along arbitrary monads with provided -- functions to create cache state in 'Monad' m2, and modify and read -- cache state in 'Monad' m1. -- -- 'newECMIO' is just a wrapper to this function with 'MV.MVar' functions: -- -- @ -- newECMIO retr gettime timecheckmodulo cachesettings = -- newECMForM retr gettime timecheckmodulo cachesettings -- 'MV.newMVar' 'MV.modifyMVar' 'MV.readMVar' -- @ -- -- Value request and time check request functions are provided as arguments. -- -- The time check frequency value has to be 1 or higher, with higher values -- postponing time checks for longer periods of time. -- -- A cache setting specifies how the cache should remove entries when the -- cache becomes a certain size. The only constructor for this is -- 'CacheWithLRUList'. -- newECMForM :: (Monad m1, Monad m2) => (Eq k, Hashable k) => (Maybe s -> k -> m1 (TimeUnits, (Maybe s, v))) -> (m1 TimeUnits) -> ECMIncr -> CacheSettings -> ECMNewState m2 mv s HM.HashMap k v -> ECMEnterState m1 mv s HM.HashMap k v -> ECMReadState m1 mv s HM.HashMap k v -> m2 (ECM m1 mv s HM.HashMap k v) newECMForM retr gettime timecheckmodulo (CacheWithLRUList minimumkeep removalsize compactlistsize) newstate enterstate readstate = if timecheckmodulo <= 0 then error "Modulo time check must be 1 or higher." else do m'maps <- newstate $ CacheState ( Nothing, HM.empty, 0, ([], 0), 0 ) return $ ECM ( m'maps, retr, gettime, minimumkeep, timecheckmodulo, removalsize, compactlistsize, enterstate, readstate ) -- | Request a value associated with a key from the cache. -- -- * If the value is not in the cache, the value will be requested through the -- function defined when the 'ECM' value was created, its computation -- returned and the value stored in the cache state map. -- -- * If the value is in the cache and has not expired, it will be returned. -- -- * If the value is in the cache and a new time is computed in the same -- lookup, and the value has been determined to have since expired, it -- will be discarded and a new value will be requested for this computation. -- -- Every 'lookupECM' computation increments an accumulator in the cache state -- which is used to keep track of the succession of key accesses. Based on the -- parameters provided with the 'CacheWithLRUList' constructor, this history -- of key accesses is then used to remove entries from the cache back down to -- a minimum size. Also, when the modulo of the accumulator and the modulo -- value computes to 0, the time request function is invoked. In some cases the -- accumulator may get incremented more than once in a 'lookupECM' computation. -- -- As the accumulator is a bound unsigned integer, when the accumulator -- increments back to 0, the cache state is completely cleared. -- -- The time request function is invoked in one of two different conditions -- -- * When a new key-value entry is requested, the current time is also -- requested during the same lookup, as a recent time determination is -- needed for a new entry in the key-value cache. -- -- * When the modulo of the accumulator and a specified value equals to 0. -- -- When the current time is determined during a lookup, access times of the -- entries in the key-value cache are compared with the new time to filter -- out expired entries from the key-value map. -- lookupECM :: (Monad m, Eq k, Hashable k) => ECM m mv s HM.HashMap k v -> k -> m v lookupECM ecm id = do enter m'maps $ \(CacheState (retr_state, maps, mapsize, uses, incr)) -> let incr' = incr + 1 in if incr' < incr -- Word incrementor has cycled back to 0, -- so may as well clear the cache completely. then lookupECM' (retr_state, HM.empty, 0, ([], 0), 0) (0+1) else lookupECM' (retr_state, maps, mapsize, uses, incr) incr' where ECM ( m'maps, retr, gettime, minimumkeep, timecheckmodulo, removalsize, compactlistsize, enter, _ro ) = ecm -- Reversing the list first before turning into a map, so the higher value -- which is at the beginning will be at the end. And fromList retains the -- last value for a key in the list. mnub = HM.toList . HM.fromList . reverse lookupECM' (retr_state, maps, mapsize, uses, incr) incr' = do let uses' = updateUses uses id incr' compactlistsize mnub (ret, do_again) <- det retr_state maps mapsize uses' incr' if do_again then do let (CacheState (retr_state', maps', mapsize', uses'', incr''), _) = ret uses''' = updateUses uses'' id incr'' compactlistsize mnub (ret', _) <- det retr_state' maps' mapsize' uses''' incr'' return ret' else return ret det retr_state maps mapsize uses' incr' = detECM (HM.lookup id maps) retr_state (retr retr_state id) ( (\time_r -> HM.insert id time_r maps), (\time_r keepuses -> HM.insert id time_r $! HM.intersection maps $ HM.fromList keepuses), mnub, minimumkeep, removalsize ) gettime HM.filter mapsize HM.size uses' incr' timecheckmodulo maps getValReqState :: (Monad m, Eq k, Hashable k) => ECM m mv s HM.HashMap k v -> k -> m (Maybe s) getValReqState ecm id = do CacheState (retr_state, maps, mapsize, uses, incr) <- read m'maps return retr_state where ECM ( m'maps, _, _, _, _, _, _, _, read ) = ecm -- | Invalidates a key from the cache and returns its value if any. -- Note that this is a sequential composition of a read and modify of the -- mutable cache container (e.g. 'MV.readMVar' followed by 'MV.modifyMVar' -- with 'newECMIO' instances). -- invalidate :: (Monad m, Eq k, Hashable k) => ECM m mv s HM.HashMap k v -> k -> m (Maybe v) invalidate ecm id = do CacheState (_, maps0, _, _, _) <- read m'maps case HM.lookup id maps0 of Just time_prev0 -> do prev0' <- enter m'maps $ \(CacheState (retr_state, maps, mapsize, uses, incr)) -> let (_, _, prev) = case HM.lookup id maps of Just time_prev -> time_prev Nothing -> time_prev0 maps' = HM.delete id maps in return (CacheState (retr_state, maps', mapsize, uses, incr), prev) return $ Just prev0' Nothing -> return Nothing where ECM ( m'maps, _, _, _, _, _, compactlistsize, enter, read ) = ecm -- | Invalidates the entire cache and returns the last key and value if any. -- Note that this is a sequential composition of a read and modify of the -- mutable cache container (e.g. 'MV.readMVar' followed by 'MV.modifyMVar' -- with 'newECMIO' instances). -- invalidateCache :: (Monad m, Eq k, Hashable k) => ECM m mv s HM.HashMap k v -> m (Maybe (k, v)) invalidateCache ecm = do CacheState (_, maps0, _, (uses0, _), _) <- read m'maps case (HM.toList $ HM.intersection (HM.fromList $ reverse uses0) maps0) of [] -> return Nothing uses0' -> let (id, _) = L.maximumBy (\(_,a) (_,b) -> compare a b) uses0' in case HM.lookup id maps0 of Just time_prev0 -> do prev0' <- enter m'maps $ \(CacheState (retr_state, maps, _mapsize, _uses, _incr)) -> let (_, _, prev) = case HM.lookup id maps of Just time_prev -> time_prev Nothing -> time_prev0 in return (CacheState (retr_state, HM.empty, 0, ([], 0), 0), prev) return $ Just (id, prev0') where ECM ( m'maps, _, _, _, _, _, compactlistsize, enter, read ) = ecm -- | List of keys in the cache map without performing a time check, returning -- both stored keys that are expired and keys that are not expired. keys are -- in an unspecified order. -- keysCached :: (Monad m, Eq k, Hashable k) => ECM m mv s HM.HashMap k v -> m [k] keysCached ecm = do CacheState (_, maps0, _, _, _) <- read m'maps return $ HM.keys maps0 where ECM ( m'maps, _, _, _, _, _, _, _, read ) = ecm -- | List of keys in the cache map that are not expired values. A time check -- is always performed to compare with the elapsed time left with each key. -- The cache state is not modified and the time check is not performed from -- within a modifying state context, e.g. not within 'MV.modifyMVar' with a -- 'newECMIO' instance. Keys are in an unspecified order. -- keysNotExpired :: (Monad m, Eq k, Hashable k) => ECM m mv s HM.HashMap k v -> m [k] keysNotExpired ecm = do CacheState (_, maps0, _, _, _) <- read m'maps current_time <- gettime return $ detNotExpired current_time $ HM.toList maps0 where ECM ( m'maps, _, gettime, _, _, _, _, _, read ) = ecm {- These functions would require inclusion of a enter_ function (like modifyMVar_) putValReqState :: (Monad m, Eq k, Hashable k) => ECM m mv s HM.HashMap k v -> k -> Maybe s -> m (Maybe s) putValReqState ecm id new_state = do enter m'maps $ \(CacheState (retr_state, maps, mapsize, uses, incr)) -> return (CacheState (new_state, maps, mapsize, uses, incr), retr_state) where ECM ( m'maps, _, _, _, _, _, _, _, enter_ _ro ) = ecm -- clearCache :: (Monad m, Eq k, Hashable k) => ECM m mv s HM.HashMap k v -> m () clearCache ecm = do enter_ m'maps $ \(CacheState (retr_state, maps, mapsize, uses, incr)) -> return $ CacheState (retr_state, HM.empty, 0, ([], 0), 0) where ECM ( m'maps, _, _, _, _, _, _, _, enter_, _ ) = ecm -} {- -- This function differs from 'lookupECM' only in the case that the value -- being requested also causes a new time to have been computed during the -- same lookup, and have been found to be out of date. When the condition -- happens, this function returns the old cached value without attempting -- to request a new value, despite being out of date. However, it does -- clear the key from the key-value store for the next request. -- lookupECMUse :: (Monad m, Eq k, Hashable k) => ECM m mv s HM.HashMap k v -> k -> m v lookupECMUse ecm id = do enter m'maps $ \(CacheState (retr_state, maps, mapsize, uses, incr)) -> let incr' = incr + 1 in if incr' < incr -- Word incrementor has cycled back to 0, -- so may as well clear the cache completely. then lookupECM' (retr_state, HM.empty, 0, ([], 0), 0) (0+1) else lookupECM' (retr_state, maps, mapsize, uses, incr) incr' where ECM ( m'maps, retr, gettime, minimumkeep, timecheckmodulo, removalsize, compactlistsize, enter, _ro ) = ecm mnub = HM.toList . HM.fromList . reverse lookupECM' (retr_state, maps, mapsize, uses, incr) incr' = do let uses' = updateUses uses id incr' compactlistsize mnub (ret, _) <- detECM (HM.lookup id maps) retr_state (retr retr_state id) ( (\time_r -> HM.insert id time_r maps), (\time_r keepuses -> HM.insert id time_r $! HM.intersection maps $ HM.fromList keepuses), mnub, minimumkeep, removalsize) gettime HM.filter mapsize HM.size uses' incr' timecheckmodulo maps return ret -} -- | Used with 'newECMIO' or 'newECMForM' to provide a consistent duration for requested values. consistentDuration :: (Monad m, Eq k, Hashable k) => TimeUnits -> (Maybe s -> k -> m (Maybe s, v)) -> (Maybe s -> k -> m (TimeUnits, (Maybe s, v))) consistentDuration duration fun = \state id -> do ret <- fun state id return (duration, ret) expiring-cache-map-0.0.6.1/Caching/ExpiringCacheMap/Utils/0000755000000000000000000000000012752752732021322 5ustar0000000000000000expiring-cache-map-0.0.6.1/Caching/ExpiringCacheMap/Utils/Types.hs0000644000000000000000000000202412752752732022760 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} -- | -- Module : Caching.ExpiringCacheMap.Utils.Types -- Copyright: (c) 2014 Edward L. Blake -- License: BSD-style -- Maintainer: Edward L. Blake -- Stability: experimental -- Portability: portable -- -- Simple types. -- module Caching.ExpiringCacheMap.Utils.Types ( -- * Types TimeUnits, ECMMapSize, ECMULength, ECMIncr, ) where import Data.Word (Word32) -- | Integer involved in the time units used to determine when an item expires. -- The time units used can be any arbitrary integer time representation, such -- as seconds or milliseconds for examples. They can also be deterministic time -- steps in a sequencing monad. -- type TimeUnits = Int -- | Integer involved in the size of a key-value map. type ECMMapSize = Int -- | Integer involved in the length of the usage history list. type ECMULength = Int -- | Unsigned integer ('Word32') involved in the cache state incrementing accumulator. type ECMIncr = Word32 expiring-cache-map-0.0.6.1/Caching/ExpiringCacheMap/Utils/TestSequence.hs0000644000000000000000000001473312752752732024276 0ustar0000000000000000{-# LANGUAGE CPP #-} -- | -- Module : Caching.ExpiringCacheMap.Utils.TestSequence -- Copyright: (c) 2014 Edward L. Blake -- License: BSD-style -- Maintainer: Edward L. Blake -- Stability: experimental -- Portability: portable -- -- TestSequence monad for testing caching behaviour. -- -- > {-# LANGUAGE OverloadedStrings #-} -- > -- > import Caching.ExpiringCacheMap.HashECM (newECMForM, lookupECM, CacheSettings(..), consistentDuration) -- > import qualified Caching.ExpiringCacheMap.Utils.TestSequence as TestSeq -- > -- > import qualified Data.ByteString.Char8 as BS -- > -- > test = do -- > (TestSeq.TestSequenceState (_, events, _), return_value) <- TestSeq.runTestSequence test' -- > (putStrLn . show . reverse) events -- > return () -- > where -- > test' = do -- > filecache <- newECMForM -- > (consistentDuration 100 -- Duration between access and expiry time of each item, no state needed. -- > (\state _id -> do number <- TestSeq.readNumber -- > return (state, number))) -- > (TestSeq.getCurrentTime >>= return) -- > 12000 -- 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 -- > ) -- > TestSeq.newTestSVar TestSeq.enterTestSVar TestSeq.readTestSVar -- > -- > -- Use lookupECM whenever the contents of "file1" is needed. -- > b <- lookupECM filecache ("file1" :: BS.ByteString) -- > TestSeq.haveNumber b -- > b <- lookupECM filecache "file1" -- > b <- lookupECM filecache "file2" -- > TestSeq.haveNumber b -- > return b -- > -- -- Evaluating the @test@ function results in a list of events. -- -- >>> test -- [GetVar 3,ReadNumber 4,GetTime 7,PutVar 11,HaveNumber 4,GetVar 14,PutVar 17, -- GetVar 19,ReadNumber 20,GetTime 23,PutVar 27,HaveNumber 20] -- -- In this example the history shows 2 time accesses (@GetTime 7@ and -- @GetTime 23@) since the time check frequency number is a high value (12000), -- but regardless the high value a time check is still requested again because -- of the new key request for @"file2"@. -- -- Changing the time frequency to 1 will alter the list of events with more -- frequent time checks: -- -- >>> test -- [GetVar 3,ReadNumber 4,GetTime 7,PutVar 11,HaveNumber 4,GetVar 14,GetTime 15, -- GetTime 18,PutVar 22,GetVar 24,ReadNumber 25,GetTime 28,PutVar 32, -- HaveNumber 25] -- module Caching.ExpiringCacheMap.Utils.TestSequence ( runTestSequence, newTestSVar, enterTestSVar, readTestSVar, getCurrentTime, readNumber, haveNumber, TestSequenceEvents(..), TestSequenceState(..), TestSequence(..), TestSVar(..) ) where #if (!defined(__GLASGOW_HASKELL__)) || (__GLASGOW_HASKELL__ < 710) import Control.Applicative (Applicative(..)) #endif import Control.Monad (ap, liftM) import Data.Word (Word32) data TestSequenceEvents = GetVar Word32 | PutVar Word32 | GetTime Word32 | ReadNumber Int | HaveNumber Int deriving (Eq) instance Show TestSequenceEvents where show (GetVar a) = "GetVar " ++ (show a) show (PutVar a) = "PutVar " ++ (show a) show (GetTime a) = "GetTime " ++ (show a) show (ReadNumber a) = "ReadNumber " ++ (show a) show (HaveNumber a) = "HaveNumber " ++ (show a) newtype TestSequenceState b = TestSequenceState (Word32, [TestSequenceEvents], Maybe b) instance Show (TestSequenceState ct) where show (TestSequenceState (a,b,_)) = "TestSequenceState " ++ (show a) ++ " " ++ (show b) newtype TestSequence b a = TestSequence (TestSequenceState b -> (TestSequenceState b, a)) newtype TestSVar a = TestSVar a -- For GHC 7.10 instance Functor (TestSequence a) where fmap = liftM instance Applicative (TestSequence a) where pure = return (<*>) = ap instance Monad (TestSequence a) where TestSequence fun >>= k = TestSequence (\state -> let (state', ret) = (fun state) TestSequence fun' = k ret in fun' state') return ret = TestSequence $ \(TestSequenceState (timer, hl, testsvar)) -> (TestSequenceState (timer+1,hl, testsvar), ret) runTestSequence :: Show a => TestSequence b a -> IO (TestSequenceState b, a) runTestSequence f = do let ret = (fun (TestSequenceState (0, [], Nothing))) in return ret where TestSequence fun = (TestSequence (\(TestSequenceState (t, hl, testsvar)) -> (TestSequenceState (t+1, hl, testsvar), ()))) >> f newTestSVar :: a -> TestSequence a (TestSVar a) newTestSVar var = TestSequence $ \(TestSequenceState (timer, hl, Nothing)) -> (TestSequenceState (timer+1, hl, Just var), TestSVar var) enterTestSVar :: TestSVar a -> (a -> TestSequence a (a,b)) -> TestSequence a b enterTestSVar testsvar fun = do teststate <- readTestSVar testsvar (teststate',passalong) <- fun teststate putTestSVar testsvar teststate' return passalong -- 'putTestSVar' is used along with 'readTestSVar' to implement enterTestSVar. -- putTestSVar :: TestSVar a -> a -> TestSequence a a putTestSVar _testsvar testsvar' = TestSequence $ \(TestSequenceState (timer, hl, testsvar)) -> (TestSequenceState (timer+1, (PutVar timer) : hl, Just testsvar'), case testsvar of Nothing -> testsvar' Just testsvar'' -> testsvar'') readTestSVar :: TestSVar a -> TestSequence a a readTestSVar _testsvar = TestSequence $ \(TestSequenceState (timer, hl, Just testsvar)) -> (TestSequenceState (timer+1, (GetVar timer) : hl, Just testsvar), testsvar) getCurrentTime :: TestSequence a Int getCurrentTime = TestSequence $ \(TestSequenceState (timer, hl, testsvar)) -> (TestSequenceState (timer+1, (GetTime timer) : hl, testsvar), fromIntegral timer) readNumber :: TestSequence a Int readNumber = TestSequence $ \(TestSequenceState (timer, hl, testsvar)) -> let number = fromIntegral timer in (TestSequenceState (timer+1, (ReadNumber number) : hl, testsvar), number) haveNumber :: Int -> TestSequence a () haveNumber number = TestSequence $ \(TestSequenceState (timer, hl, testsvar)) -> (TestSequenceState (timer+1, (HaveNumber number) : hl, testsvar), ()) expiring-cache-map-0.0.6.1/Caching/ExpiringCacheMap/Internal/0000755000000000000000000000000012752752732021776 5ustar0000000000000000expiring-cache-map-0.0.6.1/Caching/ExpiringCacheMap/Internal/Types.hs0000644000000000000000000000311012752752732023431 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} -- | -- Module : Caching.ExpiringCacheMap.Internal.Types -- Copyright: (c) 2014 Edward L. Blake -- License: BSD-style -- Maintainer: Edward L. Blake -- Stability: experimental -- Portability: portable -- -- Types used by internal functions and as the opaque types exported by other -- modules, assume these type definitions to change from version to version. -- module Caching.ExpiringCacheMap.Internal.Types ( -- * Cache internals ECM(..), CacheState(..), ECMNewState, ECMEnterState, ECMReadState ) where import qualified Control.Concurrent.MVar as MV import Caching.ExpiringCacheMap.Utils.Types type ECMNewState a b s m k v = (CacheState s m k v) -> a (b (CacheState s m k v)) type ECMEnterState a b s m k v = b (CacheState s m k v) -> ((CacheState s m k v) -> a ((CacheState s m k v), v)) -> a v type ECMReadState a b s m k v = b (CacheState s m k v) -> a (CacheState s m k v) -- | The cache state. newtype CacheState s m k v = CacheState (Maybe s, m k (TimeUnits, TimeUnits, v), ECMMapSize, ([(k, ECMIncr)], ECMULength), ECMIncr) -- | The type that encapsulates a cache map. newtype ECM a b s m k v = ECM ( b (CacheState s m k v), Maybe s -> k -> a (TimeUnits, (Maybe s, v)), a TimeUnits, ECMMapSize, -- TimeUnits, ECMIncr, ECMULength, ECMULength, ECMEnterState a b s m k v, ECMReadState a b s m k v) expiring-cache-map-0.0.6.1/Caching/ExpiringCacheMap/Internal/Internal.hs0000644000000000000000000001764712752752732024125 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} -- | -- Module : Caching.ExpiringCacheMap.Internal -- Copyright: (c) 2014 Edward L. Blake -- License: BSD-style -- Maintainer: Edward L. Blake -- Stability: experimental -- Portability: portable -- -- A module with internal functions used in common by HashECM and OrdECM. -- Assume these functions to change from version to version. -- module Caching.ExpiringCacheMap.Internal.Internal ( updateUses, detECM, getStatsString, detNotExpired ) where import qualified Data.List as L import Caching.ExpiringCacheMap.Types import Caching.ExpiringCacheMap.Internal.Types updateUses :: (Eq k) => ([(k, ECMIncr)], ECMULength) -> k -> ECMIncr -> ECMULength -> ([(k, ECMIncr)] -> [(k, ECMIncr)]) -> ([(k, ECMIncr)], ECMULength) {-# INLINE updateUses #-} updateUses (usesl, lcount) id incr' compactlistsize compactUses | lcount >= 5 = case usesl of (id', _) : rest | id' == id -> ((id', incr') : rest, lcount) latest : (id1, oincr1) : (id2, oincr2) : (id3, oincr3) : (id4, oincr4) : rest -> case True of _ | id1 == id -> ((id1, incr') : latest : (id2, oincr2) : (id3, oincr3) : (id4, oincr4) : rest, lcount) _ | id2 == id -> ((id2, incr') : latest : (id1, oincr1) : (id3, oincr3) : (id4, oincr4) : rest, lcount) _ | id3 == id -> ((id3, incr') : latest : (id1, oincr1) : (id2, oincr2) : (id4, oincr4) : rest, lcount) _ | id4 == id -> ((id4, incr') : latest : (id1, oincr1) : (id2, oincr2) : (id3, oincr3) : rest, lcount) _ -> justPrepend {- if id1 == id then ((id1, incr') : latest : (id2, oincr2) : (id3, oincr3) : (id4, oincr4) : rest, lcount) else if id2 == id then ((id2, incr') : latest : (id1, oincr1) : (id3, oincr3) : (id4, oincr4) : rest, lcount) else if id3 == id then ((id3, incr') : latest : (id1, oincr1) : (id2, oincr2) : (id4, oincr4) : rest, lcount) else if id4 == id then ((id4, incr') : latest : (id1, oincr1) : (id2, oincr2) : (id3, oincr3) : rest, lcount) else justPrepend -} _ -> justPrepend | otherwise = case usesl of (id', _) : rest | id' == id -> ((id', incr') : rest, lcount) latest : (id1, oincr1) : (id2, oincr2) : (id3, oincr3) : rest -> case True of _ | id1 == id -> ((id1, incr') : latest : (id2, oincr2) : (id3, oincr3) : rest, lcount) _ | id2 == id -> ((id2, incr') : latest : (id1, oincr1) : (id3, oincr3) : rest, lcount) _ | id3 == id -> ((id3, incr') : latest : (id1, oincr1) : (id2, oincr2) : rest, lcount) _ -> justPrepend {- if id1 == id then ((id1, incr') : latest : (id2, oincr2) : (id3, oincr3) : rest, lcount) else if id2 == id then ((id2, incr') : latest : (id1, oincr1) : (id3, oincr3) : rest, lcount) else if id3 == id then ((id3, incr') : latest : (id1, oincr1) : (id2, oincr2) : rest, lcount) else justPrepend -} latest : (id1, oincr1) : (id2, oincr2) : rest -> case True of _ | id1 == id -> ((id1, incr') : latest : (id2, oincr2) : rest, lcount) _ | id2 == id -> ((id2, incr') : latest : (id1, oincr1) : rest, lcount) _ -> justPrepend {- if id1 == id then ((id1, incr') : latest : (id2, oincr2) : rest, lcount) else if id2 == id then ((id2, incr') : latest : (id1, oincr1) : rest, lcount) else justPrepend -} latest : (id', _) : rest -> if id' == id then ((id', incr') : latest : rest, lcount) else justPrepend _ -> justPrepend where justPrepend = if lcount > compactlistsize then let newusesl = compactUses usesl in ((id, incr') : newusesl, (+1) $! (L.length newusesl) ) else ((id, incr') : usesl, lcount + 1) detECM :: (Monad m, Eq k) => Maybe (TimeUnits, TimeUnits, v) -> Maybe s -> m (TimeUnits, (Maybe s, v)) -> ( ((TimeUnits, TimeUnits, v) -> mp k (TimeUnits, TimeUnits, v)), ((TimeUnits, TimeUnits, v) -> [(k, ECMIncr)] -> mp k (TimeUnits, TimeUnits, v)), ([(k, ECMIncr)] -> [(k, ECMIncr)]), ECMMapSize, ECMULength) -> m TimeUnits -> (((TimeUnits, TimeUnits, v) -> Bool) -> mp k (TimeUnits, TimeUnits, v) -> mp k (TimeUnits, TimeUnits, v)) -> ECMMapSize -> (mp k (TimeUnits, TimeUnits, v) -> ECMMapSize) -> ([(k, ECMIncr)], ECMULength) -> ECMIncr -> ECMIncr -> mp k (TimeUnits, TimeUnits, v) -> m ((CacheState s mp k v, v), Bool) {-# INLINE detECM #-} detECM result retr_state retr_id etc gettime filt cmapsize newsize uses' incr' timecheckmodulo maps = case result of Nothing -> do (expirytime, (retr_state', r)) <- retr_id time <- gettime let (newmaps,mapsize',newuses) = insertAndPerhapsRemoveSome etc cmapsize newsize filt time r expirytime uses' return $! ((CacheState (retr_state', newmaps, mapsize', newuses, incr'), r), False) Just (_accesstime, _expirytime, m) -> do if incr' `mod` timecheckmodulo == 0 then do time <- gettime return $! let maps' = filterExpired time maps in ((CacheState (retr_state, maps', (+0) $! newsize maps', uses', incr'), m), True) else return ((CacheState (retr_state, maps, cmapsize, uses', incr'), m), False) where filterExpired = filterExpired' filt {-# INLINE insertAndPerhapsRemoveSome #-} insertAndPerhapsRemoveSome (insert_id1, insert_id2, mnub, minimumkeep, removalsize) cmapsize newsize filt time r expirytime uses = if cmapsize >= removalsize then let (keepuses, _removekeys) = getKeepAndRemove usesl newmaps = insert_id2 (time, expirytime, r) keepuses newmaps' = filterExpired time newmaps in (newmaps', (+0) $! newsize newmaps', (keepuses, (+0) $! (L.length keepuses))) else let newmaps = insert_id1 (time, expirytime, r) in (newmaps, cmapsize + 1, uses) -- filterExpired time where (usesl, _lcount) = uses getKeepAndRemove = finalTup . splitAt minimumkeep . reverse . sortI . map swap2 . mnub where swap2 (a,b) = (b,a) finalTup (l1,l2) = (map (\(c,k) -> (k,c)) l1, map (\(c,k) -> k) l2) sortI = L.sortBy (\(l,_) (r,_) -> compare l r) filterExpired = filterExpired' filt {-# INLINE filterExpired' #-} filterExpired' filt time = filt (\(accesstime, expirytime, _value) -> (accesstime <= time) && (accesstime > (time - expirytime))) detNotExpired :: TimeUnits -> [(k, (TimeUnits, TimeUnits, v))] -> [k] {-# INLINE detNotExpired #-} detNotExpired _time l = detNotExpired' _time l [] {-# INLINE detNotExpired' #-} detNotExpired' _time [] l = reverse l detNotExpired' time ((key, (accesstime, expirytime, _value)) : r) l | (accesstime <= time) && (accesstime > (time - expirytime)) = detNotExpired' time r (key:l) | otherwise = detNotExpired' time r l -- | Debugging function -- getStatsString ecm = do CacheState (_retr_state, _maps, _mapsize, uses, _incr) <- ro m'uses return $ show uses where ECM ( m'uses, _retr, _gettime, _minimumkeep, _timecheckmodulo, _removalsize, _compactlistsize, _enter, ro ) = ecm