packages feed

arbor-lru-cache (empty) → 0.1.1.0

raw patch · 11 files changed

+444/−0 lines, 11 filesdep +arbor-lru-cachedep +basedep +containerssetup-changed

Dependencies added: arbor-lru-cache, base, containers, generic-lens, hedgehog, hspec, hw-hspec-hedgehog, lens, stm

Files

+ ChangeLog.md view
@@ -0,0 +1,3 @@+# Changelog for arbor-lru-cache++## Unreleased changes
+ LICENSE view
@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2018 Arbor Networks++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ README.md view
@@ -0,0 +1,42 @@+# arbor-lru-cache++A thread-safe LRU cache library.++## Example++To use the cache:++```haskell+main :: IO+main = do+  -- Provide a configuration that includes how many simultaneous in+  -- flight requests are allowed and now many entries the cache can store+  let config = A.CacheConfig+        { A.maxRequestsInFlight = 1+        , A.maxOccupancy        = 1+        }++  -- Create a cache providing the config and functions that handle retrieval+  -- and eviction.+  cache <- A.makeCache config retrieve evict++  -- Perform your lookups+  _ <- A.lookup 1 cache+  _ <- A.lookup 2 cache+  _ <- A.lookup 3 cache++  return ()++-- Implement value retrieval function.  If the same key is looked up multiple+-- times, the cache guarantees that the retrieve function is called only once+-- for that key up until it is evicted.+retrieve :: Int -> IO String+retrieve mk = ...++-- Perform any cleanup that should occur when an entry is evicted+-- Please be aware that if your code is concurrent, the eviction function may+-- be called whilst the you code is concurrently using a value it has looked up.+-- Your code is wholly responsible for ensuring this case still works.+evict :: Int -> String -> IO ()+evict mk mv = ...+```
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ arbor-lru-cache.cabal view
@@ -0,0 +1,63 @@+-- This file has been generated from package.yaml by hpack version 0.18.1.+--+-- see: https://github.com/sol/hpack++name:           arbor-lru-cache+version:        0.1.1.0+description:    Please see the README on GitHub at <https://github.com/arbor/arbor-lru-cache#readme>+homepage:       https://github.com/arbor/arbor-lru-cache#readme+bug-reports:    https://github.com/arbor/arbor-lru-cache/issues+author:         Arbor Networks+maintainer:     mayhem@arbor.net+copyright:      2018 Arbor Networks+license:        MIT+license-file:   LICENSE+build-type:     Simple+cabal-version:  >= 1.10++extra-source-files:+    ChangeLog.md+    README.md++source-repository head+  type: git+  location: https://github.com/arbor/arbor-lru-cache++library+  hs-source-dirs:+      src+  ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints+  build-depends:+      base >= 4.7 && < 5+    , containers+    , generic-lens+    , lens+    , stm+  exposed-modules:+      Arbor.LruCache+      Arbor.LruCache.Internal.PriorityQueue+      Arbor.LruCache.Type+  other-modules:+      Paths_arbor_lru_cache+  default-language: Haskell2010++test-suite arbor-lru-cache-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  hs-source-dirs:+      test+  ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      base >= 4.7 && < 5+    , containers+    , generic-lens+    , lens+    , stm+    , hedgehog+    , hspec+    , hw-hspec-hedgehog+    , arbor-lru-cache+  other-modules:+      Arbor.LruCache.Internal.PriorityQueueSpec+      Arbor.LruCache.LruCacheSpec+  default-language: Haskell2010
+ src/Arbor/LruCache.hs view
@@ -0,0 +1,161 @@+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections       #-}+{-# LANGUAGE TypeApplications    #-}++module Arbor.LruCache+    ( lookup+    , makeCache+    , Z.CacheConfig(..)+    , Z.Cache(..)+    , retrieveData+    , evictData+    , entries+    ) where++import Control.Concurrent+import Control.Exception+import Control.Lens+import Control.Monad+import Data.Generics.Product.Any+import Data.Maybe+import Prelude                   hiding (lookup)++import qualified Arbor.LruCache.Internal.PriorityQueue as PQ+import qualified Arbor.LruCache.Type                   as Z+import qualified Control.Concurrent.STM                as STM+import qualified Data.Map                              as M++lookup :: Ord k => k -> Z.Cache k v -> IO v+lookup k cache = do+  newTmv <- STM.newTVarIO Nothing+  let maxInFlight       = cache ^. the @"config" . the @"maxRequestsInFlight"+  let evict             = cache ^. the @"evict"+  let tRequestsInFlight = cache ^. the @"requestsInFlight"+  let retrieve          = cache ^. the @"retrieve"+  let tEntries          = cache ^. the @"entries"+  let tOccupancy        = cache ^. the @"occupancy"++  join $ STM.atomically $ do+    es <- STM.readTVar tEntries+    case M.lookup k es of+      Just tmv -> do+        registerForEviction k cache+        return $ STM.atomically $ do+          registerForEviction k cache+          STM.readTVar tmv >>= maybe STM.retry return++      Nothing -> do+        requestsInFlight <- STM.readTVar tRequestsInFlight+        if requestsInFlight >= maxInFlight+          then STM.retry+          else do+            STM.writeTVar tRequestsInFlight (requestsInFlight + 1)+            STM.writeTVar tEntries (M.insert k newTmv es)+            return $ do+              v <- catch (retrieve k) $ \(e :: SomeException) -> do+                STM.atomically $ do+                  entries2 <- STM.readTVar tEntries+                  forM_ (M.lookup k entries2) $ \tv -> STM.writeTVar tv (throw e)+                  STM.modifyTVar tRequestsInFlight pred+                  STM.writeTVar tEntries (M.delete k entries2)+                throw e++              kvsForEviction <- STM.atomically $ do+                STM.writeTVar newTmv (Just v)+                STM.modifyTVar tRequestsInFlight pred+                STM.modifyTVar tOccupancy succ++                registerForEviction k cache+                takeEvictionsDue cache++              forM_ kvsForEviction $ uncurry evict++              return v++registerForEviction :: Eq k => k -> Z.Cache k v -> STM.STM ()+registerForEviction k cache = do+  let tEvictionQueue    = cache ^. the @"evictionQueue"+  let tEvictionPriority = cache ^. the @"evictionPriority"++  STM.modifyTVar tEvictionPriority (+1)+  evictionPriority <- STM.readTVar tEvictionPriority+  STM.modifyTVar tEvictionQueue (PQ.insert evictionPriority k)++takeEvictionsDue :: Ord k => Z.Cache k v -> STM.STM [(k, v)]+takeEvictionsDue cache = do+  let maxOccupancy      = cache ^. the @"config" . the @"maxOccupancy"+  let tEntries          = cache ^. the @"entries"+  let tOccupancy        = cache ^. the @"occupancy"+  let tEvictionQueue    = cache ^. the @"evictionQueue"++  evictionQueue <- STM.readTVar tEvictionQueue+  occupancy <- STM.readTVar tOccupancy++  if occupancy > maxOccupancy+    then case PQ.take (occupancy - maxOccupancy) evictionQueue of+      (ks, evictionQueue') -> do+        STM.writeTVar tEvictionQueue evictionQueue'+        STM.writeTVar tOccupancy maxOccupancy++        removeEvictionsFromEntries ks tEntries++    else return []++removeEvictionsFromEntries :: Ord k => [k] -> STM.TVar (M.Map k (STM.TVar (Maybe v))) -> STM.STM [(k, v)]+removeEvictionsFromEntries ks tEntries = do+  es <- STM.readTVar tEntries++  let kmtmvs = (\k -> (k, M.lookup k es)) <$> ks++  mkvs <- forM kmtmvs $ \(k, mtmv) -> case mtmv of+    Just tmv -> do+      mv <- STM.readTVar tmv+      return ((k, ) <$> mv)+    Nothing -> return Nothing++  let kvs = catMaybes mkvs++  STM.writeTVar tEntries (foldl (flip M.delete) es (fst <$> kvs))++  return kvs++entries :: Ord k => Z.Cache k v -> IO (M.Map k (Maybe v))+entries cache = do+  let tEntries          = cache ^. the @"entries"++  STM.atomically $ do+    m <- STM.readTVar tEntries+    kvs <- forM (M.toList m) $ \(k, tmv) -> do+      mv <- STM.readTVar tmv+      return (k, mv)++    return (M.fromList kvs)++makeCache :: Z.CacheConfig -> (k -> IO v) -> (k -> v -> IO ()) -> IO (Z.Cache k v)+makeCache config retrieve evict = do+  tRequestsInFlight <- STM.newTVarIO 0+  tEntries          <- STM.newTVarIO M.empty+  tOccupancy        <- STM.newTVarIO 0+  tEvictionQueue    <- STM.newTVarIO PQ.empty+  tEvictionPriority <- STM.newTVarIO 0++  return Z.Cache+    { Z.config            = config+    , Z.requestsInFlight  = tRequestsInFlight+    , Z.entries           = tEntries+    , Z.evictionQueue     = tEvictionQueue+    , Z.evictionPriority  = tEvictionPriority+    , Z.occupancy         = tOccupancy+    , Z.retrieve          = retrieve+    , Z.evict             = evict+    }++retrieveData :: (String, Int) -> IO String+retrieveData (s, d) = do+  threadDelay d+  putStrLn $ "Retrieved " ++ show (s, d)+  return $ "Got: " ++ show (s, d)++evictData :: (String, Int) -> String -> IO ()+evictData k v = putStrLn $ "Evicting " ++ show (k, v)
+ src/Arbor/LruCache/Internal/PriorityQueue.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE ScopedTypeVariables #-}++module Arbor.LruCache.Internal.PriorityQueue where++import Data.List (sortOn, splitAt)++newtype PriorityQueue p v = PriorityQueue [(p, v)]+  deriving (Eq, Show)++insert :: Eq v => p -> v -> PriorityQueue p v -> PriorityQueue p v+insert p v (PriorityQueue qas) = PriorityQueue ((p, v):filter ((/= v) . snd) qas)++take :: Ord p => Int -> PriorityQueue p v -> ([v], PriorityQueue p v)+take n (PriorityQueue qas) = case splitAt n (sortOn fst qas) of+  (as, bs) -> (snd <$> as, PriorityQueue bs)++empty :: PriorityQueue p v+empty = PriorityQueue []++toList :: Ord p => PriorityQueue p v -> [(p, v)]+toList (PriorityQueue qas) = sortOn fst qas
+ src/Arbor/LruCache/Type.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE DeriveGeneric         #-}+{-# LANGUAGE DuplicateRecordFields #-}++module Arbor.LruCache.Type where++import GHC.Generics++import qualified Arbor.LruCache.Internal.PriorityQueue as PQ+import qualified Control.Concurrent.STM                as STM+import qualified Data.Map                              as M++data CacheConfig = CacheConfig+  { maxRequestsInFlight :: Int+  , maxOccupancy        :: Int+  } deriving (Eq, Show, Generic)++data Cache k v = Cache+  { config           :: CacheConfig+  , requestsInFlight :: STM.TVar Int+  , entries          :: STM.TVar (M.Map k (STM.TVar (Maybe v)))+  , evictionQueue    :: STM.TVar (PQ.PriorityQueue Int k)+  , evictionPriority :: STM.TVar Int+  , occupancy        :: STM.TVar Int+  , retrieve         :: k -> IO v+  , evict            :: k -> v -> IO ()+  } deriving Generic
+ test/Arbor/LruCache/Internal/PriorityQueueSpec.hs view
@@ -0,0 +1,51 @@+module Arbor.LruCache.Internal.PriorityQueueSpec (spec) where++import Data.Function+import HaskellWorks.Hspec.Hedgehog+import Hedgehog+import Test.Hspec++import qualified Arbor.LruCache.Internal.PriorityQueue as PQ++spec :: Spec+spec = describe "Arbor.LruCache.Internal.PriorityQueueSpec" $ do+  it "Insertion dedupes by value" $ requireTest $ do+    let actual = (PQ.empty :: PQ.PriorityQueue Int Int)+          & PQ.insert 1 101+          & PQ.insert 3 101+          & PQ.insert 2 101++    let expected = [(2, 101)]++    PQ.toList actual === expected+  it "Insert stores all non-duplicate values" $ requireTest $ do+    let actual = (PQ.empty :: PQ.PriorityQueue Int Int)+          & PQ.insert 1 101+          & PQ.insert 3 303+          & PQ.insert 2 202++    let expected = [(1, 101), (2, 202), (3, 303)]++    PQ.toList actual === expected+  it "Take removes most priority element from queue" $ requireTest $ do+    let actual = (PQ.empty :: PQ.PriorityQueue Int Int)+          & PQ.insert 1 101+          & PQ.insert 3 303+          & PQ.insert 2 202+          & PQ.take 1 & snd++    let expected = [(2, 202), (3, 303)]++    PQ.toList actual === expected+  it "Take yields most priority element from queue" $ requireTest $ do+    let actual = (PQ.empty :: PQ.PriorityQueue Int Int)+          & PQ.insert 1 101+          & PQ.insert 3 303+          & PQ.insert 2 202+          & PQ.take 1 & fst++    let expected = [101]++    actual === expected++
+ test/Arbor/LruCache/LruCacheSpec.hs view
@@ -0,0 +1,53 @@+module Arbor.LruCache.LruCacheSpec (spec) where++import Control.Concurrent.STM+import Control.Monad.IO.Class+import HaskellWorks.Hspec.Hedgehog+import Hedgehog+import Test.Hspec++import qualified Arbor.LruCache as A++{-# ANN module ("HLint: ignore Redundant do"  :: String) #-}++data Event+  = EvictEvent+  { key   :: Int+  , value :: String+  }+  | RetrieveEvent+  { key   :: Int+  , value :: String+  } deriving (Eq, Show)++spec :: Spec+spec = describe "Arbor.LruCache.LruCacheSpec" $ do+  it "Insertion dedupes by value" $ requireTest $ do+    th <- liftIO $ newTVarIO []+    let config = A.CacheConfig+          { A.maxRequestsInFlight = 1+          , A.maxOccupancy        = 1+          }+    cache <- liftIO $ A.makeCache config (retrieve th) (evict th)++    _ <- liftIO $ A.lookup 1 cache+    _ <- liftIO $ A.lookup 2 cache+    _ <- liftIO $ A.lookup 3 cache++    history <- liftIO $ atomically $ reverse <$> readTVar th+    history ===+      [ RetrieveEvent { key = 1 , value = "1" }+      , RetrieveEvent { key = 2 , value = "2" }+      , EvictEvent    { key = 1 , value = "1" }+      , RetrieveEvent { key = 3 , value = "3" }+      , EvictEvent    { key = 2 , value = "2" }+      ]++retrieve :: TVar [Event] -> Int -> IO String+retrieve th mk = do+  let mv = show mk+  atomically $ modifyTVar th (RetrieveEvent mk mv:)+  return mv++evict :: TVar [Event] -> Int -> String -> IO ()+evict th mk mv = atomically $ modifyTVar th (EvictEvent mk mv:)
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}