{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE ExplicitForAll #-}
module Database.Persist.Class.PersistStore
( HasPersistBackend (..)
, withBaseBackend
, IsPersistBackend (..)
, PersistRecordBackend
, liftPersist
, PersistCore (..)
, PersistStoreRead (..)
, PersistStoreWrite (..)
, getEntity
, getJust
, getJustEntity
, belongsTo
, belongsToJust
, insertEntity
, insertRecord
, ToBackendKey(..)
, BackendCompatible(..)
, withCompatibleBackend
) where
import Control.Exception (throwIO)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Reader (MonadReader (ask), runReaderT)
import Control.Monad.Trans.Reader (ReaderT, withReaderT)
import qualified Data.Aeson as A
import Data.Map (Map)
import qualified Data.Map as Map
import qualified Data.Maybe as Maybe
import qualified Data.Text as T
import GHC.Stack
import Database.Persist.Class.PersistEntity
import Database.Persist.Class.PersistField
import Database.Persist.Types
class HasPersistBackend backend where
type BaseBackend backend
persistBackend :: backend -> BaseBackend backend
withBaseBackend :: (HasPersistBackend backend)
=> ReaderT (BaseBackend backend) m a -> ReaderT backend m a
withBaseBackend :: ReaderT (BaseBackend backend) m a -> ReaderT backend m a
withBaseBackend = (backend -> BaseBackend backend)
-> ReaderT (BaseBackend backend) m a -> ReaderT backend m a
forall r' r (m :: * -> *) a.
(r' -> r) -> ReaderT r m a -> ReaderT r' m a
withReaderT backend -> BaseBackend backend
forall backend.
HasPersistBackend backend =>
backend -> BaseBackend backend
persistBackend
class (HasPersistBackend backend) => IsPersistBackend backend where
mkPersistBackend :: BaseBackend backend -> backend
class BackendCompatible sup sub where
projectBackend :: sub -> sup
withCompatibleBackend :: (BackendCompatible sup sub)
=> ReaderT sup m a -> ReaderT sub m a
withCompatibleBackend :: ReaderT sup m a -> ReaderT sub m a
withCompatibleBackend = (sub -> sup) -> ReaderT sup m a -> ReaderT sub m a
forall r' r (m :: * -> *) a.
(r' -> r) -> ReaderT r m a -> ReaderT r' m a
withReaderT sub -> sup
forall sup sub. BackendCompatible sup sub => sub -> sup
projectBackend
type PersistRecordBackend record backend = (PersistEntity record, PersistEntityBackend record ~ BaseBackend backend)
liftPersist
:: (MonadIO m, MonadReader backend m)
=> ReaderT backend IO b -> m b
liftPersist :: ReaderT backend IO b -> m b
liftPersist ReaderT backend IO b
f = do
backend
env <- m backend
forall r (m :: * -> *). MonadReader r m => m r
ask
IO b -> m b
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO b -> m b) -> IO b -> m b
forall a b. (a -> b) -> a -> b
$ ReaderT backend IO b -> backend -> IO b
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT backend IO b
f backend
env
class ( PersistEntity record
, PersistEntityBackend record ~ backend
, PersistCore backend
) => ToBackendKey backend record where
toBackendKey :: Key record -> BackendKey backend
fromBackendKey :: BackendKey backend -> Key record
class PersistCore backend where
data BackendKey backend
class
( Show (BackendKey backend), Read (BackendKey backend)
, Eq (BackendKey backend), Ord (BackendKey backend)
, PersistCore backend
, PersistField (BackendKey backend), A.ToJSON (BackendKey backend), A.FromJSON (BackendKey backend)
) => PersistStoreRead backend where
get :: forall record m. (MonadIO m, PersistRecordBackend record backend)
=> Key record -> ReaderT backend m (Maybe record)
getMany
:: forall record m. (MonadIO m, PersistRecordBackend record backend)
=> [Key record] -> ReaderT backend m (Map (Key record) record)
getMany [] = Map (Key record) record
-> ReaderT backend m (Map (Key record) record)
forall (m :: * -> *) a. Monad m => a -> m a
return Map (Key record) record
forall k a. Map k a
Map.empty
getMany [Key record]
ks = do
[Maybe record]
vs <- (Key record -> ReaderT backend m (Maybe record))
-> [Key record] -> ReaderT backend m [Maybe record]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Key record -> ReaderT backend m (Maybe record)
forall backend record (m :: * -> *).
(PersistStoreRead backend, MonadIO m,
PersistRecordBackend record backend) =>
Key record -> ReaderT backend m (Maybe record)
get [Key record]
ks
let kvs :: [(Key record, Maybe record)]
kvs = [Key record] -> [Maybe record] -> [(Key record, Maybe record)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Key record]
ks [Maybe record]
vs
let kvs' :: [(Key record, record)]
kvs' = ((Maybe record -> record)
-> (Key record, Maybe record) -> (Key record, record)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe record -> record
forall a. HasCallStack => Maybe a -> a
Maybe.fromJust) ((Key record, Maybe record) -> (Key record, record))
-> [(Key record, Maybe record)] -> [(Key record, record)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` ((Key record, Maybe record) -> Bool)
-> [(Key record, Maybe record)] -> [(Key record, Maybe record)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Key record
_,Maybe record
v) -> Maybe record -> Bool
forall a. Maybe a -> Bool
Maybe.isJust Maybe record
v) [(Key record, Maybe record)]
kvs
Map (Key record) record
-> ReaderT backend m (Map (Key record) record)
forall (m :: * -> *) a. Monad m => a -> m a
return (Map (Key record) record
-> ReaderT backend m (Map (Key record) record))
-> Map (Key record) record
-> ReaderT backend m (Map (Key record) record)
forall a b. (a -> b) -> a -> b
$ [(Key record, record)] -> Map (Key record) record
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Key record, record)]
kvs'
class
( Show (BackendKey backend), Read (BackendKey backend)
, Eq (BackendKey backend), Ord (BackendKey backend)
, PersistStoreRead backend
, PersistField (BackendKey backend), A.ToJSON (BackendKey backend), A.FromJSON (BackendKey backend)
) => PersistStoreWrite backend where
insert :: forall record m. (MonadIO m, PersistRecordBackend record backend, SafeToInsert record)
=> record -> ReaderT backend m (Key record)
insert_ :: forall record m. (MonadIO m, PersistRecordBackend record backend, SafeToInsert record)
=> record -> ReaderT backend m ()
insert_ record
record = record -> ReaderT backend m (Key record)
forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
PersistRecordBackend record backend, SafeToInsert record) =>
record -> ReaderT backend m (Key record)
insert record
record ReaderT backend m (Key record)
-> ReaderT backend m () -> ReaderT backend m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> ReaderT backend m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
insertMany :: forall record m. (MonadIO m, PersistRecordBackend record backend, SafeToInsert record)
=> [record] -> ReaderT backend m [Key record]
insertMany = (record -> ReaderT backend m (Key record))
-> [record] -> ReaderT backend m [Key record]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM record -> ReaderT backend m (Key record)
forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
PersistRecordBackend record backend, SafeToInsert record) =>
record -> ReaderT backend m (Key record)
insert
insertMany_ :: forall record m. (MonadIO m, PersistRecordBackend record backend, SafeToInsert record)
=> [record] -> ReaderT backend m ()
insertMany_ [record]
x = [record] -> ReaderT backend m [Key record]
forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
PersistRecordBackend record backend, SafeToInsert record) =>
[record] -> ReaderT backend m [Key record]
insertMany [record]
x ReaderT backend m [Key record]
-> ReaderT backend m () -> ReaderT backend m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> ReaderT backend m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
insertEntityMany :: forall record m. (MonadIO m, PersistRecordBackend record backend)
=> [Entity record] -> ReaderT backend m ()
insertEntityMany = (Entity record -> ReaderT backend m ())
-> [Entity record] -> ReaderT backend m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(Entity Key record
k record
record) -> Key record -> record -> ReaderT backend m ()
forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
PersistRecordBackend record backend) =>
Key record -> record -> ReaderT backend m ()
insertKey Key record
k record
record)
insertKey :: forall record m. (MonadIO m, PersistRecordBackend record backend)
=> Key record -> record -> ReaderT backend m ()
repsert :: forall record m. (MonadIO m, PersistRecordBackend record backend)
=> Key record -> record -> ReaderT backend m ()
repsertMany
:: forall record m. (MonadIO m, PersistRecordBackend record backend)
=> [(Key record, record)] -> ReaderT backend m ()
repsertMany = ((Key record, record) -> ReaderT backend m ())
-> [(Key record, record)] -> ReaderT backend m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((Key record -> record -> ReaderT backend m ())
-> (Key record, record) -> ReaderT backend m ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Key record -> record -> ReaderT backend m ()
forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
PersistRecordBackend record backend) =>
Key record -> record -> ReaderT backend m ()
repsert)
replace :: forall record m. (MonadIO m, PersistRecordBackend record backend)
=> Key record -> record -> ReaderT backend m ()
delete :: forall record m. (MonadIO m, PersistRecordBackend record backend)
=> Key record -> ReaderT backend m ()
update :: forall record m. (MonadIO m, PersistRecordBackend record backend)
=> Key record -> [Update record] -> ReaderT backend m ()
updateGet :: forall record m. (MonadIO m, PersistRecordBackend record backend)
=> Key record -> [Update record] -> ReaderT backend m record
updateGet Key record
key [Update record]
ups = do
Key record -> [Update record] -> ReaderT backend m ()
forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
PersistRecordBackend record backend) =>
Key record -> [Update record] -> ReaderT backend m ()
update Key record
key [Update record]
ups
Key record -> ReaderT backend m (Maybe record)
forall backend record (m :: * -> *).
(PersistStoreRead backend, MonadIO m,
PersistRecordBackend record backend) =>
Key record -> ReaderT backend m (Maybe record)
get Key record
key ReaderT backend m (Maybe record)
-> (Maybe record -> ReaderT backend m record)
-> ReaderT backend m record
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ReaderT backend m record
-> (record -> ReaderT backend m record)
-> Maybe record
-> ReaderT backend m record
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (IO record -> ReaderT backend m record
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO record -> ReaderT backend m record)
-> IO record -> ReaderT backend m record
forall a b. (a -> b) -> a -> b
$ UpdateException -> IO record
forall e a. Exception e => e -> IO a
throwIO (UpdateException -> IO record) -> UpdateException -> IO record
forall a b. (a -> b) -> a -> b
$ String -> UpdateException
KeyNotFound (String -> UpdateException) -> String -> UpdateException
forall a b. (a -> b) -> a -> b
$ Key record -> String
forall a. Show a => a -> String
show Key record
key) record -> ReaderT backend m record
forall (m :: * -> *) a. Monad m => a -> m a
return
getJust :: forall record backend m.
( PersistStoreRead backend
, PersistRecordBackend record backend
, MonadIO m)
=> Key record -> ReaderT backend m record
getJust :: Key record -> ReaderT backend m record
getJust Key record
key = Key record -> ReaderT backend m (Maybe record)
forall backend record (m :: * -> *).
(PersistStoreRead backend, MonadIO m,
PersistRecordBackend record backend) =>
Key record -> ReaderT backend m (Maybe record)
get Key record
key ReaderT backend m (Maybe record)
-> (Maybe record -> ReaderT backend m record)
-> ReaderT backend m record
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ReaderT backend m record
-> (record -> ReaderT backend m record)
-> Maybe record
-> ReaderT backend m record
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
(IO record -> ReaderT backend m record
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO record -> ReaderT backend m record)
-> IO record -> ReaderT backend m record
forall a b. (a -> b) -> a -> b
$ PersistException -> IO record
forall e a. Exception e => e -> IO a
throwIO (PersistException -> IO record) -> PersistException -> IO record
forall a b. (a -> b) -> a -> b
$ Text -> PersistException
PersistForeignConstraintUnmet (Text -> PersistException) -> Text -> PersistException
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Key record -> String
forall a. Show a => a -> String
show Key record
key)
record -> ReaderT backend m record
forall (m :: * -> *) a. Monad m => a -> m a
return
getJustEntity :: forall record backend m.
( PersistEntityBackend record ~ BaseBackend backend
, MonadIO m
, PersistEntity record
, PersistStoreRead backend)
=> Key record -> ReaderT backend m (Entity record)
getJustEntity :: Key record -> ReaderT backend m (Entity record)
getJustEntity Key record
key = do
record
record <- Key record -> ReaderT backend m record
forall record backend (m :: * -> *).
(PersistStoreRead backend, PersistRecordBackend record backend,
MonadIO m) =>
Key record -> ReaderT backend m record
getJust Key record
key
Entity record -> ReaderT backend m (Entity record)
forall (m :: * -> *) a. Monad m => a -> m a
return (Entity record -> ReaderT backend m (Entity record))
-> Entity record -> ReaderT backend m (Entity record)
forall a b. (a -> b) -> a -> b
$
Entity :: forall rec. Key rec -> rec -> Entity rec
Entity
{ entityKey :: Key record
entityKey = Key record
key
, entityVal :: record
entityVal = record
record
}
belongsTo :: forall ent1 ent2 backend m.
( PersistStoreRead backend
, PersistEntity ent1
, PersistRecordBackend ent2 backend
, MonadIO m
) => (ent1 -> Maybe (Key ent2)) -> ent1 -> ReaderT backend m (Maybe ent2)
belongsTo :: (ent1 -> Maybe (Key ent2))
-> ent1 -> ReaderT backend m (Maybe ent2)
belongsTo ent1 -> Maybe (Key ent2)
foreignKeyField ent1
model = case ent1 -> Maybe (Key ent2)
foreignKeyField ent1
model of
Maybe (Key ent2)
Nothing -> Maybe ent2 -> ReaderT backend m (Maybe ent2)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ent2
forall a. Maybe a
Nothing
Just Key ent2
f -> Key ent2 -> ReaderT backend m (Maybe ent2)
forall backend record (m :: * -> *).
(PersistStoreRead backend, MonadIO m,
PersistRecordBackend record backend) =>
Key record -> ReaderT backend m (Maybe record)
get Key ent2
f
belongsToJust :: forall ent1 ent2 backend m.
( PersistStoreRead backend
, PersistEntity ent1
, PersistRecordBackend ent2 backend
, MonadIO m
)
=> (ent1 -> Key ent2) -> ent1 -> ReaderT backend m ent2
belongsToJust :: (ent1 -> Key ent2) -> ent1 -> ReaderT backend m ent2
belongsToJust ent1 -> Key ent2
getForeignKey ent1
model = Key ent2 -> ReaderT backend m ent2
forall record backend (m :: * -> *).
(PersistStoreRead backend, PersistRecordBackend record backend,
MonadIO m) =>
Key record -> ReaderT backend m record
getJust (Key ent2 -> ReaderT backend m ent2)
-> Key ent2 -> ReaderT backend m ent2
forall a b. (a -> b) -> a -> b
$ ent1 -> Key ent2
getForeignKey ent1
model
insertEntity :: forall e backend m.
( PersistStoreWrite backend
, PersistRecordBackend e backend
, SafeToInsert e
, MonadIO m
, HasCallStack
) => e -> ReaderT backend m (Entity e)
insertEntity :: e -> ReaderT backend m (Entity e)
insertEntity e
e = do
Key e
eid <- e -> ReaderT backend m (Key e)
forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
PersistRecordBackend record backend, SafeToInsert record) =>
record -> ReaderT backend m (Key record)
insert e
e
Entity e -> Maybe (Entity e) -> Entity e
forall a. a -> Maybe a -> a
Maybe.fromMaybe (String -> Entity e
forall a. HasCallStack => String -> a
error String
errorMessage) (Maybe (Entity e) -> Entity e)
-> ReaderT backend m (Maybe (Entity e))
-> ReaderT backend m (Entity e)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Key e -> ReaderT backend m (Maybe (Entity e))
forall e backend (m :: * -> *).
(PersistStoreRead backend, PersistRecordBackend e backend,
MonadIO m) =>
Key e -> ReaderT backend m (Maybe (Entity e))
getEntity Key e
eid
where
errorMessage :: String
errorMessage =
String
"persistent: failed to get record from database despite receiving key from the database"
getEntity :: forall e backend m.
( PersistStoreRead backend
, PersistRecordBackend e backend
, MonadIO m
) => Key e -> ReaderT backend m (Maybe (Entity e))
getEntity :: Key e -> ReaderT backend m (Maybe (Entity e))
getEntity Key e
key = do
Maybe e
maybeModel <- Key e -> ReaderT backend m (Maybe e)
forall backend record (m :: * -> *).
(PersistStoreRead backend, MonadIO m,
PersistRecordBackend record backend) =>
Key record -> ReaderT backend m (Maybe record)
get Key e
key
Maybe (Entity e) -> ReaderT backend m (Maybe (Entity e))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Entity e) -> ReaderT backend m (Maybe (Entity e)))
-> Maybe (Entity e) -> ReaderT backend m (Maybe (Entity e))
forall a b. (a -> b) -> a -> b
$ (e -> Entity e) -> Maybe e -> Maybe (Entity e)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Key e
key Key e -> e -> Entity e
forall rec. Key rec -> rec -> Entity rec
`Entity`) Maybe e
maybeModel
insertRecord
:: forall record backend m.
( PersistEntityBackend record ~ BaseBackend backend
, PersistEntity record
, MonadIO m
, PersistStoreWrite backend
, SafeToInsert record
, HasCallStack
)
=> record -> ReaderT backend m record
insertRecord :: record -> ReaderT backend m record
insertRecord record
record = do
Key record
k <- record -> ReaderT backend m (Key record)
forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
PersistRecordBackend record backend, SafeToInsert record) =>
record -> ReaderT backend m (Key record)
insert record
record
let errorMessage :: String
errorMessage =
String
"persistent: failed to retrieve a record despite receiving a key from the database"
Maybe record
mentity <- Key record -> ReaderT backend m (Maybe record)
forall backend record (m :: * -> *).
(PersistStoreRead backend, MonadIO m,
PersistRecordBackend record backend) =>
Key record -> ReaderT backend m (Maybe record)
get Key record
k
record -> ReaderT backend m record
forall (m :: * -> *) a. Monad m => a -> m a
return (record -> ReaderT backend m record)
-> record -> ReaderT backend m record
forall a b. (a -> b) -> a -> b
$ record -> Maybe record -> record
forall a. a -> Maybe a -> a
Maybe.fromMaybe (String -> record
forall a. HasCallStack => String -> a
error String
errorMessage) Maybe record
mentity