diff --git a/src/Data/TTLHashTable.hs b/src/Data/TTLHashTable.hs --- a/src/Data/TTLHashTable.hs +++ b/src/Data/TTLHashTable.hs @@ -44,10 +44,12 @@ delete, find, foldM, + getSettings, Data.TTLHashTable.mapM_, lookup, new, newWithSettings, + reconfigure, removeExpired, size) where @@ -65,7 +67,8 @@ atomicModifyIORef', modifyIORef', newIORef, - readIORef) + readIORef, + writeIORef) import Data.Typeable (Typeable) import System.Clock (Clock(..), TimeSpec(..), getTime) @@ -76,13 +79,13 @@ -- | The TTL hash table type, parameterized on the type of table, key and value. data TTLHashTable h k v where TTLHashTable :: (C.HashTable h) - => { hashTable_ :: H.IOHashTable h k (Value v), - maxSize_ :: Int, - numEntriesRef_ :: IORef Int, - timeStampsRef_ :: IORef (IntMap k), - renewUponRead_ :: Bool, - defaultTTL_ :: Int, - gcMaxEntries_ :: Int } + => { hashTable_ :: H.IOHashTable h k (Value v), + maxSizeRef_ :: IORef Int, + numEntriesRef_ :: IORef Int, + timeStampsRef_ :: IORef (IntMap k), + renewUponReadRef_ :: IORef Bool, + defaultTTLRef_ :: IORef Int, + gcMaxEntriesRef_ :: IORef Int } -> TTLHashTable h k v data Value v = Value { expiresAt :: Int, @@ -107,11 +110,13 @@ gcMaxEntries :: Int } -- | Exception type used to report failures (depending on calling context) -data TTLHashTableError = NotFound -- ^ The entry was not found in the table - | ExpiredEntry -- ^ The entry did exist but is no longer valid - | HashTableFull -- ^ The maximum size for the table has been reached - | UnsupportedPlatform String -- ^ The platform is not supported - deriving (Eq, Typeable, Show) +data TTLHashTableError = + NotFound -- ^ The entry was not found in the table + | ExpiredEntry -- ^ The entry did exist but is no longer valid + | HashTableFull -- ^ The maximum size for the table has been reached + | UnsupportedPlatform String -- ^ The platform is not supported + | HashTableTooLarge -- ^ The hash table is too large for the provided settings + deriving (Eq, Typeable, Show) instance Exception TTLHashTableError @@ -142,16 +147,20 @@ newWithSettings Settings {..} = do assertIntSize liftIO $ do - table <- newHT - sRef <- newIORef 0 - tRef <- newIORef M.empty - return TTLHashTable { hashTable_ = table, - maxSize_ = maxSize, - numEntriesRef_ = sRef, - timeStampsRef_ = tRef, - renewUponRead_ = renewUponRead, - defaultTTL_ = defaultTTL, - gcMaxEntries_ = gcMaxEntries + table <- newHT + sRef <- newIORef 0 + tRef <- newIORef M.empty + msRef <- newIORef maxSize + rurRef <- newIORef renewUponRead + dTTLRef <- newIORef defaultTTL + meRef <- newIORef gcMaxEntries + return TTLHashTable { hashTable_ = table, + maxSizeRef_ = msRef, + numEntriesRef_ = sRef, + timeStampsRef_ = tRef, + renewUponReadRef_ = rurRef, + defaultTTLRef_ = dTTLRef, + gcMaxEntriesRef_ = meRef } where newHT | maxSize == maxBound = H.new | otherwise = H.newSized maxSize @@ -166,7 +175,9 @@ -> k -> v -> m () -insert ht@TTLHashTable {..} = insertWithTTL ht defaultTTL_ +insert ht@TTLHashTable {..} k v = do + ttl <- liftIO $ readIORef defaultTTLRef_ + insertWithTTL ht ttl k v -- | Just like 'insert' but doesn't result in a failure if the insertion doesn't succeed. -- It just saves you from ignoring the return code returned from 'insert' manually @@ -189,7 +200,8 @@ numEntries <- liftIO $ readIORef numEntriesRef_ now <- getTimeStamp let expiresAt = now + ttl * 1000000 -- to nanoseconds - if numEntries < maxSize_ + maxSize <- liftIO $ readIORef maxSizeRef_ + if numEntries < maxSize then insert' expiresAt else do madeSpace <- checkOldest ht now @@ -228,13 +240,17 @@ -- return @IO Nothing@ or @IO (Left NotFound)@ respectively. So you probably want to -- __execute this function in one of these transformer monads__ lookup :: (Eq k, Hashable k, MonadIO m, Failable m) => TTLHashTable h k v -> k -> m v -lookup ht@TTLHashTable {..} k - | not renewUponRead_ = do +lookup ht@TTLHashTable {..} k = do + renewUponRead <- liftIO $ readIORef renewUponReadRef_ + lookup' ht renewUponRead k + +lookup' :: (Eq k, Hashable k, MonadIO m, Failable m) => TTLHashTable h k v -> Bool -> k -> m v +lookup' ht@TTLHashTable {..} False k = do now <- getTimeStamp mValue <- liftIO $ H.lookup hashTable_ k Value {..} <- checkLookedUp ht k mValue now return value - | otherwise = do +lookup' ht@TTLHashTable {..} True k = do now <- getTimeStamp (mExpire, mValue) <- mutateWith (refreshEntry now) ht k removeTimeStamp mExpire @@ -316,7 +332,12 @@ -- 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 {..} = +removeExpired ht@TTLHashTable {..} = do + gcMaxEntries <- liftIO $ readIORef gcMaxEntriesRef_ + removeExpired' ht gcMaxEntries + +removeExpired' :: (MonadIO m, Eq k, Hashable k) => TTLHashTable h k v -> Int -> m Int +removeExpired' ht@TTLHashTable {..} gcMaxEntries = liftIO $ do now <- getTimeStamp (n, expired) <- atomicModifyIORef' timeStampsRef_ $ selectedEntries now @@ -325,7 +346,7 @@ 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 + (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) @@ -345,3 +366,25 @@ mapM_ :: (MonadIO m) => ((k, v) -> IO a) -> TTLHashTable h k v -> m () mapM_ f TTLHashTable {..} = liftIO $ H.mapM_ f' hashTable_ where f' (k, Value {..}) = f (k, value) + +-- | Provide a new set of settings for a given hash table +reconfigure :: (MonadIO m, Failable m) => TTLHashTable h k v -> Settings -> m () +reconfigure TTLHashTable {..} Settings {..} = do + numEntries <- liftIO $ readIORef numEntriesRef_ + when (numEntries > maxSize) $ failure HashTableTooLarge + liftIO $ do + writeIORef maxSizeRef_ maxSize + writeIORef renewUponReadRef_ renewUponRead + writeIORef defaultTTLRef_ defaultTTL + writeIORef gcMaxEntriesRef_ gcMaxEntries + +getSettings :: (MonadIO m) => TTLHashTable h k v -> m Settings +getSettings TTLHashTable {..} = liftIO $ do + maxSize <- readIORef maxSizeRef_ + renewUponRead <- readIORef renewUponReadRef_ + defaultTTL <- readIORef defaultTTLRef_ + gcMaxEntries <- readIORef gcMaxEntriesRef_ + return Settings { maxSize = maxSize, + renewUponRead = renewUponRead, + defaultTTL = defaultTTL, + gcMaxEntries = gcMaxEntries } 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: 65615fa7b0bf5fdbc5d34448bd6b00132bfecbbdb8d68e7e67cd0c7e727b0464 +-- hash: 7f24064c13cfbd206d12c76b27fd473341e87ce71c17f45f0561136bb2302ac8 name: ttl-hashtables -version: 1.2.1.0 +version: 1.2.2.0 synopsis: Extends hashtables so that entries added can be expired after a TTL description: Please see the README on Gitlab at category: Data