[#78] Add in-memory implementation of KVStore

src/Headroom/IO/KVStore.hs

@@ -41,10 +41,9 @@ module Headroom.IO.KVStore
   , ValueKey(..)
   , StorePath(..)
     -- * Public Functions
+  , inMemoryKVStore
   , sqliteKVStore
   , valueKey
-  , getValue
-  , putValue
   )
 where
 
@@ -61,14 +60,14 @@ import           Database.Persist.TH                 ( mkMigrate
                                                      , sqlSettings
                                                      )
 import           RIO
+import qualified RIO.Map                            as M
 import qualified RIO.Text                           as T
 import           RIO.Time                            ( UTCTime
                                                      , defaultTimeLocale
                                                      , formatTime
                                                      , parseTimeM
                                                      )
 
-
 ------------------------------  TEMPLATE HASKELL  ------------------------------
 
 share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
@@ -108,12 +107,21 @@ data KVStore m = KVStore
   }
 
 
--- | Constructs the default 'KVStore' that uses /SQLite/ as a backend.
+-- | Constructs persistent instance of 'KVStore' that uses /SQLite/ as a backend.
 sqliteKVStore :: MonadIO m
               => StorePath -- ^ path of the store location
               -> KVStore m -- ^ store instance
 sqliteKVStore sp =
-  KVStore { kvGetValue = getValue sp, kvPutValue = putValue sp }
+  KVStore { kvGetValue = getValueSQLite sp, kvPutValue = putValueSQLite sp }
+
+
+-- | Constructs non-persistent in-memory instance of 'KVStore'.
+inMemoryKVStore :: MonadIO m => m (KVStore m)
+inMemoryKVStore = do
+  ref <- newIORef M.empty
+  pure KVStore { kvGetValue = getValueInMemory ref
+               , kvPutValue = putValueInMemory ref
+               }
 
 --------------------------------  TYPE CLASSES  --------------------------------
 
@@ -154,11 +162,22 @@ valueKey = ValueKey
 newtype StorePath = StorePath Text deriving (Eq, Show)
 
 
-------------------------------  PUBLIC FUNCTIONS  ------------------------------
+------------------------------  PRIVATE FUNCTIONS  -----------------------------
+
+getValueInMemory :: MonadIO m => IORef (Map Text Text) -> GetValueFn m
+getValueInMemory ref (ValueKey key) = do
+  storeMap <- readIORef ref
+  pure $ M.lookup key storeMap >>= decodeValue
+
+
+putValueInMemory :: MonadIO m => IORef (Map Text Text) -> PutValueFn m
+putValueInMemory ref (ValueKey key) value = do
+  modifyIORef ref $ M.insert key (encodeValue value)
+  pure ()
+
 
--- | Implementation of 'GetValueFn' that gets value from /SQLite/.
-getValue :: MonadIO m => StorePath -> GetValueFn m
-getValue (StorePath path) (ValueKey key) = do
+getValueSQLite :: MonadIO m => StorePath -> GetValueFn m
+getValueSQLite (StorePath path) (ValueKey key) = do
   liftIO . runSqlite path $ do
     _          <- runMigrationSilent migrateAll
     maybeValue <- get $ StoreRecordKey key
@@ -167,9 +186,8 @@ getValue (StorePath path) (ValueKey key) = do
       Nothing              -> pure Nothing
 
 
--- | Implementation of 'PutValueFn' that puts value to /SQLite/.
-putValue :: MonadIO m => StorePath -> PutValueFn m
-putValue (StorePath path) (ValueKey key) value = do
+putValueSQLite :: MonadIO m => StorePath -> PutValueFn m
+putValueSQLite (StorePath path) (ValueKey key) value = do
   liftIO . runSqlite path $ do
     _ <- runMigrationSilent migrateAll
     repsert (StoreRecordKey key) (StoreRecord $ encodeValue value)

test/Headroom/IO/KvStoreSpec.hs

@@ -19,7 +19,7 @@ import           Test.Hspec
 spec :: Spec
 spec = do
 
-  describe "getValue/putValue" $ do
+  describe "SQLite store" $ do
     it "reads and writes values from/to store" $ do
       withSystemTempDirectory "sqlite-kvstore" $ \dir -> do
         let path         = StorePath . T.pack $ dir </> "test-db.sqlite"
@@ -34,6 +34,19 @@ spec = do
         maybeSnd `shouldBe` Just "bar"
 
 
+  describe "In-memory store" $ do
+    it "reads and writes values from/to store" $ do
+      let fstKey = valueKey @Text "fst-key"
+          sndKey = valueKey @Text "snd-key"
+      KVStore {..} <- inMemoryKVStore
+      maybeFst     <- kvGetValue fstKey
+      _            <- kvPutValue sndKey "foo"
+      _            <- kvPutValue sndKey "bar"
+      maybeSnd     <- kvGetValue sndKey
+      maybeFst `shouldBe` Nothing
+      maybeSnd `shouldBe` Just "bar"
+
+
   describe "ValueCodec type class" $ do
     it "has working instance for Text" $ do
       let sample = "The Cake is a Lie"