freckle-http 0.4.0.0 → 0.4.1.0
raw patch · 5 files changed
+363/−3 lines, 5 filesdep +psqueues
Dependencies added: psqueues
Files
- CHANGELOG.md +5/−1
- freckle-http.cabal +4/−1
- library/Freckle/App/Http/Cache/InProcess.hs +223/−0
- package.yaml +2/−1
- tests/Freckle/App/Http/Cache/InProcessSpec.hs +129/−0
CHANGELOG.md view
@@ -1,4 +1,8 @@-## [_Unreleased_](https://github.com/freckle/freckle-http/compare/v0.4.0.0...main)+## [_Unreleased_](https://github.com/freckle/freckle-http/compare/v0.4.1.0...main)++## [v0.4.1.0](https://github.com/freckle/freckle-http/compare/v0.4.0.0...v0.4.1.0)++- Add `Freckle.App.Http.Cache.InProcess`, an in-memory, size-bounded cache ## [v0.4.0.0](https://github.com/freckle/freckle-http/compare/v0.3.1.0...v0.4.0.0)
freckle-http.cabal view
@@ -1,6 +1,6 @@ cabal-version: 1.18 name: freckle-http-version: 0.4.0.0+version: 0.4.1.0 license: MIT license-file: LICENSE maintainer: Freckle Education@@ -24,6 +24,7 @@ Freckle.App.Http Freckle.App.Http.Cache Freckle.App.Http.Cache.Gzip+ Freckle.App.Http.Cache.InProcess Freckle.App.Http.Cache.Memcached Freckle.App.Http.Cache.State Freckle.App.Http.Header@@ -74,6 +75,7 @@ monad-validate >=1.3.0.0, mtl >=2.2.2, network-uri >=2.6.4.2,+ psqueues >=0.2.7.3, retry >=0.8.1.0, safe >=0.3.19, semigroupoids >=5.3.7,@@ -93,6 +95,7 @@ main-is: Main.hs hs-source-dirs: tests other-modules:+ Freckle.App.Http.Cache.InProcessSpec Freckle.App.Http.CacheSpec Freckle.App.HttpSpec Freckle.App.Test.Http.MatchRequestSpec
+ library/Freckle/App/Http/Cache/InProcess.hs view
@@ -0,0 +1,223 @@+-- | An in-process, size-bounded cache of upstream HTTP responses+--+-- 'cacheGet' checks only the entry being looked up: if its own TTL has+-- already elapsed, it is evicted and treated as a miss. 'cacheSet' evicts+-- only when the total size is over budget, preferring an already-expired+-- entry over the least-recently-used one. Neither walks the whole cache on+-- every call. Call 'cacheReap' yourself (e.g. from a periodic background+-- thread) for more proactive reclamation than that.+module Freckle.App.Http.Cache.InProcess+ ( InProcessHttpCache+ , InProcessHttpCacheSettings (..)+ , defaultSettings+ , newInProcessHttpCache+ , inProcessHttpCache+ , inProcessHttpCacheSettings+ , cacheGet+ , Reap (..)+ , cacheGetReap+ , cacheSet+ , cacheDelete+ , cacheReap+ ) where++import Prelude++import Blammo.Logging (MonadLogger, logDebugNS, logWarnNS)+import Control.Exception.Annotated.UnliftIO (try)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.ByteString qualified as BS+import Data.HashPSQ (HashPSQ)+import Data.HashPSQ qualified as HashPSQ+import Data.IORef (IORef, atomicModifyIORef', newIORef)+import Data.Time (UTCTime, addUTCTime, getCurrentTime)+import Database.Memcache.Types (Key, Value)+import Freckle.App.Http.Cache+import Freckle.App.Http.Cache.Memcached (memcachedHttpCodec)+import Freckle.App.Memcached.CacheKey (fromCacheKey)+import Freckle.App.Memcached.CacheTTL (CacheTTL)+import UnliftIO (MonadUnliftIO)++-- | A monotonically increasing counter used as a recency priority+--+-- Smaller means less recently used.+type Tick = Int++data Entry = Entry+ { value :: Value+ , expiresAt :: UTCTime+ }++data CacheState = CacheState+ { byRecency :: HashPSQ Key Tick Entry+ , byExpiry :: HashPSQ Key UTCTime ()+ , totalBytes :: Int+ , nextTick :: Tick+ }++data InProcessHttpCache = InProcessHttpCache+ { ref :: IORef CacheState+ , maxBytes :: Int+ , clock :: IO UTCTime+ }++data InProcessHttpCacheSettings = InProcessHttpCacheSettings+ { maxBytes :: Int+ , clock :: IO UTCTime+ -- ^ What to use as "now". Tests can override this to simulate a TTL+ -- having elapsed without an actual delay.+ }++-- | 20MB, using the real clock+defaultSettings :: InProcessHttpCacheSettings+defaultSettings =+ InProcessHttpCacheSettings+ { maxBytes = 20 * 1024 * 1024+ , clock = getCurrentTime+ }++-- | Create an empty cache+newInProcessHttpCache+ :: MonadIO m => InProcessHttpCacheSettings -> m InProcessHttpCache+newInProcessHttpCache InProcessHttpCacheSettings {maxBytes, clock} = do+ ref <-+ liftIO $+ newIORef+ CacheState+ { byRecency = HashPSQ.empty+ , byExpiry = HashPSQ.empty+ , totalBytes = 0+ , nextTick = 0+ }+ pure InProcessHttpCache {ref, maxBytes, clock}++inProcessHttpCacheSettings+ :: (MonadLogger m, MonadUnliftIO m)+ => InProcessHttpCache+ -> CacheTTL+ -- ^ Default TTL, used when @max-age@ is not present+ -> HttpCacheSettings m Value+inProcessHttpCacheSettings cache defaultTTL =+ HttpCacheSettings+ { shared = True+ , cacheable = const True+ , cacheByHeaders = []+ , forceTTL = Nothing+ , defaultTTL+ , getCurrentTime = liftIO getCurrentTime+ , logDebug = logDebugNS "http.cache"+ , logWarn = logWarnNS "http.cache"+ , codec = memcachedHttpCodec+ , cache = inProcessHttpCache cache+ }++inProcessHttpCache :: MonadUnliftIO m => InProcessHttpCache -> HttpCache m Value+inProcessHttpCache cache =+ HttpCache+ { get = try . liftIO . cacheGet cache . fromCacheKey+ , set = \k v ttl -> try $ liftIO $ cacheSet cache (fromCacheKey k) v ttl+ , evict = try . liftIO . cacheDelete cache . fromCacheKey+ }++-- | Whether a 'cacheGetReap' call should evict an expired looked-up entry+data Reap = Reap | NoReap++cacheGet :: InProcessHttpCache -> Key -> IO (Maybe Value)+cacheGet = cacheGetReap Reap++-- | 'cacheGet', with the choice of whether it checks the looked-up entry's TTL+--+-- Real callers always want 'Reap' (that's what 'cacheGet' fixes it to);+-- 'NoReap' exists so tests can observe an expired entry's continued+-- presence, and 'cacheReap's effect on it, without 'cacheGet's own check+-- masking either.+cacheGetReap :: Reap -> InProcessHttpCache -> Key -> IO (Maybe Value)+cacheGetReap reap InProcessHttpCache {ref, clock} k = do+ now <- clock+ atomicModifyIORef' ref $ \state -> case HashPSQ.lookup k state.byRecency of+ Nothing -> (state, Nothing)+ Just (_tick, entry)+ | expired -> (removeKey k state, Nothing)+ | otherwise ->+ ( state+ { byRecency = HashPSQ.insert k state.nextTick entry state.byRecency+ , nextTick = state.nextTick + 1+ }+ , Just entry.value+ )+ where+ expired = case reap of+ Reap -> entry.expiresAt <= now+ NoReap -> False++cacheSet :: InProcessHttpCache -> Key -> Value -> CacheTTL -> IO ()+cacheSet InProcessHttpCache {ref, maxBytes, clock} k v ttl = do+ now <- clock+ let expiresAt = addUTCTime (fromIntegral ttl) now+ atomicModifyIORef' ref $ \state ->+ let+ oldSize = maybe 0 (BS.length . value . snd) $ HashPSQ.lookup k state.byRecency+ state1 =+ state+ { byRecency =+ HashPSQ.insert k state.nextTick Entry {value = v, expiresAt} state.byRecency+ , byExpiry = HashPSQ.insert k expiresAt () state.byExpiry+ , totalBytes = state.totalBytes - oldSize + BS.length v+ , nextTick = state.nextTick + 1+ }+ in+ (evictToFit maxBytes now state1, ())++cacheDelete :: InProcessHttpCache -> Key -> IO ()+cacheDelete InProcessHttpCache {ref} k =+ atomicModifyIORef' ref $ \state -> (removeKey k state, ())++-- | Remove every entry whose TTL has already elapsed+--+-- Unlike 'cacheGet' and 'cacheSet', which only ever look at what that one+-- call needs to, this walks the whole cache. Call it yourself, e.g.+-- periodically from your own background thread, for more proactive+-- reclamation than ordinary traffic gives you; this module does not run one+-- itself.+cacheReap :: InProcessHttpCache -> IO ()+cacheReap InProcessHttpCache {ref, clock} = do+ now <- clock+ atomicModifyIORef' ref $ \state -> (reapExpired now state, ())++-- | 'cacheReap's implementation: remove every entry whose TTL has elapsed+reapExpired :: UTCTime -> CacheState -> CacheState+reapExpired now = go+ where+ go state = case HashPSQ.findMin state.byExpiry of+ Just (k, expiresAt, ()) | expiresAt <= now -> go (removeKey k state)+ _ -> state++-- | Evict entries until under budget, preferring an already-expired one+evictToFit :: Int -> UTCTime -> CacheState -> CacheState+evictToFit maxBytes now = go+ where+ go state+ | state.totalBytes <= maxBytes = state+ | otherwise = case popExpired state of+ Just state' -> go state'+ Nothing -> case popLru state of+ Just state' -> go state'+ Nothing -> state++ popExpired state = case HashPSQ.findMin state.byExpiry of+ Just (k, expiresAt, ()) | expiresAt <= now -> Just $ removeKey k state+ _ -> Nothing++ popLru state = case HashPSQ.findMin state.byRecency of+ Just (k, _tick, _entry) -> Just $ removeKey k state+ Nothing -> Nothing++removeKey :: Key -> CacheState -> CacheState+removeKey k state =+ state+ { byRecency = HashPSQ.delete k state.byRecency+ , byExpiry = HashPSQ.delete k state.byExpiry+ , totalBytes = state.totalBytes - size+ }+ where+ size = maybe 0 (BS.length . value . snd) $ HashPSQ.lookup k state.byRecency
package.yaml view
@@ -1,5 +1,5 @@ name: freckle-http-version: 0.4.0.0+version: 0.4.1.0 maintainer: Freckle Education category: HTTP github: freckle/freckle-http@@ -80,6 +80,7 @@ - monad-validate - mtl - network-uri+ - psqueues - retry >= 0.8.1.0 # retryingDynamic - safe - serialise
+ tests/Freckle/App/Http/Cache/InProcessSpec.hs view
@@ -0,0 +1,129 @@+module Freckle.App.Http.Cache.InProcessSpec+ ( spec+ ) where++import Prelude++import Data.IORef (newIORef, readIORef, writeIORef)+import Data.Time (UTCTime, addUTCTime)+import Data.Time.Clock.POSIX (posixSecondsToUTCTime)+import Freckle.App.Http.Cache.InProcess+ ( InProcessHttpCacheSettings (..)+ , Reap (..)+ , cacheDelete+ , cacheGet+ , cacheGetReap+ , cacheReap+ , cacheSet+ , defaultSettings+ , newInProcessHttpCache+ )+import Test.Hspec++spec :: Spec+spec = describe "InProcessHttpCache" $ do+ it "misses on an empty cache" $ do+ c <- newInProcessHttpCache defaultSettings {maxBytes = 1024}+ mv <- cacheGet c "a"+ mv `shouldBe` Nothing++ it "returns a value after it is set" $ do+ c <- newInProcessHttpCache defaultSettings {maxBytes = 1024}+ cacheSet c "a" "hello" 300+ mv <- cacheGet c "a"+ mv `shouldBe` Just "hello"++ it "no longer returns a value once evicted" $ do+ c <- newInProcessHttpCache defaultSettings {maxBytes = 1024}+ cacheSet c "a" "hello" 300+ cacheDelete c "a"+ mv <- cacheGet c "a"+ mv `shouldBe` Nothing++ it "no longer returns a value once its own ttl has elapsed" $ do+ c <- newInProcessHttpCache defaultSettings {maxBytes = 1024}+ cacheSet c "a" "hello" 0+ mv <- cacheGet c "a"+ mv `shouldBe` Nothing++ it "does not check any other key's ttl when getting one key" $ do+ c <- newInProcessHttpCache defaultSettings {maxBytes = 1024}+ cacheSet c "a" "hello" 0 -- already expired+ cacheSet c "b" "world" 300 -- fresh, unrelated+ _ <- cacheGet c "b" -- looks up "b" only+ mv <- cacheGetReap NoReap c "a" -- skip get's own check, to see whether "b"'s get touched "a"+ mv `shouldBe` Just "hello" -- untouched; still there, even though already expired++ it "leaves an entry that has expired since it was set until something reaps it" $ do+ clockRef <- newIORef epoch+ c <-+ newInProcessHttpCache+ defaultSettings {maxBytes = 1024, clock = readIORef clockRef}+ cacheSet c "a" "hello" 1 -- expires 1 second after epoch+ writeIORef clockRef (addUTCTime 2 epoch) -- simulate 2 seconds passing, no delay needed+ stillThere <- cacheGetReap NoReap c "a" -- skip get's own check, so its lingering presence shows+ stillThere `shouldBe` Just "hello"+ cacheReap c+ afterReap <- cacheGetReap NoReap c "a" -- skip get's own check again, to isolate cacheReap's effect+ afterReap `shouldBe` Nothing++ it "evicts the least-recently-used entry once over budget" $ do+ c <- newInProcessHttpCache defaultSettings {maxBytes = 10}+ cacheSet c "a" "aaaaa" 300 -- total: 5+ cacheSet c "b" "bbbbb" 300 -- total: 10+ cacheSet c "c" "ccccc" 300 -- total: 15, over budget; evicts "a"+ va <- cacheGet c "a"+ vb <- cacheGet c "b"+ vc <- cacheGet c "c"+ va `shouldBe` Nothing+ vb `shouldBe` Just "bbbbb"+ vc `shouldBe` Just "ccccc"++ it "treats a 'get' as refreshing an entry's recency" $ do+ c <- newInProcessHttpCache defaultSettings {maxBytes = 10}+ cacheSet c "a" "aaaaa" 300 -- total: 5+ cacheSet c "b" "bbbbb" 300 -- total: 10+ _ <- cacheGet c "a" -- "a" is now more-recently-used than "b"+ cacheSet c "c" "ccccc" 300 -- total: 15, over budget; evicts "b"+ va <- cacheGet c "a"+ vb <- cacheGet c "b"+ vc <- cacheGet c "c"+ va `shouldBe` Just "aaaaa"+ vb `shouldBe` Nothing+ vc `shouldBe` Just "ccccc"++ it "does not cache a single response larger than the whole budget" $ do+ c <- newInProcessHttpCache defaultSettings {maxBytes = 10}+ cacheSet c "a" "this value is way over budget" 300+ mv <- cacheGet c "a"+ mv `shouldBe` Nothing++ it "evicts an already-expired entry ahead of the least-recently-used one" $ do+ c <- newInProcessHttpCache defaultSettings {maxBytes = 10}+ cacheSet c "a" "aaaaa" 300 -- total: 5, fresh, least-recently-touched+ cacheSet c "b" "bbbbb" 0 -- total: 10, already expired, but more-recently-touched than "a"+ cacheSet c "c" "ccccc" 300 -- total: 15, over budget; evicts "b" (expired), not "a" (LRU tail)+ va <- cacheGetReap NoReap c "a"+ vb <- cacheGetReap NoReap c "b" -- skip get's own check, to isolate the set-time eviction+ vc <- cacheGetReap NoReap c "c"+ va `shouldBe` Just "aaaaa"+ vb `shouldBe` Nothing+ vc `shouldBe` Just "ccccc"++ it "falls back to least-recently-used once no expired entries remain" $ do+ c <- newInProcessHttpCache defaultSettings {maxBytes = 10}+ cacheSet c "a" "aaaaa" 0 -- total: 5, already expired+ cacheSet c "b" "bbbbb" 300 -- total: 10, fresh+ cacheSet c "c" "ccccc" 300 -- total: 15, over budget; evicts "a" (expired)+ cacheSet c "d" "ddddd" 300 -- total: 15, over budget; no expired entries left, evicts "b" (LRU)+ va <- cacheGet c "a"+ vb <- cacheGet c "b"+ vc <- cacheGet c "c"+ vd <- cacheGet c "d"+ va `shouldBe` Nothing+ vb `shouldBe` Nothing+ vc `shouldBe` Just "ccccc"+ vd `shouldBe` Just "ddddd"++epoch :: UTCTime+epoch = posixSecondsToUTCTime 0