cache (empty) → 0.1.0.0
raw patch · 6 files changed
+396/−0 lines, 6 filesdep +basedep +cachedep +clocksetup-changed
Dependencies added: base, cache, clock, hashable, hspec, stm, transformers, unordered-containers
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- cache.cabal +51/−0
- src/Data/Cache.hs +209/−0
- test/Data/CacheSpec.hs +103/−0
- test/Spec.hs +1/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Henri Verroken (c) 2016++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 Henri Verroken 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ cache.cabal view
@@ -0,0 +1,51 @@+name: cache+version: 0.1.0.0+synopsis: An in-memory key/value store with expiration support+homepage: https://github.com/hverr/haskell-cache#readme+license: BSD3+license-file: LICENSE+author: Henri Verroken+maintainer: henriverroken@gmail.com+copyright: 2016 Henri Verroken+category: Data, Cache+build-type: Simple+cabal-version: >= 1.10+tested-with: GHC == 7.10.3, GHC == 8.0.1+homepage: https://github.com/hverr/haskell-cache+bug-reports: https://github.com/hverr/haskell-cache/issues+description:+ An in-memory key/value store with expiration support, similar+ to patrickmn/go-cache for Go.+ .+ The cache is a shared mutable HashMap implemented using STM and+ with support for expiration times.++library+ ghc-options: -Wall+ hs-source-dirs: src+ exposed-modules: Data.Cache+ build-depends: base >= 4.8 && < 5+ , clock >= 0.7 && < 0.8+ , hashable >= 1.0.1.1+ , stm >= 2.2 && < 3+ , transformers >= 0.4.2 && < 0.6+ , unordered-containers >= 0.2.2 && < 0.3+ default-language: Haskell2010++test-suite cache-test+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Spec.hs+ other-modules: Data.CacheSpec+ build-depends: base+ , cache+ , clock+ , hspec+ , stm+ , transformers+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ default-language: Haskell2010++source-repository head+ type: git+ location: https://github.com/hverr/cache
+ src/Data/Cache.hs view
@@ -0,0 +1,209 @@+-- |+-- Module: Data.Cache+-- Copyright: (c) 2016 Henri Verroken+-- LIcense: BSD3+-- Maintainer: Henri Verroken <henriverroken@gmail.com>+-- Stability: experimental+--+-- An in-memory key/value store with expiration support, similar+-- to patrickmn/go-cache for GO.+--+-- The cache is a shard mutable HashMap implemented using STM. It+-- supports item expiration.++module Data.Cache (+ -- * How to use this library+ -- $use++ -- * Creating a cache+ Cache+ , newCache++ -- * Cache properties+ , defaultExpiration+ , setDefaultExpiration+ , copyCache++ -- * Managing items+ -- ** Insertion+ , insert+ , insert'+ -- ** Querying+ , lookup+ , lookup'+ , keys+ -- ** Deletion+ , delete+ , purgeExpired++ -- * Cache information+ , size+) where++import Prelude hiding (lookup)++import Control.Concurrent.STM+import Control.Monad+import Control.Monad.Trans.Maybe+import qualified Data.HashMap.Strict as HM+import Data.Hashable+import Data.Maybe+import System.Clock++-- | The cache with keys of type @k@ and values of type @v@.+--+-- Create caches with the 'newCache' and 'copyCache' functions.+data Cache k v = Cache {+ container :: TVar (HM.HashMap k (CacheItem v))+ -- | The default expiration value of newly added cache items.+ --+ -- See 'newCache' for more information on the default expiration value.+ , defaultExpiration :: Maybe TimeSpec+}++-- | Change the default expiration value of newly added cache items.+--+-- See 'newCache' for more information on the default expiration value.+setDefaultExpiration :: Cache k v -> Maybe TimeSpec -> Cache k v+setDefaultExpiration c t = c { defaultExpiration = t }++data CacheItem v = CacheItem {+ item :: v+ , itemExpiration :: Maybe TimeSpec+}++isExpired :: TimeSpec -> CacheItem v -> Bool+isExpired t i = fromMaybe False (itemExpiration i >>= f t)+ where f now' e+ | e < now' = Just True+ | otherwise = Just False++newCacheSTM :: Maybe TimeSpec -> STM (Cache k v)+newCacheSTM d = do+ m <- newTVar HM.empty+ return Cache { container = m, defaultExpiration = d }++-- | Create a new cache with a default expiration value for newly+-- added cache items.+--+-- Items that are added to the cache without an explicit expiration value+-- (using 'insert') will be inserted with the default expiration value.+--+-- If the specified default expiration value is `Nothing`, items inserted+-- by 'insert' will never expire.+newCache :: Maybe TimeSpec -> IO (Cache k v)+newCache = atomically . newCacheSTM++copyCacheSTM :: Cache k v -> STM (Cache k v)+copyCacheSTM c = do+ m <- newTVar =<< readTVar (container c)+ return c { container = m }++-- | Create a deep copy of the cache.+copyCache :: Cache k v -> IO (Cache k v)+copyCache = atomically . copyCacheSTM++sizeSTM :: Cache k v -> STM Int+sizeSTM c = HM.size <$> readTVar (container c)++-- | Return the size of the cache, including expired items.+size :: Cache k v -> IO Int+size = atomically . sizeSTM++deleteSTM :: (Eq k, Hashable k) => k -> Cache k v -> STM ()+deleteSTM k c = writeTVar v =<< (HM.delete k <$> readTVar v) where v = container c++-- | Delete an item from the cache. Won't do anything if the item is not present.+delete :: (Eq k, Hashable k) => Cache k v -> k -> IO ()+delete c k = atomically $ deleteSTM k c++lookupItem' :: (Eq k, Hashable k) => k -> Cache k v -> STM (Maybe (CacheItem v))+lookupItem' k c = HM.lookup k <$> readTVar (container c)++lookupItemT :: (Eq k, Hashable k) => Bool -> k -> Cache k v -> TimeSpec -> STM (Maybe (CacheItem v))+lookupItemT del k c t = runMaybeT $ do+ i <- MaybeT (lookupItem' k c)+ let e = isExpired t i+ _ <- when (e && del) (MaybeT $ Just <$> deleteSTM k c)+ if e then MaybeT $ return Nothing else MaybeT $ return (Just i)++lookupItem :: (Eq k, Hashable k) => Bool -> k -> Cache k v -> IO (Maybe (CacheItem v))+lookupItem del k c = (atomically . lookupItemT del k c) =<< now++-- | Lookup an item with the given key, but don't delete it if it is expired.+--+-- The function will only return a value if it is present in the cache and if+-- the item is not expired.+--+-- The function will not delete the item from the cache.+lookup' :: (Eq k, Hashable k) => Cache k v -> k -> IO (Maybe v)+lookup' c k = runMaybeT $ item <$> MaybeT (lookupItem False k c)++-- | Lookup an item with the given key, and delete it if it is expired.+--+-- The function will only return a value if it is present in the cache and if+-- the item is not expired.+--+-- The function will eagerly delete the item from the cache if it is expired.+lookup :: (Eq k, Hashable k) => Cache k v -> k -> IO (Maybe v)+lookup c k = runMaybeT $ item <$> MaybeT (lookupItem True k c)++insertItem :: (Eq k, Hashable k) => k -> CacheItem v -> Cache k v -> STM ()+insertItem k a c = writeTVar v =<< (HM.insert k a <$> readTVar v) where v = container c++insertT :: (Eq k, Hashable k) => k -> v -> Cache k v -> Maybe TimeSpec -> STM ()+insertT k a c t = insertItem k (CacheItem a t) c++-- | Insert an item in the cache, with an explicit expiration value.+--+-- If the expiration value is 'Nothing', the item will never expire. The+-- default expiration value of the cache is ignored.+insert' :: (Eq k, Hashable k) => Cache k v -> Maybe TimeSpec -> k -> v -> IO ()+insert' c Nothing k a = atomically $ insertT k a c Nothing+insert' c (Just d) k a = atomically . insertT k a c =<< Just . (d +) <$> now++-- | Insert an item in the cache, using the default expiration value of+-- the cache.+insert :: (Eq k, Hashable k) => Cache k v -> k -> v -> IO ()+insert c = insert' c (defaultExpiration c)++keysSTM :: Cache k v -> STM [k]+keysSTM c = HM.keys <$> readTVar (container c)++-- | Return all keys present in the cache.+keys :: Cache k v -> IO [k]+keys = atomically . keysSTM++now :: IO TimeSpec+now = getTime Monotonic++purgeExpiredSTM :: (Eq k, Hashable k) => Cache k v -> TimeSpec -> STM ()+purgeExpiredSTM c t = mapM_ (\k -> lookupItemT True k c t) =<< keysSTM c++-- | Delete all items that are expired.+--+-- This is one big atomic operation.+purgeExpired :: (Eq k, Hashable k) => Cache k v -> IO ()+purgeExpired c = (atomically . purgeExpiredSTM c) =<< now++-- $use+--+-- All operations are atomically executed in the IO monad. The+-- underlying data structure is @Data.HashMap.Strict@.+--+-- First create a cache using 'newCache' and possibly a default+-- expiration value. Items can now be inserted using 'insert' and+-- 'insert''.+--+-- 'lookup' and 'lookup'' are used to query items. These functions+-- only return a value when the item is in the cache and it is not+-- expired. The 'lookup' function will automatically delete the+-- item if it is expired, while 'lookup'' won't delete the item.+--+-- > >>> c <- newCache Nothing :: IO (Cache String String)+-- > >>> insert c "key" "value"+-- > >>> lookup c "key"+-- > Just "value"+-- > >>> delete c "key"+-- > >>> lookup c "key"+-- > Nothing
+ test/Data/CacheSpec.hs view
@@ -0,0 +1,103 @@+module Data.CacheSpec (main, spec) where++import Prelude hiding (lookup)++import Test.Hspec++import Control.Concurrent+import Control.Monad.IO.Class (liftIO)+import Data.Cache+import System.Clock++main :: IO ()+main = hspec spec++spec :: Spec+spec = do+ it "should have a deletion/non-deletion variant" $ do+ c <- liftIO $ defCache Nothing+ _ <- liftIO $ expire defExpiration+ liftIO (size c) >>= (`shouldBe` 4)+ liftIO (lookup' c (fst expired))>>= (`shouldBe` Nothing)+ liftIO (size c) >>= (`shouldBe` 4)+ liftIO (lookup c (fst expired)) >>= (`shouldBe` Nothing)+ liftIO (size c) >>= (`shouldBe` 3)+ it "should work without a default expiration" $ do+ c <- liftIO $ defCache Nothing+ _ <- liftIO $ expire defExpiration+ liftIO (lookup' c (fst notAvailable)) >>= (`shouldBe` Nothing)+ liftIO (lookup' c (fst ok) ) >>= (`shouldBe` Just (snd ok))+ liftIO (lookup' c (fst notExpired) ) >>= (`shouldBe` Just (snd notExpired))+ liftIO (lookup' c (fst expired) ) >>= (`shouldBe` Nothing)+ liftIO (lookup' c (fst autoExpired) ) >>= (`shouldBe` Just (snd autoExpired))+ it "should work with a default expiration" $ do+ c <- liftIO $ defCache (Just defExpiration)+ _ <- liftIO $ expire defExpiration+ liftIO (lookup' c (fst notAvailable)) >>= (`shouldBe` Nothing)+ liftIO (lookup c (fst ok) ) >>= (`shouldBe` Just (snd ok))+ liftIO (lookup' c (fst expired) ) >>= (`shouldBe` Nothing)+ liftIO (lookup' c (fst autoExpired) ) >>= (`shouldBe` Nothing)+ it "should delete items" $ do+ c <- liftIO $ defCache Nothing+ _ <- liftIO $ expire defExpiration+ liftIO (size c) >>= (`shouldBe` 4)+ _ <- liftIO $ delete c (fst ok)+ liftIO (size c) >>= (`shouldBe` 3)+ liftIO (lookup' c (fst notAvailable)) >>= (`shouldBe` Nothing)+ liftIO (lookup' c (fst ok) ) >>= (`shouldBe` Nothing)+ liftIO (lookup' c (fst notExpired) ) >>= (`shouldBe` Just (snd notExpired))+ liftIO (lookup' c (fst expired) ) >>= (`shouldBe` Nothing)+ liftIO (lookup' c (fst autoExpired) ) >>= (`shouldBe` Just (snd autoExpired))+ it "should copy" $ do+ c <- liftIO $ defCache Nothing+ c' <- liftIO $ copyCache c+ _ <- liftIO $ delete c (fst ok)+ liftIO (lookup c (fst ok)) >>= (`shouldBe` Nothing)+ liftIO (lookup c' (fst ok)) >>= (`shouldBe` Just (snd ok))+ it "should set default expiratio time" $ do+ c <- liftIO $ defCache Nothing+ defaultExpiration (setDefaultExpiration c $ Just 4) `shouldBe` Just 4+ it "should return keys" $ do+ c <- liftIO $ defCache Nothing+ liftIO (keys c) >>= (`shouldContain` [(fst ok)])+ liftIO (keys c) >>= (`shouldContain` [(fst notExpired)])+ it "should purge expired keys" $ do+ c <- liftIO $ defCache Nothing+ _ <- liftIO $ expire defExpiration+ liftIO (size c) >>= (`shouldBe` 4)+ _ <- liftIO $ purgeExpired c+ liftIO (size c) >>= (`shouldBe` 3)++defExpiration :: TimeSpec+defExpiration = 1000000++defNotExpired :: TimeSpec+defNotExpired = 1000000000++expire :: TimeSpec -> IO ()+expire = threadDelay . fromInteger . (`div` 1000) . (* 2) . toNanoSecs++expired :: (String, Int)+expired = ("expired", 1)++notExpired :: (String, Int)+notExpired = ("not expired", 5)++autoExpired :: (String, Int)+autoExpired = ("auto expired", 4)++notAvailable :: (String, Int)+notAvailable = ("not available", 2)++ok :: (String, Int)+ok = ("ok", 3)++defCache :: Maybe TimeSpec -> IO (Cache String Int)+defCache t = do+ c <- newCache t+ _ <- uncurry (insert' c Nothing) ok+ _ <- uncurry (insert' c $ Just defExpiration) expired+ _ <- uncurry (insert c) autoExpired+ _ <- uncurry (insert' c $ Just defNotExpired) notExpired+ return c+
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}