[#78] Introduce Cache + SQLite backend

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

package.yaml

@@ -76,6 +76,8 @@ library:
     - mustache
     - pcre-light
     - pcre-heavy
+    - persistent
+    - persistent-sqlite
     - req
     - string-interpolate
     - template-haskell

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  : [email protected]
+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

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  : [email protected]
+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)

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