caching-vault (empty) → 0.1.0.0

raw patch · 6 files changed

+272/−0 lines, 6 filesdep +basedep +caching-vaultdep +hspecsetup-changed

Dependencies added: base, caching-vault, hspec, stm, stm-containers, text, time, timespan

Files

LICENSE +30/−0
README.md +23/−0
Setup.hs +2/−0
caching-vault.cabal +64/−0
src/Data/Cache/Vault.hs +96/−0
test/Spec.hs +57/−0

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright Alexander Thiemann (c) 2021++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 Alexander Thiemann 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,23 @@+# caching-vault++A simple [vault](https://hackage.haskell.org/package/vault) style cache implementation based on [stm-containers](https://hackage.haskell.org/package/stm-containers).++## Example++``` haskell+import Data.Time+import qualified Data.Cache.Vault as C++main :: IO ()+main =+  do cache <- C.newCache+     let key :: C.Key String+         key = C.mintLabeledKey "foo"+     C.insert key Nothing "cached value" cache+     +     now <- getCurrentTime+     value <- C.lookup now key cache+     case value of+       Nothing -> putStrLn "Cache miss"+       Just val -> putStrLn ("Cache value is: " <> val)+```

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ caching-vault.cabal view

@@ -0,0 +1,64 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.33.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: d045485a8c1101cb9c1d54251cc48c42e544e597c1ec7c06b0e0a5850a78ddc8++name:           caching-vault+version:        0.1.0.0+synopsis:       A vault-style cache implementation+description:    Allows a central cache for arbitrary values with expiry dates+category:       Data+homepage:       https://github.com/agrafix/caching-vault#readme+bug-reports:    https://github.com/agrafix/caching-vault/issues+author:         Alexander Thiemann+maintainer:     Alexander Thiemann <mail@thiemann.at>+copyright:      2021 Alexander Thiemann+license:        BSD3+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md++source-repository head+  type: git+  location: https://github.com/agrafix/caching-vault++library+  exposed-modules:+      Data.Cache.Vault+  other-modules:+      Paths_caching_vault+  hs-source-dirs:+      src+  default-extensions: OverloadedStrings DataKinds TypeOperators TypeFamilies GADTs FlexibleInstances FlexibleContexts MultiParamTypeClasses StrictData ScopedTypeVariables DeriveGeneric DeriveFunctor+  ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates+  build-depends:+      base >=4.7 && <5+    , stm+    , stm-containers+    , text+    , time+  default-language: Haskell2010++test-suite caching-vault-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Paths_caching_vault+  hs-source-dirs:+      test+  default-extensions: OverloadedStrings DataKinds TypeOperators TypeFamilies GADTs FlexibleInstances FlexibleContexts MultiParamTypeClasses StrictData ScopedTypeVariables DeriveGeneric DeriveFunctor+  ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      base >=4.7 && <5+    , caching-vault+    , hspec+    , stm+    , stm-containers+    , text+    , time+    , timespan+  default-language: Haskell2010

+ src/Data/Cache/Vault.hs view

@@ -0,0 +1,96 @@+module Data.Cache.Vault+  ( Cache, newCache+  , Key, mintLabeledKey, mintUniqKey+  , insert, delete, reset, lookup+  )+where++import Control.Concurrent.STM (atomically)+import Data.IORef+import Data.Time+import Data.Typeable+import GHC.Exts+import GHC.Fingerprint+import Prelude hiding (lookup)+import System.IO.Unsafe (unsafePerformIO)+import Unsafe.Coerce (unsafeCoerce)+import qualified Data.Text as T+import qualified StmContainers.Map as M++type KeyRepr = T.Text++data CacheEntry+  = CacheEntry+  { ceValidUntil :: Maybe UTCTime+  , ceValue :: Any+  }++newtype Cache+  = Cache { _unCache :: M.Map KeyRepr CacheEntry }++newtype Key a+  = Key { unKey :: KeyRepr }+  deriving (Show, Eq)++keyCounter :: IORef Int+keyCounter =+  unsafePerformIO $ newIORef 0+{-# NOINLINE keyCounter #-}++-- | Mint a globally unique key+mintUniqKey :: IO (Key a)+mintUniqKey =+  atomicModifyIORef' keyCounter $ \ctr ->+  ( ctr + 1+  , Key $ "uniq/" <> T.pack (show ctr)+  )++-- | Mint a key with a label for a given type. Note that keys+-- with the same label but for different types are different.+mintLabeledKey :: forall a. Typeable a => T.Text -> Key a+mintLabeledKey label =+  Key $ "label/" <> label <> "/" <> typeSig+  where+    typeSig =+      let (Fingerprint x1 x2) =+            typeRepFingerprint (typeRep (Proxy :: Proxy (Proxy a)))+      in T.pack $ show x1 <> "." <> show x2++-- | Create a new cache container.+newCache :: IO Cache+newCache =+  Cache <$> M.newIO++-- | Insert a value into the cache with an optional expiry date.+insert :: Key a -> Maybe UTCTime -> a -> Cache -> IO ()+insert k t v (Cache ref) =+  atomically $ M.insert val key ref+  where+    val =+      CacheEntry+      { ceValidUntil = t+      , ceValue = unsafeCoerce v+      }+    key = unKey k++-- | Delete a value from the cache.+delete :: Key a -> Cache -> IO ()+delete k (Cache ref) =+  atomically $ M.delete (unKey k) ref++-- | Purge all values form the cache.+reset :: Cache -> IO ()+reset (Cache ref) =+  atomically $ M.reset ref++-- | Given the current time, lookup a key in the cache.+lookup :: UTCTime -> Key a -> Cache -> IO (Maybe a)+lookup now k (Cache ref) =+  do entry <-+       atomically $ M.lookup (unKey k) ref+     case entry of+       Nothing -> pure Nothing+       Just e ->+         case ceValidUntil e of+           Just validUntil | validUntil < now -> pure Nothing+           _ -> pure (Just $ unsafeCoerce (ceValue e))

+ test/Spec.hs view

@@ -0,0 +1,57 @@+import Test.Hspec++import Data.Time+import Data.Time.TimeSpan++import Control.Monad (replicateM)+import Data.List (nub)+import qualified Data.Cache.Vault as C++main :: IO ()+main =+  hspec $+  do it "allows reading previously written values" $+       do now <- getCurrentTime+          cache <- C.newCache+          let key = C.mintLabeledKey "foo"+          C.insert key Nothing False cache+          C.lookup now key cache `shouldReturn` Just False+     it "expires values" $+       do now <- getCurrentTime+          cache <- C.newCache+          let key = C.mintLabeledKey "foo"+          C.insert key (Just now) False cache+          C.lookup (addUTCTimeTS (minutes 1) now) key cache `shouldReturn` Nothing+     it "deletes values" $+       do now <- getCurrentTime+          cache <- C.newCache+          let key = C.mintLabeledKey "foo"+          C.insert key Nothing False cache+          C.delete key cache+          C.lookup now key cache `shouldReturn` Nothing+     it "purges values" $+       do now <- getCurrentTime+          cache <- C.newCache+          let key = C.mintLabeledKey "foo"+          C.insert key Nothing False cache+          C.reset cache+          C.lookup now key cache `shouldReturn` Nothing+     it "generates distinct unique keys" $+       do keys <- replicateM 200 C.mintUniqKey+          keys `shouldBe` nub keys+     it "differentiates labeled and unique keys" $+       do let key :: C.Key Bool+              key = C.mintLabeledKey "foo"+          uniqKey <- C.mintUniqKey+          key `shouldNotBe` uniqKey+     it "keys with same label of different types are different" $+       do now <- getCurrentTime+          cache <- C.newCache+          let key1 :: C.Key Bool+              key1 = C.mintLabeledKey "foo"++              key2 :: C.Key Int+              key2 = C.mintLabeledKey "foo"+          C.insert key1 Nothing False cache+          C.lookup now key1 cache `shouldReturn` Just False+          C.lookup now key2 cache `shouldReturn` Nothing