{-# 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
(
GetValueFn
, PutValueFn
, KVStore(..)
, ValueCodec(..)
, ValueKey(..)
, StorePath(..)
, 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
)
share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
StoreRecord
Id Text
value Text
deriving Show
|]
type GetValueFn m
= forall a
. (ValueCodec a)
=> ValueKey a
-> m (Maybe a)
type PutValueFn m
= forall a
. (ValueCodec a)
=> ValueKey a
-> a
-> m ()
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
}
sqliteKVStore :: MonadIO m
=> StorePath
-> KVStore m
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 }
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
}
class ValueCodec a where
encodeValue :: a
-> Text
decodeValue :: Text
-> Maybe a
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
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)
valueKey :: Text -> ValueKey a
valueKey :: Text -> ValueKey a
valueKey = Text -> ValueKey a
forall a. Text -> ValueKey a
ValueKey
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)
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)