From 6b861de9c1ea8524ad3dda1749043e51f4904184 Mon Sep 17 00:00:00 2001 From: Vaclav Svejcar Date: Mon, 2 Aug 2021 16:13:18 +0200 Subject: [PATCH] [#78] Introduce Cache + SQLite backend --- headroom.cabal | 7 +- package.yaml | 2 + src/Headroom/IO/Cache.hs | 98 +++++++++++++++++++++++ src/Headroom/IO/Cache/SQLite.hs | 111 +++++++++++++++++++++++++++ test/Headroom/IO/Cache/SQLiteSpec.hs | 34 ++++++++ 5 files changed, 251 insertions(+), 1 deletion(-) create mode 100644 src/Headroom/IO/Cache.hs create mode 100644 src/Headroom/IO/Cache/SQLite.hs create mode 100644 test/Headroom/IO/Cache/SQLiteSpec.hs diff --git a/headroom.cabal b/headroom.cabal index 36a1c52..c70bcde 100644 --- a/headroom.cabal +++ b/headroom.cabal @@ -4,7 +4,7 @@ cabal-version: 2.2 -- -- see: https://github.com/sol/hpack -- --- hash: 3845aee60e6509e43b9ea9ad092405846976b023c0e54af2c6587198799158ba +-- hash: dcc10e87079fd164b265fca5b32d9c72bdd5fac387d925787458af66b0d7208a name: headroom version: 0.4.3.0 @@ -175,6 +175,8 @@ library Headroom.Header Headroom.Header.Sanitize Headroom.Header.Types + Headroom.IO.Cache + Headroom.IO.Cache.SQLite Headroom.IO.FileSystem Headroom.IO.Network Headroom.Meta @@ -216,6 +218,8 @@ library , optparse-applicative , pcre-heavy , pcre-light + , persistent + , persistent-sqlite , req , rio , string-interpolate @@ -286,6 +290,7 @@ test-suite spec Headroom.FileTypeSpec Headroom.Header.SanitizeSpec Headroom.HeaderSpec + Headroom.IO.Cache.SQLiteSpec Headroom.IO.FileSystemSpec Headroom.Meta.VersionSpec Headroom.PostProcess.TypesSpec diff --git a/package.yaml b/package.yaml index 7daa30f..0fdbd1d 100644 --- a/package.yaml +++ b/package.yaml @@ -76,6 +76,8 @@ library: - mustache - pcre-light - pcre-heavy + - persistent + - persistent-sqlite - req - string-interpolate - template-haskell diff --git a/src/Headroom/IO/Cache.hs b/src/Headroom/IO/Cache.hs new file mode 100644 index 0000000..b55def6 --- /dev/null +++ b/src/Headroom/IO/Cache.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} + +{-| +Module : Headroom.IO.Cache +Description : Support for Cache implementations +Copyright : (c) 2019-2021 Vaclav Svejcar +License : BSD-3-Clause +Maintainer : vaclav.svejcar@gmail.com +Stability : experimental +Portability : POSIX + +This module provides abstract key/value cache representation that allows to +implement specific in-memory/persistent backends. +-} + +module Headroom.IO.Cache + ( -- * Data Types + Cache(..) + , CacheT + , CacheKey(..) + , ValueCodec(..) + , ValueRepr + -- * Helper Functions + , cacheKey + , withCache + ) +where + +import RIO + + +--------------------------------- DATA TYPES --------------------------------- + +-- | Represents key/value cache. Whether this cache is persistent or not is +-- dependend on the concrete implementation. Operation over keys is done in +-- type-safe manner by declaring them using 'CacheKey'. Cache can store any +-- value type for which the instance of 'ValueCodec' is defined. +class Cache c where + + -- | Gets value for given key from the cache (if exists). + getValue :: forall a m. (ValueCodec c a, MonadIO m) + => CacheKey a -- ^ key + -> CacheT c m (Maybe a) -- ^ value (if found) + + -- | Sets value for given key in the cache. If the value already exists, it's + -- replaced by the new value. + setValue :: forall a m. (ValueCodec c a, MonadIO m) + => CacheKey a -- ^ key + -> a -- ^ value to store + -> CacheT c m () -- ^ operation result + + +-- | Transformer monad type for cache operations. +type CacheT = ReaderT + + +-- | Type class providing support to decode/encode given value for given 'Cache' +-- instance. +class ValueCodec c a where + + -- | Encodes value into type recognized by given 'Cache' instance. + encodeValue :: a -- ^ value to encode + -> ValueRepr c -- ^ encoded representation + + -- | Decodes value from type recognized by given 'Cache' instance. + decodeValue :: ValueRepr c -- ^ encoded representation + -> Maybe a -- ^ decoded value + + +-- | Representation of encoded cache value, specific to the given 'Cache' +-- instance. Main point is that each 'Cache' instance might need to +-- encode/decode given type into some internal representation. Using this type +-- family, it's possible to define such representation in type safe manner. +type family ValueRepr c + + +-- | Type safe representation of cache key. +newtype CacheKey a = CacheEntry Text deriving (Eq, Show) + + +------------------------------ PUBLIC FUNCTIONS ------------------------------ + +-- | Constructor function for 'CacheKey'. +cacheKey :: Text -- ^ name of the key + -> CacheKey a -- ^ type safe representation +cacheKey = CacheEntry + + +-- | Runs the monadic cache operation using the given 'Cache' instance. +withCache :: c -- ^ 'Cache' instance to use + -> CacheT c m a -- ^ operations over cache + -> m a -- ^ operation result +withCache cache op = runReaderT op cache diff --git a/src/Headroom/IO/Cache/SQLite.hs b/src/Headroom/IO/Cache/SQLite.hs new file mode 100644 index 0000000..c2ff7c0 --- /dev/null +++ b/src/Headroom/IO/Cache/SQLite.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +{-| +Module : Headroom.IO.Cache.SQLite +Description : /SQLite/ backend for cache support +Copyright : (c) 2019-2021 Vaclav Svejcar +License : BSD-3-Clause +Maintainer : vaclav.svejcar@gmail.com +Stability : experimental +Portability : POSIX + +Persistent 'Cache' implementation using /SQLite/ as backend store. This +implementation is quite crude and definitely not great performance-wise, but +given the intended use it should be good enough for now. +-} + +module Headroom.IO.Cache.SQLite + ( SQLiteCache(..) + ) +where + +import Database.Persist +import Database.Persist.Sqlite ( runMigrationSilent + , runSqlite + ) +import Database.Persist.TH +import qualified Headroom.Data.Text as T +import Headroom.IO.Cache ( Cache(..) + , CacheKey(..) + , CacheT + , ValueCodec(..) + , ValueRepr + ) +import RIO +import qualified RIO.Text as T + + +------------------------------ TEMPLATE HASKELL ------------------------------ + +share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| +CacheStore + Id Text + value Text + deriving Show +|] + + +--------------------------------- DATA TYPES --------------------------------- + +-- | Persistent cache implementation using /SQLite/ as backend store. +newtype SQLiteCache = SQLiteCache Text deriving (Eq, Show) + + +instance Cache SQLiteCache where + getValue = getValue' + setValue = setValue' + + +type instance ValueRepr SQLiteCache = Text + + +instance ValueCodec SQLiteCache Int where + encodeValue = T.pack . show + decodeValue = T.read + + +instance ValueCodec SQLiteCache Text where + encodeValue = id + decodeValue = Just + + +------------------------------ PRIVATE FUNCTIONS ----------------------------- + +getValue' :: (ValueCodec SQLiteCache a, MonadIO m) + => CacheKey a + -> CacheT SQLiteCache m (Maybe a) +getValue' (CacheEntry key) = do + SQLiteCache connPath <- ask + liftIO . runSqlite connPath $ do + _ <- runMigrationSilent migrateAll + maybeValue <- get $ CacheStoreKey key + case maybeValue of + Just (CacheStore v) -> pure . decodeValue @SQLiteCache $ v + Nothing -> pure Nothing + + +setValue' :: (ValueCodec SQLiteCache a, MonadIO m) + => CacheKey a + -> a + -> CacheT SQLiteCache m () +setValue' (CacheEntry key) value = do + SQLiteCache connPath <- ask + let newValue = encodeValue @SQLiteCache value + liftIO . runSqlite connPath $ do + _ <- runMigrationSilent migrateAll + repsert (CacheStoreKey key) (CacheStore newValue) diff --git a/test/Headroom/IO/Cache/SQLiteSpec.hs b/test/Headroom/IO/Cache/SQLiteSpec.hs new file mode 100644 index 0000000..23b7a19 --- /dev/null +++ b/test/Headroom/IO/Cache/SQLiteSpec.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module Headroom.IO.Cache.SQLiteSpec + ( spec + ) +where + +import Headroom.IO.Cache +import Headroom.IO.Cache.SQLite +import RIO +import RIO.FilePath ( () ) +import qualified RIO.Text as T +import Test.Hspec + + +spec :: Spec +spec = do + + describe "SQLiteCache instance of Cache" $ do + it "reads and writes values from/to cache" $ do + withSystemTempDirectory "sqlite-cache" $ \dir -> do + let cache = SQLiteCache . T.pack $ dir "test-db.sqlite" + nameKey = cacheKey @Text "name" + yearKey = cacheKey @Int "year" + (maybeName, maybeYear) <- withCache cache $ do + name <- getValue nameKey + _ <- setValue yearKey 41 + _ <- setValue yearKey 42 + year <- getValue yearKey + pure (name, year) + maybeName `shouldBe` Nothing + maybeYear `shouldBe` Just 42