diff --git a/src/Data/TTLHashTable.hs b/src/Data/TTLHashTable.hs --- a/src/Data/TTLHashTable.hs +++ b/src/Data/TTLHashTable.hs @@ -47,6 +47,7 @@ getSettings, Data.TTLHashTable.mapM_, lookup, + mutate, new, newWithSettings, reconfigure, @@ -56,9 +57,11 @@ import Prelude hiding (lookup) import Control.Exception (Exception) import Control.Monad (void, when) +import Control.Monad.Except (runExcept, throwError) import Control.Monad.Failable (Failable, failure) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) +import Data.Bifunctor (first) import Data.Bits (finiteBitSize) import Data.Default (Default, def) import Data.Hashable (Hashable) @@ -258,15 +261,15 @@ liftIO $ modifyIORef' timeStampsRef_ $ M.insert expiresAt k return value where refreshEntry _ Nothing = - ((Nothing, 0), (Nothing, Nothing)) + (Nothing, (Nothing, Nothing)) refreshEntry now (Just v@Value{..}) = if expiresAt > now then let v' = Value { expiresAt = now + ttl * 1000000, -- nanoseconds ttl = ttl, value = value } - in ((Just v', 0), (Just expiresAt, Just v')) + in (Just v', (Just expiresAt, Just v')) else - ((Nothing, 1), (Nothing, Just v)) + (Nothing, (Nothing, Just v)) removeTimeStamp Nothing = return () removeTimeStamp (Just timeStamp) = @@ -295,31 +298,41 @@ -- | delete an entry from the hash table. delete :: (C.HashTable h, Eq k, Hashable k, MonadIO m) => TTLHashTable h k v -> k -> m () -delete = mutateWith simpleDeletion - where simpleDeletion Nothing = ((Nothing, 0), ()) - simpleDeletion (Just Value {..}) = ((Nothing, 1), ()) +delete = ((.).(.)) (void . runMaybeT) (mutateWith (\_ -> (Nothing, ()))) -deleteExpired :: Int -> Maybe (Value v) -> ((Maybe (Value v), Int), Maybe ()) +deleteExpired :: Int -> Maybe (Value v) -> (Maybe (Value v), Maybe ()) deleteExpired _ Nothing = - ((Nothing, 0), Nothing) + (Nothing, Nothing) deleteExpired timeStamp (Just v@Value {..}) = if expiresAt == timeStamp - then ((Nothing, 1), Just ()) - else ((Just v, 0), Nothing) + then (Nothing, Just ()) + else (Just v, Nothing) -mutateWith :: (Eq k, Hashable k, MonadIO m) - => (Maybe (Value v) -> ((Maybe (Value v), Int), a)) +mutateWith :: (Eq k, Hashable k, MonadIO m, Failable m) + => (Maybe (Value v) -> (Maybe (Value v), a)) -> TTLHashTable h k v -> k -> m a -mutateWith mutator TTLHashTable {..} k = - liftIO $ do - (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)) +mutateWith mutator TTLHashTable {..} k = do + iResult <- liftIO $ do + numEntries <- readIORef numEntriesRef_ + maxSize <- readIORef maxSizeRef_ + H.mutate hashTable_ k $ mutate_ numEntries maxSize + flip (either failure) iResult $ \(n, result) -> do + liftIO $ modifyIORef' numEntriesRef_ $ (+) n + return result + where mutate_ numEntries maxSize mValue = + let (mValue', result) = mutator mValue + result' = runExcept $ do + n <- case (mValue, mValue') of + (Nothing, Just _) -> do + if numEntries < maxSize + then return 1 + else throwError HashTableFull + (Just _, Nothing) -> return (-1) + _ -> return 0 + return (n, result) + in either (\_ -> (mValue, result')) (\_ -> (mValue', result')) result' -- | Report the current number of entries in the table, including those who have expired but -- haven't been garbage collected yet @@ -388,3 +401,28 @@ renewUponRead = renewUponRead, defaultTTL = defaultTTL, gcMaxEntries = gcMaxEntries } + +-- | mutate an entry with the provided modification function. The tuple returned corresponds +-- to the new value mapped to the key and a result to return from the mutate operation. Note +-- that if the new value is @Nothing@ then the entry is deleted if it exists or no change is +-- performed if it didn't. If the value is @Just v@ then the value is replaced or inserted +-- depending on whether it was found or not respectively for that key. +mutate :: (Eq k, Hashable k, MonadIO m, Failable m) + => TTLHashTable h k v + -> k + -> (Maybe v -> (Maybe v, a)) + -> m a +mutate ht@TTLHashTable {..} k f = do + now <- getTimeStamp + 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' 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) diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -4,7 +4,7 @@ import Control.Exception (Exception(..), SomeException(..)) import Control.Monad.Except (runExceptT) import Control.Monad.Trans.Maybe (runMaybeT) -import Data.Default (Default, def) +import Data.Default (def) import Data.TTLHashTable import Test.Hspec @@ -72,9 +72,25 @@ \ht -> do insertWithTTL ht 100 2 "foo" -- TTL is 100 milliseconds threadDelay 200000 -- wait 200 mS - removeExpired ht + left <- removeExpired ht + left `shouldBe` 0 s <- size ht s `shouldBe` 0 + it "Checks mutation" $ + \ht -> do + mutate ht 1 $ \_ -> (Just "foo", ()) + s <- size ht + s `shouldBe` 1 + mutate ht 1 $ \(Just "foo") -> (Just "bar", ()) + s' <- size ht + s' `shouldBe` 1 + v <- find ht 1 + v `shouldBe` Just "bar" + mutate ht 1 $ \(Just "bar") -> (Nothing, ()) + s'' <- size ht + s'' `shouldBe` 0 + v' <- find ht 1 + v' `shouldBe` Nothing before withSizedRenewableTTLHashTable $ describe "Renewable TTL Hash Table with max size" $ do it "Checks that max size is respected" $ @@ -83,6 +99,10 @@ insert ht 2 "bar" r <- runExceptT $ insert ht 3 "baz" r `shouldSatisfy` hashTableError HashTableFull + r' <- runExceptT $ mutate ht 3 $ \Nothing -> (Just "baz", ()) + r' `shouldSatisfy` hashTableError HashTableFull + s <- size ht + s `shouldBe` 2 it "Checks that lookup renews 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: 7f24064c13cfbd206d12c76b27fd473341e87ce71c17f45f0561136bb2302ac8 +-- hash: 6d188e88f27e2de1091cb1fb49b9690c340c15938c684dcb0081715cfebe48b9 name: ttl-hashtables -version: 1.2.2.0 +version: 1.3.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