diff --git a/src/Data/TTLHashTable.hs b/src/Data/TTLHashTable.hs --- a/src/Data/TTLHashTable.hs +++ b/src/Data/TTLHashTable.hs @@ -43,6 +43,8 @@ insertWithTTL_, delete, find, + foldM, + Data.TTLHashTable.mapM_, lookup, new, newWithSettings, @@ -51,10 +53,11 @@ import Prelude hiding (lookup) import Control.Exception (Exception) -import Control.Monad (void) +import Control.Monad (void, when) import Control.Monad.Failable (Failable, failure) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) +import Data.Bits (finiteBitSize) import Data.Default (Default, def) import Data.Hashable (Hashable) import Data.IntMap.Strict (IntMap) @@ -64,7 +67,7 @@ newIORef, readIORef) import Data.Typeable (Typeable) -import System.Clock (Clock(Monotonic), TimeSpec(..), getTime) +import System.Clock (Clock(..), TimeSpec(..), getTime) import qualified Data.HashTable.Class as C import qualified Data.HashTable.IO as H @@ -94,8 +97,8 @@ -- | 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 + -- | Default TTL value in milliseconds to be used for an entry if none + -- is specified at insertion time defaultTTL :: Int, -- | Maximum number of entries that can be garbage collected in one -- single call to removeExpired. This setting is provided so that @@ -107,6 +110,7 @@ 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 + | UnsupportedPlatform String -- ^ The platform is not supported deriving (Eq, Typeable, Show) instance Exception TTLHashTableError @@ -118,8 +122,15 @@ gcMaxEntries = maxBound } +assertIntSize :: (Failable m) => m () +assertIntSize = + when (finiteBitSize maxInt < 64) $ + failure $ UnsupportedPlatform "Int size on this platform is < 64 bits" + where maxInt = maxBound :: Int + + -- | Creates a new hash table with default settings -new :: (C.HashTable h, MonadIO m) => m (TTLHashTable h k v) +new :: (C.HashTable h, MonadIO m, Failable m) => m (TTLHashTable h k v) new = newWithSettings def -- | Creates a new hash table with the specified settings. Use the 'Default' instance of 'Settings' @@ -127,8 +138,9 @@ -- @ -- newWithSettings def { maxSize = 64 } -- @ -newWithSettings :: (C.HashTable h, MonadIO m) => Settings -> m (TTLHashTable h k v) -newWithSettings Settings {..} = +newWithSettings :: (C.HashTable h, MonadIO m, Failable m) => Settings -> m (TTLHashTable h k v) +newWithSettings Settings {..} = do + assertIntSize liftIO $ do table <- newHT sRef <- newIORef 0 @@ -166,7 +178,7 @@ -> m () insert_ h k = void . runMaybeT . insert h k --- | like 'insert' but an entry specific TTL can be provided +-- | like 'insert' but an entry specific TTL in milliseconds can be provided. insertWithTTL :: (Eq k, Hashable k, C.HashTable h, MonadIO m, Failable m) => TTLHashTable h k v -> Int @@ -176,7 +188,7 @@ insertWithTTL ht@TTLHashTable {..} ttl k v = do numEntries <- liftIO $ readIORef numEntriesRef_ now <- getTimeStamp - let expiresAt = now + ttl + let expiresAt = now + ttl * 1000000 -- to nanoseconds if numEntries < maxSize_ then insert' expiresAt else do @@ -233,7 +245,9 @@ ((Nothing, 0), (Nothing, Nothing)) refreshEntry now (Just v@Value{..}) = if expiresAt > now then - let v' = Value { expiresAt = now + ttl, ttl = ttl, value = value } + let v' = Value { expiresAt = now + ttl * 1000000, -- nanoseconds + ttl = ttl, + value = value } in ((Just v', 0), (Just expiresAt, Just v')) else ((Nothing, 1), (Nothing, Just v)) @@ -306,7 +320,7 @@ liftIO $ do now <- getTimeStamp (n, expired) <- atomicModifyIORef' timeStampsRef_ $ selectedEntries now - mapM_ remove expired + Prelude.mapM_ remove expired return n where remove (timeStamp, k) = mutateWith (deleteExpired timeStamp) ht k selectedEntries now m = @@ -316,8 +330,18 @@ in (M.union active toReinsert, (n, selected)) countFromList (n, acc) (k, v) = (n + 1, M.insert k v acc) --- | Returns a timestamp value in milliseconds +-- | Returns a timestamp value in nanoseconds getTimeStamp :: (MonadIO m) => m Int getTimeStamp = do (TimeSpec secs ns) <- liftIO $ getTime Monotonic - return . fromIntegral $ (secs * 1000000000 + ns) `div` 1000000 + 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 +foldM f x TTLHashTable {..} = liftIO . H.foldM f' x $ hashTable_ + where f' acc (k, Value {..}) = f acc (k, value) + +-- | A side-effecting map over the @(key, value)@ records in a hash table +mapM_ :: (MonadIO m) => ((k, v) -> IO a) -> TTLHashTable h k v -> m () +mapM_ f TTLHashTable {..} = liftIO $ H.mapM_ f' hashTable_ + where f' (k, Value {..}) = f (k, value) diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -20,6 +20,9 @@ defaultTTL = 100, gcMaxEntries = 1 } +withIntHashTable :: IO (TTLHashTable Basic.HashTable Int Int) +withIntHashTable = new + main :: IO () main = do hspec $ do @@ -120,6 +123,14 @@ s' <- size ht s' `shouldBe` 0 left' `shouldBe` 0 + before withIntHashTable $ + describe "A hash table with integer values" $ do + it "Checks folding" $ + \ht -> do + insert ht 1 2 + insert ht 2 3 + r <- foldM (\a -> return . (a +) . snd) 0 ht + r `shouldBe` 5 hashTableError :: TTLHashTableError -> Either SomeException a -> Bool hashTableError e (Left e') = 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: 3fc54c5635761c9454d4730b7ce9c2b5e4bcdc1e8e96c1ea77312c7c0e0c54ea +-- hash: 65615fa7b0bf5fdbc5d34448bd6b00132bfecbbdb8d68e7e67cd0c7e727b0464 name: ttl-hashtables -version: 1.2.0.0 +version: 1.2.1.0 synopsis: Extends hashtables so that entries added can be expired after a TTL description: Please see the README on Gitlab at category: Data