ttl-hashtables 1.0.0.1 → 1.1.0.0
raw patch · 2 files changed
+52/−35 lines, 2 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- src/Data/TTLHashTable.hs +50/−33
- ttl-hashtables.cabal +2/−2
src/Data/TTLHashTable.hs view
@@ -52,7 +52,6 @@ import Prelude hiding (lookup) import Control.Exception (Exception) import Control.Monad (void)-import Control.Monad.Trans.Class (lift) import Control.Monad.Failable (Failable, failure) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)@@ -67,7 +66,6 @@ import Data.Tuple (swap) import Data.Typeable (Typeable) import System.Clock (Clock(Monotonic), TimeSpec(..), getTime)-import System.Mem.Weak (Weak, deRefWeak, mkWeak) import qualified Data.HashTable.Class as C import qualified Data.HashTable.IO as H@@ -79,7 +77,7 @@ => { hashTable_ :: H.IOHashTable h k (Value v), maxSize_ :: Int, numEntriesRef_ :: IORef Int,- timeStampsRef_ :: IORef (IntMap (Weak k)),+ timeStampsRef_ :: IORef (IntMap k), renewUponRead_ :: Bool, defaultTTL_ :: Int } -> TTLHashTable h k v@@ -182,8 +180,7 @@ liftIO $ do H.insert hashTable_ k value modifyIORef' numEntriesRef_ (+1)- wPtr <- mkWeak value k . Just . modifyIORef' timeStampsRef_ $ M.delete expiresAt- modifyIORef' timeStampsRef_ $ M.insert expiresAt wPtr+ modifyIORef' timeStampsRef_ $ M.insert expiresAt k -- | like 'insertWithTTL' but ignores insertion failure insertWithTTL_ :: (Eq k, Hashable k, C.HashTable h, MonadIO m)@@ -198,15 +195,14 @@ checkOldest :: (Eq k, Hashable k, MonadIO m) => TTLHashTable h k v -> Int -> m (Maybe ()) checkOldest ht@TTLHashTable {..} now = liftIO . runMaybeT $ do- wPtr <- MaybeT . atomicModifyIORef' timeStampsRef_ $ \timeStamps ->- case M.minViewWithKey timeStamps of- Nothing -> (timeStamps, Nothing)- Just ((timeStamp, wPtr), timeStamps') ->- if timeStamp <= now- then (timeStamps', Just wPtr)- else (timeStamps, Nothing)- k <- MaybeT $ deRefWeak wPtr- lift $ delete ht k+ (timeStamp, k) <- MaybeT . atomicModifyIORef' timeStampsRef_ $ \timeStamps ->+ case M.minViewWithKey timeStamps of+ Nothing -> (timeStamps, Nothing)+ Just ((timeStamp, k), timeStamps') ->+ if timeStamp <= now+ then (timeStamps', Just (timeStamp, k))+ else (timeStamps, Nothing)+ MaybeT $ mutateWith (deleteExpired timeStamp) ht k -- | Lookup a key in the hash table. If called straight in the IO monad it would throw a -- 'NotFound' exception, but if called under @MaybeT IO@ or @ExceptT SomeException IO@ it would@@ -220,20 +216,24 @@ Value {..} <- checkLookedUp ht k mValue now return value | otherwise = do- now <- getTimeStamp- mValue <- liftIO $ H.mutate hashTable_ k $ refreshEntry now- v@Value {..} <- checkLookedUp ht k mValue now- liftIO $ do- wPtr <- mkWeak v k $ Just . modifyIORef' timeStampsRef_ $ M.delete expiresAt- modifyIORef' timeStampsRef_ $ M.insert expiresAt wPtr- return value+ now <- getTimeStamp+ (mExpire, mValue) <- mutateWith (refreshEntry now) ht k+ removeTimeStamp mExpire+ Value {..} <- checkLookedUp ht k mValue now+ liftIO $ modifyIORef' timeStampsRef_ $ M.insert expiresAt k+ return value where refreshEntry _ Nothing =- (Nothing, Nothing)+ ((Nothing, 0), (Nothing, Nothing)) refreshEntry now (Just v@Value{..}) = if expiresAt > now then let v' = Value { expiresAt = now + ttl, ttl = ttl, value = value }- in (Just v', Just v')- else (Nothing, Just v)+ in ((Just v', 0), (Just expiresAt, Just v'))+ else+ ((Nothing, 1), (Nothing, Just v))+ removeTimeStamp Nothing =+ return ()+ removeTimeStamp (Just timeStamp) =+ liftIO . modifyIORef' timeStampsRef_ $ M.delete timeStamp checkLookedUp :: (Eq k, Hashable k, MonadIO m, C.HashTable h, Failable m) => TTLHashTable h k v@@ -258,12 +258,31 @@ -- | delete an entry from the hash table. delete :: (C.HashTable h, Eq k, Hashable k, MonadIO m) => TTLHashTable h k v -> k -> m ()-delete TTLHashTable {..} k =+delete = mutateWith simpleDeletion+ where simpleDeletion Nothing = ((Nothing, 0), ())+ simpleDeletion (Just Value {..}) = ((Nothing, 1), ())++deleteExpired :: Int -> Maybe (Value v) -> ((Maybe (Value v), Int), Maybe ())+deleteExpired _ Nothing =+ ((Nothing, 0), Nothing)+deleteExpired timeStamp (Just v@Value {..}) =+ if expiresAt == timeStamp+ then ((Nothing, 1), Just ())+ else ((Just v, 0), Nothing)++mutateWith :: (Eq k, Hashable k, MonadIO m)+ => (Maybe (Value v) -> ((Maybe (Value v), Int), a))+ -> TTLHashTable h k v+ -> k+ -> m a+mutateWith mutator TTLHashTable {..} k = liftIO $ do- n <- H.mutate hashTable_ k delete'- modifyIORef' numEntriesRef_ $ (flip (-) n)- where delete' Nothing = (Nothing, 0)- delete' (Just Value {..}) = (Nothing, 1)+ (n, result) <- H.mutate hashTable_ k mutate'+ modifyIORef' numEntriesRef_ $ flip (-) n+ return result+ where mutate' mValue =+ let ((mValue', n), result) = mutator mValue+ in (mValue', (n, result)) -- | Report the current number of entries in the table, including those who have expired but -- haven't been garbage collected yet@@ -279,10 +298,8 @@ liftIO $ do now <- getTimeStamp expired <- atomicModifyIORef' timeStampsRef_ $ swap . M.split now- mapM_ remove expired- where remove wPtr = runMaybeT $ do- k <- MaybeT $ deRefWeak wPtr- lift $ delete ht k+ mapM_ remove $ M.toList expired+ where remove (timeStamp, k) = mutateWith (deleteExpired timeStamp) ht k -- | Returns a timestamp value in milliseconds getTimeStamp :: (MonadIO m) => m Int
ttl-hashtables.cabal view
@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 12b473344fa79a34ea1d767912c95bbac53550ea37f2d59010ab598dfd289d63+-- hash: d0ffded13c137ec65c5ff23573ebdf5981db3de498cf050f97420d680241e357 name: ttl-hashtables-version: 1.0.0.1+version: 1.1.0.0 synopsis: Extends hashtables so that entries added can be expired after a TTL description: Please see the README on Gitlab at <https://gitlab.com/codemonkeylabs/ttl-hashtables#readme> category: Data