ttl-hashtables (empty) → 1.0.0.0
raw patch · 7 files changed
+504/−0 lines, 7 filesdep +basedep +clockdep +containerssetup-changed
Dependencies added: base, clock, containers, data-default, failable, hashable, hashtables, hspec, mtl, transformers, ttl-hashtables
Files
- ChangeLog.md +3/−0
- LICENSE +30/−0
- README.md +1/−0
- Setup.hs +2/−0
- src/Data/TTLHashTable.hs +291/−0
- test/Spec.hs +113/−0
- ttl-hashtables.cabal +64/−0
+ ChangeLog.md view
@@ -0,0 +1,3 @@+# Changelog for ttl-hashtables++## Unreleased changes
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Erick Gonzalez (c) 2018++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Author name here nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,1 @@+# ttl-hashtables
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Data/TTLHashTable.hs view
@@ -0,0 +1,291 @@+{-# LANGUAGE GADTs, RecordWildCards #-}+{- |+Module: Data.TTLHashTable+Description: Adds TTL entry expiration to the excellent mutable hash tables from the hashtables package+Copyright: (c) Erick Gonzalez, 2019+License: BSD3+Maintainer: erick@codemonkeylabs.de++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.++-}+module Data.TTLHashTable (+-- * How to use this module:+-- |+-- Import one of the hash table modules from the hashtables package.. i.e. Basic, Cuckoo, etc+-- and "wrap" them in a TTLHashTable:+--+-- @+-- import Data.HashTable.ST.Basic as Basic+--+-- type HashTable k v = TTLHashTable Basic.HashTable k v+--+-- @+--+-- You can then use the functions in this module with this hashtable type. Note that the+-- functions in this module which can fail offer a flexible error handling strategy by virtue of+-- working in the context of a 'Failable' monad. So for example, if the function is used directly+-- in the IO monad and a failure occurs it would then result in an exception being thrown. However+-- if the context supports the possibiliy of failure like a 'MaybeT' or 'ExceptT'+-- transformer, it would then instead return something like @IO Nothing@ or @Left NotFound@+-- respectively (depending on the actual failure of course).+--+-- None of the functions in this module are thread safe, just as the underlying mutable+-- 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+ TTLHashTable,+ TTLHashTableError(..),+ Settings(..),+ insert,+ insert_,+ insertWithTTL,+ insertWithTTL_,+ delete,+ find,+ lookup,+ new,+ newWithSettings,+ removeExpired,+ size) where++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)+import Data.Default (Default, def)+import Data.Hashable (Hashable)+import Data.IntMap.Strict (IntMap)+import Data.IORef (IORef,+ atomicModifyIORef',+ modifyIORef',+ newIORef,+ readIORef)+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+import qualified Data.IntMap.Strict as M++-- | 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 (Weak k)),+ renewUponRead_ :: Bool,+ defaultTTL_ :: Int }+ -> TTLHashTable h k v++data Value v = Value { expiresAt :: Int,+ ttl :: Int,+ value :: v }++-- | 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+ -- will fail. Defaults to 'maxBound'+ maxSize :: Int,+ -- | Whether a succesful lookup of an entry means the TTL of the entry+ -- should be restarted. Default is 'False'+ renewUponRead :: Bool,+ -- | Default TTL value to be used for an entry if none is specified+ -- at insertion time+ defaultTTL :: 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+ deriving (Eq, Typeable, Show)++instance Exception TTLHashTableError++instance Default Settings where+ def = Settings { maxSize = maxBound,+ renewUponRead = False,+ defaultTTL = 365 * 24 * 60 * 60 * 1000 -- 1 year in milliseconds+ }++-- | Creates a new hash table with default settings+new :: (C.HashTable h, MonadIO m) => m (TTLHashTable h k v)+new = newWithSettings def++-- | Creates a new hash table with the specified settings. Use the 'Default' instance of 'Settings'+-- and then fine tune parameters as needed. I.e:+-- @+-- newWithSettings def { maxSize = 64 }+-- @+newWithSettings :: (C.HashTable h, MonadIO m) => Settings -> m (TTLHashTable h k v)+newWithSettings Settings {..} =+ 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+ }+ where newHT | maxSize == maxBound = H.new+ | otherwise = H.newSized maxSize++-- | Insert a new entry into the hash table. Take note of the fact that __this function can fail__+-- for example if table has reached maxSize entries for example. Failure is signaled depending on+-- the calling 'Failable' context. So for example if called in pure IO, it would throw a regular+-- IO exception (of type 'TTLHashTableError'). For this reason,+-- __you probably want to call this function in a 'MaybeT' or 'ExceptT' monad__+insert :: (Eq k, Hashable k, C.HashTable h, MonadIO m, Failable m)+ => TTLHashTable h k v+ -> k+ -> v+ -> m ()+insert ht@TTLHashTable {..} = insertWithTTL ht defaultTTL_++-- | 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+-- (or catching and ignoring the exception in the case of IO)+insert_ :: (Eq k, Hashable k, C.HashTable h, MonadIO m)+ => TTLHashTable h k v+ -> k+ -> v+ -> m ()+insert_ h k = void . runMaybeT . insert h k++-- | like 'insert' but an entry specific TTL can be provided+insertWithTTL :: (Eq k, Hashable k, C.HashTable h, MonadIO m, Failable m)+ => TTLHashTable h k v+ -> Int+ -> k+ -> v+ -> m ()+insertWithTTL ht@TTLHashTable {..} ttl k v = do+ numEntries <- liftIO $ readIORef numEntriesRef_+ now <- getTimeStamp+ let expiresAt = now + ttl+ if numEntries < maxSize_+ then insert' expiresAt+ else do+ madeSpace <- checkOldest ht now+ maybe (failure HashTableFull) (const $ insert' expiresAt) madeSpace+ where insert' expiresAt = do+ let value = Value expiresAt ttl v+ 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++-- | like 'insertWithTTL' but ignores insertion failure+insertWithTTL_ :: (Eq k, Hashable k, C.HashTable h, MonadIO m)+ => TTLHashTable h k v+ -> Int+ -> k+ -> v+ -> m ()+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 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++-- | 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+-- 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+ now <- getTimeStamp+ mValue <- liftIO $ H.lookup hashTable_ k+ 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+ where refreshEntry _ Nothing =+ (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)++checkLookedUp :: (Eq k, Hashable k, MonadIO m, C.HashTable h, Failable m)+ => TTLHashTable h k v+ -> k+ -> Maybe (Value v)+ -> Int+ -> m (Value v)+checkLookedUp _ _ Nothing _ = failure NotFound+checkLookedUp ht k (Just v@Value {..}) now =+ if expiresAt < now+ then do+ delete ht k+ failure ExpiredEntry+ else+ return v++-- | A lookup function which simply returns 'Maybe' wrapped in the calling 'MonadIO'+-- context, to accomodate the more conventional users+find :: (Eq k, Hashable k, MonadIO m) => TTLHashTable h k v -> k -> m (Maybe v)+find ht@TTLHashTable {..} k = do+ runMaybeT $ lookup ht k++-- | 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 =+ liftIO $ do+ n <- H.mutate hashTable_ k delete'+ modifyIORef' numEntriesRef_ $ (flip (-) n)+ where delete' Nothing = (Nothing, 0)+ delete' (Just Value {..}) = (Nothing, 1)++-- | Report the current number of entries in the table, including those who have expired but+-- haven't been garbage collected yet+size :: (MonadIO m) => TTLHashTable h k v -> m Int+size TTLHashTable {..} = liftIO $ readIORef numEntriesRef_++-- | Run garbage collection of expired entries in the table. Note that this function as well+-- as all other operations 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 ()+removeExpired ht@TTLHashTable {..} =+ 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++-- | Returns a timestamp value in milliseconds+getTimeStamp :: (MonadIO m) => m Int+getTimeStamp = do+ (TimeSpec secs ns) <- liftIO $ getTime Monotonic+ return . fromIntegral $ (secs * 1000000000 + ns) `div` 1000000
+ test/Spec.hs view
@@ -0,0 +1,113 @@+{-# LANGUAGE ScopedTypeVariables #-}+import Prelude hiding (lookup)+import Control.Concurrent (threadDelay)+import Control.Exception (Exception(..), SomeException(..))+import Control.Monad.Except (runExceptT)+import Control.Monad.Trans.Maybe (runMaybeT)+import Data.Default (Default, def)+import Data.TTLHashTable+import Test.Hspec++import qualified Data.HashTable.ST.Basic as Basic+import qualified Data.HashTable.ST.Cuckoo as Cuckoo++withUnlimitedTTLHashTable :: IO (TTLHashTable Basic.HashTable Int String)+withUnlimitedTTLHashTable = new++withSizedRenewableTTLHashTable :: IO (TTLHashTable Cuckoo.HashTable Int String)+withSizedRenewableTTLHashTable = newWithSettings def { maxSize = 2,+ renewUponRead = True,+ defaultTTL = 100 }++main :: IO ()+main = do+ hspec $ do+ before withUnlimitedTTLHashTable $+ describe "TTL Hash Table with default settings" $ do+ it "Checks that entries saved can be retrieved" $+ \ht -> do+ insert ht 1 "foo"+ v <- find ht 1+ v `shouldBe` Just "foo"+ it "Checks that entry expiration is observed" $+ \ht -> do+ insertWithTTL ht 100 1 "foo" -- TTL is 100 milliseconds+ v <- runMaybeT $ lookup ht 1+ v `shouldBe` Just "foo"+ threadDelay 200000 -- wait 200 mS+ v' <- runExceptT $ lookup ht 1+ v' `shouldSatisfy` hashTableError ExpiredEntry+ it "Checks that size is correctly reported" $+ \ht -> do+ insertWithTTL ht 100 1 "foo" -- TTL is 100 milliseconds+ insert ht 2 "bar"+ s <- size ht+ s `shouldBe` 2+ threadDelay 200000 -- wait 200 mS+ s' <- size ht+ s' `shouldBe` 2+ _ <- find ht 1+ s'' <- size ht+ s'' `shouldBe` 1+ delete ht 2+ s''' <- size ht+ s''' `shouldBe` 0+ it "Checks that lookup doesn't renew entry" $+ \ht -> do+ insertWithTTL ht 100 1 "foo"+ threadDelay 50000 -- wait 50 mS+ _ <- find ht 1+ threadDelay 50000 -- wait 50 mS+ _ <- find ht 1+ threadDelay 50000 -- wait 50 mS+ _ <- find ht 1+ threadDelay 50000 -- wait 50 mS+ v <- find ht 1+ v `shouldBe` Nothing+ it "Checks garbage collection" $+ \ht -> do+ insertWithTTL ht 100 2 "foo" -- TTL is 100 milliseconds+ threadDelay 200000 -- wait 200 mS+ removeExpired ht+ s <- size ht+ s `shouldBe` 0+ before withSizedRenewableTTLHashTable $+ describe "Renewable TTL Hash Table with max size" $ do+ it "Checks that max size is respected" $+ \ht -> do+ insert ht 1 "foo"+ insert ht 2 "bar"+ r <- runExceptT $ insert ht 3 "baz"+ r `shouldSatisfy` hashTableError HashTableFull+ it "Checks that lookup renews entry" $+ \ht -> do+ insert ht 1 "foo"+ threadDelay 50000 -- wait 50 mS+ _ <- find ht 1+ threadDelay 50000 -- wait 50 mS+ _ <- find ht 1+ threadDelay 50000 -- wait 50 mS+ _ <- find ht 1+ threadDelay 50000 -- wait 50 mS+ v <- find ht 1+ v `shouldBe` Just "foo"+ it "Checks that lookup doesn't renew expired entry" $+ \ht -> do+ insert ht 1 "foo"+ threadDelay 200000 -- 200 mS+ v <- runMaybeT $ lookup ht 1+ v `shouldBe` Nothing+ it "Checks that garbage collection works" $+ \ht -> do+ insertWithTTL ht 10000000 1 "foo"+ insert ht 2 "bar"+ threadDelay 200000+ removeExpired ht+ s <- size ht+ s `shouldBe` 1++hashTableError :: TTLHashTableError -> Either SomeException a -> Bool+hashTableError e (Left e') =+ case fromException e' of+ Just (err::TTLHashTableError) -> err == e+ _ -> False
+ ttl-hashtables.cabal view
@@ -0,0 +1,64 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.31.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: 8b787cdec9bbe0de3e2b19e184ee46f04b3cb35fd8ef7742da9903c542660ca5++name: ttl-hashtables+version: 1.0.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+author: Erick Gonzalez+maintainer: erick@codemonkeylabs.de+copyright: 2019 Erick Gonzalez+license: BSD3+license-file: LICENSE+build-type: Simple+extra-source-files:+ README.md+ ChangeLog.md++library+ exposed-modules:+ Data.TTLHashTable+ other-modules:+ Paths_ttl_hashtables+ hs-source-dirs:+ src+ ghc-options: -Wall+ build-depends:+ base >=4.7 && <5+ , clock+ , containers+ , data-default+ , failable+ , hashable+ , hashtables+ , mtl+ , transformers+ default-language: Haskell2010++test-suite ttl-hashtables-test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules:+ Paths_ttl_hashtables+ hs-source-dirs:+ test+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ base >=4.7 && <5+ , clock+ , containers+ , data-default+ , failable+ , hashable+ , hashtables+ , hspec+ , mtl+ , transformers+ , ttl-hashtables+ default-language: Haskell2010