{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE DerivingStrategies         #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE NoImplicitPrelude          #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE QuasiQuotes                #-}
{-# LANGUAGE RankNTypes                 #-}
{-# LANGUAGE StandaloneDeriving         #-}
{-# LANGUAGE StrictData                 #-}
{-# LANGUAGE TemplateHaskell            #-}
{-# LANGUAGE TypeApplications           #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE UndecidableInstances       #-}

{-|
Module      : Headroom.IO.KVStore
Description : Key-value persistent store
Copyright   : (c) 2019-2022 Vaclav Svejcar
License     : BSD-3-Clause
Maintainer  : vaclav.svejcar@gmail.com
Stability   : experimental
Portability : POSIX

This is really simple /key-value/ persistent store that uses /SQLite/ as a
backend. Main goal is to provide /type-safe/ way how to define value keys, that
can be later used to set/put the actual value into the store.
-}

module Headroom.IO.KVStore
  ( -- * Type Aliases
    GetValueFn
  , PutValueFn
  , KVStore(..)
    -- * Type Classes
  , ValueCodec(..)
    -- * Data Types
  , ValueKey(..)
  , StorePath(..)
    -- * Public Functions
  , inMemoryKVStore
  , sqliteKVStore
  , valueKey
  )
where

import           Database.Persist                    ( PersistStoreRead(..)
                                                     , PersistStoreWrite(..)
                                                     )
import           Database.Persist.Sqlite             ( runMigrationSilent
                                                     , runSqlite
                                                     )
import           Database.Persist.TH                 ( mkMigrate
                                                     , mkPersist
                                                     , persistLowerCase
                                                     , share
                                                     , 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|
StoreRecord
  Id Text
  value Text
  deriving Show
|]


--------------------------------  TYPE ALIASES  --------------------------------

-- | Gets the value for given 'ValueKey' from the store.
type GetValueFn m
  =  forall a
   . (ValueCodec a)
  => ValueKey a  -- ^ key for the value
  -> m (Maybe a) -- ^ value (if found)


-- | Puts the value for given 'ValueKey' into the store.
type PutValueFn m
  =  forall a
   . (ValueCodec a)
  => ValueKey a -- ^ key for the value
  -> a          -- ^ value to put into store
  -> m ()       -- ^ operation result


-----------------------------  POLYMORPHIC RECORD  -----------------------------

-- | /Polymorphic record/ composed of /key-value/ store operations, allowing to
-- abstract over concrete implementation without (ab)using /type classes/.
data KVStore m = KVStore
  { KVStore m -> forall a. ValueCodec a => ValueKey a -> m (Maybe a)
kvGetValue :: GetValueFn m
  , KVStore m -> forall a. ValueCodec a => ValueKey a -> a -> m ()
kvPutValue :: PutValueFn m
  }


-- | 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 :: StorePath -> KVStore m
sqliteKVStore StorePath
sp =
  KVStore :: forall (m :: * -> *). GetValueFn m -> PutValueFn m -> KVStore m
KVStore { kvGetValue :: GetValueFn m
kvGetValue = StorePath -> GetValueFn m
forall (m :: * -> *). MonadIO m => StorePath -> GetValueFn m
getValueSQLite StorePath
sp, kvPutValue :: PutValueFn m
kvPutValue = StorePath -> PutValueFn m
forall (m :: * -> *). MonadIO m => StorePath -> PutValueFn m
putValueSQLite StorePath
sp }


-- | Constructs non-persistent in-memory instance of 'KVStore'.
inMemoryKVStore :: MonadIO m => m (KVStore m)
inMemoryKVStore :: m (KVStore m)
inMemoryKVStore = do
  IORef (Map Text Text)
ref <- Map Text Text -> m (IORef (Map Text Text))
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef Map Text Text
forall k a. Map k a
M.empty
  KVStore m -> m (KVStore m)
forall (f :: * -> *) a. Applicative f => a -> f a
pure KVStore :: forall (m :: * -> *). GetValueFn m -> PutValueFn m -> KVStore m
KVStore { kvGetValue :: GetValueFn m
kvGetValue = IORef (Map Text Text) -> GetValueFn m
forall (m :: * -> *).
MonadIO m =>
IORef (Map Text Text) -> GetValueFn m
getValueInMemory IORef (Map Text Text)
ref
               , kvPutValue :: PutValueFn m
kvPutValue = IORef (Map Text Text) -> PutValueFn m
forall (m :: * -> *).
MonadIO m =>
IORef (Map Text Text) -> PutValueFn m
putValueInMemory IORef (Map Text Text)
ref
               }

--------------------------------  TYPE CLASSES  --------------------------------

-- | Represents way how to encode/decode concrete types into textual
-- representation used by the store to hold values.
class ValueCodec a where

  -- | Encodes value into textual representation.
  encodeValue :: a    -- ^ value to encode
              -> Text -- ^ textual representation


  -- | Decodes value from textual representation.
  decodeValue :: Text    -- ^ value to decode
              -> Maybe a -- ^ decoded value (if available)


instance ValueCodec Text where
  encodeValue :: Text -> Text
encodeValue = Text -> Text
forall a. a -> a
id
  decodeValue :: Text -> Maybe Text
decodeValue = Text -> Maybe Text
forall a. a -> Maybe a
Just

instance ValueCodec UTCTime where
  encodeValue :: UTCTime -> Text
encodeValue = String -> Text
T.pack (String -> Text) -> (UTCTime -> String) -> UTCTime -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%FT%T%Q"
  decodeValue :: Text -> Maybe UTCTime
decodeValue = Bool -> TimeLocale -> String -> String -> Maybe UTCTime
forall (m :: * -> *) t.
(MonadFail m, ParseTime t) =>
Bool -> TimeLocale -> String -> String -> m t
parseTimeM Bool
True TimeLocale
defaultTimeLocale String
"%FT%T%Q" (String -> Maybe UTCTime)
-> (Text -> String) -> Text -> Maybe UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack

---------------------------------  DATA TYPES  ---------------------------------

-- | /Type-safe/ representation of the key for specific value.
newtype ValueKey a = ValueKey Text deriving (ValueKey a -> ValueKey a -> Bool
(ValueKey a -> ValueKey a -> Bool)
-> (ValueKey a -> ValueKey a -> Bool) -> Eq (ValueKey a)
forall a. ValueKey a -> ValueKey a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ValueKey a -> ValueKey a -> Bool
$c/= :: forall a. ValueKey a -> ValueKey a -> Bool
== :: ValueKey a -> ValueKey a -> Bool
$c== :: forall a. ValueKey a -> ValueKey a -> Bool
Eq, Int -> ValueKey a -> ShowS
[ValueKey a] -> ShowS
ValueKey a -> String
(Int -> ValueKey a -> ShowS)
-> (ValueKey a -> String)
-> ([ValueKey a] -> ShowS)
-> Show (ValueKey a)
forall a. Int -> ValueKey a -> ShowS
forall a. [ValueKey a] -> ShowS
forall a. ValueKey a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ValueKey a] -> ShowS
$cshowList :: forall a. [ValueKey a] -> ShowS
show :: ValueKey a -> String
$cshow :: forall a. ValueKey a -> String
showsPrec :: Int -> ValueKey a -> ShowS
$cshowsPrec :: forall a. Int -> ValueKey a -> ShowS
Show)


-- | Constructor function for 'ValueKey'.
valueKey :: Text -> ValueKey a
valueKey :: Text -> ValueKey a
valueKey = Text -> ValueKey a
forall a. Text -> ValueKey a
ValueKey


-- | Path to the store (e.g. path of the /SQLite/ database on filesystem).
newtype StorePath = StorePath Text deriving (StorePath -> StorePath -> Bool
(StorePath -> StorePath -> Bool)
-> (StorePath -> StorePath -> Bool) -> Eq StorePath
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: StorePath -> StorePath -> Bool
$c/= :: StorePath -> StorePath -> Bool
== :: StorePath -> StorePath -> Bool
$c== :: StorePath -> StorePath -> Bool
Eq, Int -> StorePath -> ShowS
[StorePath] -> ShowS
StorePath -> String
(Int -> StorePath -> ShowS)
-> (StorePath -> String)
-> ([StorePath] -> ShowS)
-> Show StorePath
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [StorePath] -> ShowS
$cshowList :: [StorePath] -> ShowS
show :: StorePath -> String
$cshow :: StorePath -> String
showsPrec :: Int -> StorePath -> ShowS
$cshowsPrec :: Int -> StorePath -> ShowS
Show)


------------------------------  PRIVATE FUNCTIONS  -----------------------------

getValueInMemory :: MonadIO m => IORef (Map Text Text) -> GetValueFn m
getValueInMemory :: IORef (Map Text Text) -> GetValueFn m
getValueInMemory IORef (Map Text Text)
ref (ValueKey Text
key) = do
  Map Text Text
storeMap <- IORef (Map Text Text) -> m (Map Text Text)
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef (Map Text Text)
ref
  Maybe a -> m (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe a -> m (Maybe a)) -> Maybe a -> m (Maybe a)
forall a b. (a -> b) -> a -> b
$ Text -> Map Text Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
key Map Text Text
storeMap Maybe Text -> (Text -> Maybe a) -> Maybe a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Maybe a
forall a. ValueCodec a => Text -> Maybe a
decodeValue


putValueInMemory :: MonadIO m => IORef (Map Text Text) -> PutValueFn m
putValueInMemory :: IORef (Map Text Text) -> PutValueFn m
putValueInMemory IORef (Map Text Text)
ref (ValueKey Text
key) a
value = do
  IORef (Map Text Text) -> (Map Text Text -> Map Text Text) -> m ()
forall (m :: * -> *) a. MonadIO m => IORef a -> (a -> a) -> m ()
modifyIORef IORef (Map Text Text)
ref ((Map Text Text -> Map Text Text) -> m ())
-> (Map Text Text -> Map Text Text) -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Map Text Text -> Map Text Text
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Text
key (a -> Text
forall a. ValueCodec a => a -> Text
encodeValue a
value)
  () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()


getValueSQLite :: MonadIO m => StorePath -> GetValueFn m
getValueSQLite :: StorePath -> GetValueFn m
getValueSQLite (StorePath Text
path) (ValueKey Text
key) = do
  IO (Maybe a) -> m (Maybe a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe a) -> m (Maybe a))
-> (ReaderT SqlBackend (NoLoggingT (ResourceT IO)) (Maybe a)
    -> IO (Maybe a))
-> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) (Maybe a)
-> m (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text
-> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) (Maybe a)
-> IO (Maybe a)
forall (m :: * -> *) a.
MonadUnliftIO m =>
Text -> ReaderT SqlBackend (NoLoggingT (ResourceT m)) a -> m a
runSqlite Text
path (ReaderT SqlBackend (NoLoggingT (ResourceT IO)) (Maybe a)
 -> m (Maybe a))
-> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) (Maybe a)
-> m (Maybe a)
forall a b. (a -> b) -> a -> b
$ do
    [Text]
_          <- Migration -> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) [Text]
forall (m :: * -> *).
MonadUnliftIO m =>
Migration -> ReaderT SqlBackend m [Text]
runMigrationSilent Migration
migrateAll
    Maybe StoreRecord
maybeValue <- Key StoreRecord
-> ReaderT
     SqlBackend (NoLoggingT (ResourceT IO)) (Maybe StoreRecord)
forall backend record (m :: * -> *).
(PersistStoreRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
Key record -> ReaderT backend m (Maybe record)
get (Key StoreRecord
 -> ReaderT
      SqlBackend (NoLoggingT (ResourceT IO)) (Maybe StoreRecord))
-> Key StoreRecord
-> ReaderT
     SqlBackend (NoLoggingT (ResourceT IO)) (Maybe StoreRecord)
forall a b. (a -> b) -> a -> b
$ Text -> Key StoreRecord
StoreRecordKey Text
key
    case Maybe StoreRecord
maybeValue of
      Just (StoreRecord Text
v) -> Maybe a -> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe a
 -> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) (Maybe a))
-> (Text -> Maybe a)
-> Text
-> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Maybe a
forall a. ValueCodec a => Text -> Maybe a
decodeValue (Text -> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) (Maybe a))
-> Text -> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) (Maybe a)
forall a b. (a -> b) -> a -> b
$ Text
v
      Maybe StoreRecord
Nothing              -> Maybe a -> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing


putValueSQLite :: MonadIO m => StorePath -> PutValueFn m
putValueSQLite :: StorePath -> PutValueFn m
putValueSQLite (StorePath Text
path) (ValueKey Text
key) a
value = do
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ())
-> (ReaderT SqlBackend (NoLoggingT (ResourceT IO)) () -> IO ())
-> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) ()
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) () -> IO ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
Text -> ReaderT SqlBackend (NoLoggingT (ResourceT m)) a -> m a
runSqlite Text
path (ReaderT SqlBackend (NoLoggingT (ResourceT IO)) () -> m ())
-> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    [Text]
_ <- Migration -> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) [Text]
forall (m :: * -> *).
MonadUnliftIO m =>
Migration -> ReaderT SqlBackend m [Text]
runMigrationSilent Migration
migrateAll
    Key StoreRecord
-> StoreRecord -> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) ()
forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
Key record -> record -> ReaderT backend m ()
repsert (Text -> Key StoreRecord
StoreRecordKey Text
key) (Text -> StoreRecord
StoreRecord (Text -> StoreRecord) -> Text -> StoreRecord
forall a b. (a -> b) -> a -> b
$ a -> Text
forall a. ValueCodec a => a -> Text
encodeValue a
value)