ttl-hashtables 1.2.2.0 → 1.3.0.0

raw patch · 3 files changed

+82/−24 lines, 3 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• src/Data/TTLHashTable.hs +58/−20
• test/Spec.hs +22/−2
• ttl-hashtables.cabal +2/−2

@@ -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)

@@ -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"

@@ -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 <https://gitlab.com/codemonkeylabs/ttl-hashtables#readme> category:       Data