diff --git a/src/Data/TTLHashTable.hs b/src/Data/TTLHashTable.hs --- a/src/Data/TTLHashTable.hs +++ b/src/Data/TTLHashTable.hs @@ -63,7 +63,6 @@ modifyIORef', newIORef, readIORef) -import Data.Tuple (swap) import Data.Typeable (Typeable) import System.Clock (Clock(Monotonic), TimeSpec(..), getTime) @@ -79,7 +78,8 @@ numEntriesRef_ :: IORef Int, timeStampsRef_ :: IORef (IntMap k), renewUponRead_ :: Bool, - defaultTTL_ :: Int } + defaultTTL_ :: Int, + gcMaxEntries_ :: Int } -> TTLHashTable h k v data Value v = Value { expiresAt :: Int, @@ -89,14 +89,19 @@ -- | The 'Settings' type allows for specifying how the hash table should behave. data Settings = Settings { -- | Maximum size of the hash table. Once reached, insertion of keys - -- will fail. Defaults to 'maxBound' + -- will fail. Defaults to @maxBound@ maxSize :: Int, -- | Whether a succesful lookup of an entry means the TTL of the entry -- should be restarted. Default is 'False' renewUponRead :: Bool, -- | Default TTL value to be used for an entry if none is specified -- at insertion time - defaultTTL :: Int } + defaultTTL :: Int, + -- | Maximum number of entries that can be garbage collected in one + -- single call to removeExpired. This setting is provided so that + -- the possibility of long running garbage collection can be managed + -- by the user of the library. Default is @maxBound@ + gcMaxEntries :: Int } -- | Exception type used to report failures (depending on calling context) data TTLHashTableError = NotFound -- ^ The entry was not found in the table @@ -109,7 +114,8 @@ instance Default Settings where def = Settings { maxSize = maxBound, renewUponRead = False, - defaultTTL = 365 * 24 * 60 * 60 * 1000 -- 1 year in milliseconds + defaultTTL = 365 * 24 * 60 * 60 * 1000, -- 1 year in milliseconds + gcMaxEntries = maxBound } -- | Creates a new hash table with default settings @@ -132,7 +138,8 @@ numEntriesRef_ = sRef, timeStampsRef_ = tRef, renewUponRead_ = renewUponRead, - defaultTTL_ = defaultTTL + defaultTTL_ = defaultTTL, + gcMaxEntries_ = gcMaxEntries } where newHT | maxSize == maxBound = H.new | otherwise = H.newSized maxSize @@ -289,17 +296,25 @@ size :: (MonadIO m) => TTLHashTable h k v -> m Int size TTLHashTable {..} = liftIO $ readIORef numEntriesRef_ --- | Run garbage collection of expired entries in the table. Note that this function as well --- as all other operations in a hash table are __not__ thread safe. If concurrent threads --- need to operate on the table, some concurrency primitive must be used to guarantee exclusive --- access. -removeExpired :: (MonadIO m, Eq k, Hashable k) => TTLHashTable h k v -> m () +-- | Run garbage collection of expired entries in the table. It returns the number of expired +-- entries left yet to be removed from the table, if the 'gcMaxEntries' limit was reached before +-- finishing cleaning up all old entries. Note that this function as well as all other operations +-- in a hash table are __not__ thread safe. If concurrent threads need to operate on the table, +-- some concurrency primitive must be used to guarantee exclusive access. +removeExpired :: (MonadIO m, Eq k, Hashable k) => TTLHashTable h k v -> m Int removeExpired ht@TTLHashTable {..} = liftIO $ do - now <- getTimeStamp - expired <- atomicModifyIORef' timeStampsRef_ $ swap . M.split now - mapM_ remove $ M.toList expired + now <- getTimeStamp + (n, expired) <- atomicModifyIORef' timeStampsRef_ $ selectedEntries now + mapM_ remove expired + return n where remove (timeStamp, k) = mutateWith (deleteExpired timeStamp) ht k + selectedEntries now m = + let (old, active) = M.split now m + (selected, notYet) = splitAt gcMaxEntries_ $ M.toList old + (n, toReinsert) = foldl countFromList (0, M.empty) notYet + in (M.union active toReinsert, (n, selected)) + countFromList (n, acc) (k, v) = (n + 1, M.insert k v acc) -- | Returns a timestamp value in milliseconds getTimeStamp :: (MonadIO m) => m Int diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -17,7 +17,8 @@ withSizedRenewableTTLHashTable :: IO (TTLHashTable Cuckoo.HashTable Int String) withSizedRenewableTTLHashTable = newWithSettings def { maxSize = 2, renewUponRead = True, - defaultTTL = 100 } + defaultTTL = 100, + gcMaxEntries = 1 } main :: IO () main = do @@ -102,9 +103,23 @@ insertWithTTL ht 10000000 1 "foo" insert ht 2 "bar" threadDelay 200000 - removeExpired ht + left <- removeExpired ht s <- size ht s `shouldBe` 1 + left `shouldBe` 0 + it "Checks that maxGCEntries limit is observed" $ + \ht -> do + insert ht 1 "foo" + insert ht 2 "bar" + threadDelay 200000 + left <- removeExpired ht + s <- size ht + s `shouldBe` 1 + left `shouldBe` 1 + left' <- removeExpired ht + s' <- size ht + s' `shouldBe` 0 + left' `shouldBe` 0 hashTableError :: TTLHashTableError -> Either SomeException a -> Bool hashTableError e (Left e') = diff --git a/ttl-hashtables.cabal b/ttl-hashtables.cabal --- a/ttl-hashtables.cabal +++ b/ttl-hashtables.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: d0ffded13c137ec65c5ff23573ebdf5981db3de498cf050f97420d680241e357 +-- hash: 3fc54c5635761c9454d4730b7ce9c2b5e4bcdc1e8e96c1ea77312c7c0e0c54ea name: ttl-hashtables -version: 1.1.0.0 +version: 1.2.0.0 synopsis: Extends hashtables so that entries added can be expired after a TTL description: Please see the README on Gitlab at category: Data