diff --git a/src/Data/TTLHashTable.hs b/src/Data/TTLHashTable.hs --- a/src/Data/TTLHashTable.hs +++ b/src/Data/TTLHashTable.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GADTs, RecordWildCards #-} +{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, RecordWildCards #-} {- | Module: Data.TTLHashTable Description: Adds TTL entry expiration to the excellent mutable hash tables from the hashtables package @@ -34,6 +34,7 @@ -- hash tables in the ST monad aren't as well. If concurrent threads need to operate on the same -- table, you need to provide external means of synchronization to guarantee exclusive access -- to the table + TimeStamp, TTLHashTable, TTLHashTableError(..), Settings(..), @@ -93,10 +94,13 @@ gcMaxEntriesRef_ :: IORef Int } -> TTLHashTable h k v -data Value v = Value { expiresAt :: Int, +data Value v = Value { expiresAt :: TimeStamp, ttl :: Int, value :: v } +-- | A representation of a point in time, used to track entry lifetime. +newtype TimeStamp = TimeStamp Int deriving (Num, Integral, Real, Enum, Eq, Ord) + -- | 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 @@ -198,7 +202,7 @@ insertWithTTL ht@TTLHashTable {..} ttl k v = do numEntries <- liftIO $ readIORef numEntriesRef_ now <- getTimeStamp - let expiresAt = now + ttl * 1000000 -- to nanoseconds + let expiresAt = now + fromIntegral (ttl * 1000000) -- to nanoseconds maxSize <- liftIO $ readIORef maxSizeRef_ if numEntries < maxSize then insert' expiresAt @@ -210,7 +214,7 @@ liftIO $ do H.insert hashTable_ k value modifyIORef' numEntriesRef_ (+1) - modifyIORef' timeStampsRef_ $ M.insert expiresAt k + modifyIORef' timeStampsRef_ $ M.insert (fromIntegral expiresAt) k -- | like 'insertWithTTL' but ignores insertion failure insertWithTTL_ :: (Eq k, Hashable k, C.HashTable h, MonadIO m) @@ -222,17 +226,17 @@ insertWithTTL_ h ttl k = void . runMaybeT . insertWithTTL h ttl k -checkOldest :: (Eq k, Hashable k, MonadIO m) => TTLHashTable h k v -> Int -> m (Maybe ()) +checkOldest :: (Eq k, Hashable k, MonadIO m) => TTLHashTable h k v -> TimeStamp -> m (Maybe ()) checkOldest ht@TTLHashTable {..} now = liftIO . runMaybeT $ do (timeStamp, k) <- MaybeT . atomicModifyIORef' timeStampsRef_ $ \timeStamps -> case M.minViewWithKey timeStamps of Nothing -> (timeStamps, Nothing) Just ((timeStamp, k), timeStamps') -> - if timeStamp <= now + if (fromIntegral timeStamp) <= now then (timeStamps', Just (timeStamp, k)) else (timeStamps, Nothing) - MaybeT $ mutateWith (deleteExpired timeStamp) ht k + MaybeT $ mutateWith (deleteExpired $ fromIntegral 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 @@ -246,7 +250,13 @@ lookupAndRenew :: (Eq k, Hashable k, MonadIO m, Failable m) => TTLHashTable h k v -> k -> m v lookupAndRenew = lookup' True -lookupMaybeExpired :: (Eq k, Hashable k, MonadIO m, Failable m) => TTLHashTable h k v -> k -> m (v, Int) +-- | Perform a lookup without doing any actual checks to see if the entry is still alive or +-- if it has expired. Instead, the entry expiration timestamp is returned together with the +-- value (if found). The purpose of this function is to provide a manual way to check expiration, +-- for example when performing batch lookups or sacrificing lifetime resolution for the sake +-- of performance (and thus avoiding an expensive timestamp retrieval every time a lookup is +-- performed) +lookupMaybeExpired :: (Eq k, Hashable k, MonadIO m, Failable m) => TTLHashTable h k v -> k -> m (v, TimeStamp) lookupMaybeExpired TTLHashTable {..} k = maybe (failure NotFound) returnValue =<< liftIO (H.lookup hashTable_ k) where returnValue Value {..} = return (value, expiresAt) @@ -262,13 +272,13 @@ (mExpire, mValue) <- mutateWith (refreshEntry now) ht k removeTimeStamp mExpire Value {..} <- checkLookedUp mValue now - liftIO $ modifyIORef' timeStampsRef_ $ M.insert expiresAt k + liftIO $ modifyIORef' timeStampsRef_ $ M.insert (fromIntegral expiresAt) k return value where refreshEntry _ Nothing = (Nothing, (Nothing, Nothing)) refreshEntry now (Just v@Value{..}) = if expiresAt > now then - let v' = Value { expiresAt = now + ttl * 1000000, -- nanoseconds + let v' = Value { expiresAt = now + (fromIntegral ttl * 1000000), -- nanoseconds ttl = ttl, value = value } in (Just v', (Just expiresAt, Just v')) @@ -277,11 +287,11 @@ removeTimeStamp Nothing = return () removeTimeStamp (Just timeStamp) = - liftIO . modifyIORef' timeStampsRef_ $ M.delete timeStamp + liftIO . modifyIORef' timeStampsRef_ $ M.delete (fromIntegral timeStamp) checkLookedUp :: (MonadIO m, Failable m) => Maybe (Value v) - -> Int + -> TimeStamp -> m (Value v) checkLookedUp Nothing _ = failure NotFound checkLookedUp (Just v@Value {..}) now = @@ -301,10 +311,10 @@ delete ht@TTLHashTable {..} k = do timeStamp <- deleteWith $ \v -> (Nothing, v >>= return . expiresAt) - forM_ timeStamp $ liftIO . modifyIORef' timeStampsRef_ . M.delete + forM_ timeStamp $ liftIO . modifyIORef' timeStampsRef_ . M.delete . fromIntegral where deleteWith fun = mutateWith fun ht k -deleteExpired :: Int -> Maybe (Value v) -> (Maybe (Value v), Maybe ()) +deleteExpired :: TimeStamp -> Maybe (Value v) -> (Maybe (Value v), Maybe ()) deleteExpired _ Nothing = (Nothing, Nothing) deleteExpired timeStamp (Just v@Value {..}) = @@ -357,10 +367,10 @@ removeExpired' ht@TTLHashTable {..} gcMaxEntries = liftIO $ do now <- getTimeStamp - (n, expired) <- atomicModifyIORef' timeStampsRef_ $ selectedEntries now + (n, expired) <- atomicModifyIORef' timeStampsRef_ $ selectedEntries (fromIntegral now) Prelude.mapM_ remove expired return n - where remove (timeStamp, k) = mutateWith (deleteExpired timeStamp) ht k + where remove (timeStamp, k) = mutateWith (deleteExpired $ fromIntegral timeStamp) ht k selectedEntries now m = let (old, active) = M.split now m (selected, notYet) = splitAt gcMaxEntries $ M.toList old @@ -368,11 +378,13 @@ in (M.union active toReinsert, (n, selected)) countFromList (n, acc) (k, v) = (n + 1, M.insert k v acc) --- | Returns a timestamp value in nanoseconds -getTimeStamp :: (MonadIO m) => m Int +-- | Returns a timestamp for the current moment (__now__). This value can be used when +-- | comparing expiration times manually as returned by 'lookupMaybeExpired' for example, +-- | when it makes sense to do so in the name of performance. +getTimeStamp :: (MonadIO m) => m TimeStamp getTimeStamp = do (TimeSpec secs ns) <- liftIO $ getTime Monotonic - return . fromIntegral $ (secs * 1000000000 + ns) + return . fromIntegral $ secs * 1000000000 + ns -- | A strict fold in IO over the @(key, value)@ records in a hash table foldM :: (MonadIO m) => (a -> (k, v) -> IO a) -> a -> TTLHashTable h k v -> m a @@ -418,12 +430,14 @@ defaultTTL <- liftIO $ readIORef defaultTTLRef_ mutateWith (mutate' now defaultTTL f) ht k -mutate' :: Int -> Int -> (Maybe v -> (Maybe v, a)) -> Maybe (Value v) -> (Maybe (Value v), a) +mutate' :: TimeStamp -> Int -> (Maybe v -> (Maybe v, a)) -> Maybe (Value v) -> (Maybe (Value v), a) mutate' now defaultTTL f mV = let (expiresAt, ttl, mValue) = metaFrom mV vFrom mValue' = do value <- mValue' return Value {expiresAt = expiresAt, ttl = ttl, value = value } in first vFrom $ f mValue - where metaFrom Nothing = (now + defaultTTL * 1000000, defaultTTL, Nothing) - metaFrom (Just Value {..}) = (now + ttl * 1000000, ttl, Just value) + where metaFrom Nothing = + (now + fromIntegral (defaultTTL * 1000000), defaultTTL, Nothing) + metaFrom (Just Value {..}) = + (now + fromIntegral (ttl * 1000000), ttl, Just value) diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -16,7 +16,6 @@ withSizedRenewableTTLHashTable :: IO (TTLHashTable Cuckoo.HashTable Int String) withSizedRenewableTTLHashTable = newWithSettings def { maxSize = 2, - renewUponRead = True, defaultTTL = 100, gcMaxEntries = 1 } @@ -50,7 +49,7 @@ threadDelay 200000 -- wait 200 mS s' <- size ht s' `shouldBe` 2 - _ <- find ht 1 + _ <- runExceptT $ lookupAndRenew ht 1 s'' <- size ht s'' `shouldBe` 1 delete ht 2 @@ -107,14 +106,14 @@ \ht -> do insert ht 1 "foo" threadDelay 50000 -- wait 50 mS - _ <- find ht 1 + _ <- lookupAndRenew ht 1 threadDelay 50000 -- wait 50 mS - _ <- find ht 1 + _ <- lookupAndRenew ht 1 threadDelay 50000 -- wait 50 mS - _ <- find ht 1 + _ <- lookupAndRenew ht 1 threadDelay 50000 -- wait 50 mS - v <- find ht 1 - v `shouldBe` Just "foo" + v <- lookupAndRenew ht 1 + v `shouldBe` "foo" it "Checks that lookup doesn't renew expired entry" $ \ht -> do insert ht 1 "foo" 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: 3388338e9a83ada9651f2f035614cb640965e9628df50285184ab9166923e93a +-- hash: 4659935f4d42287b429b71c7213283dcc3e3c103e8d0527509ad3d1d73a4f6a1 name: ttl-hashtables -version: 1.4.0.0 +version: 1.4.1.0 synopsis: Extends hashtables so that entries added can be expired after a TTL description: This library extends fast mutable hashtables so that entries added can be expired after a given TTL (time to live). This TTL can be specified as a default property of the table or on a per entry basis. category: Data