{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Yesod.Persist.Core
( YesodPersist (..)
, defaultRunDB
, YesodPersistRunner (..)
, defaultGetDBRunner
, DBRunner (..)
, runDBSource
, respondSourceDB
, YesodDB
, get404
, getBy404
, insert400
, insert400_
) where
import Database.Persist
import Control.Monad.Trans.Reader (ReaderT, runReaderT)
import Data.Foldable (toList)
import Yesod.Core
import Data.Conduit
import Blaze.ByteString.Builder (Builder)
import Data.Pool
import Control.Monad.Trans.Resource
import Control.Exception (throwIO)
import Yesod.Core.Types (HandlerContents (HCError))
import qualified Database.Persist.Sql as SQL
#if MIN_VERSION_persistent(2,13,0)
import qualified Database.Persist.SqlBackend.Internal as SQL
#endif
#if MIN_VERSION_persistent(2,14,0)
import Database.Persist.Class.PersistEntity
#endif
unSqlPersistT :: a -> a
unSqlPersistT :: forall a. a -> a
unSqlPersistT = a -> a
forall a. a -> a
id
type YesodDB site = ReaderT (YesodPersistBackend site) (HandlerFor site)
class Monad (YesodDB site) => YesodPersist site where
type YesodPersistBackend site
runDB :: YesodDB site a -> HandlerFor site a
defaultRunDB :: PersistConfig c
=> (site -> c)
-> (site -> PersistConfigPool c)
-> PersistConfigBackend c (HandlerFor site) a
-> HandlerFor site a
defaultRunDB :: forall c site a.
PersistConfig c =>
(site -> c)
-> (site -> PersistConfigPool c)
-> PersistConfigBackend c (HandlerFor site) a
-> HandlerFor site a
defaultRunDB site -> c
getConfig site -> PersistConfigPool c
getPool PersistConfigBackend c (HandlerFor site) a
f = do
master <- HandlerFor site site
HandlerFor site (HandlerSite (HandlerFor site))
forall (m :: * -> *). MonadHandler m => m (HandlerSite m)
getYesod
Database.Persist.runPool
(getConfig master)
f
(getPool master)
class YesodPersist site => YesodPersistRunner site where
getDBRunner :: HandlerFor site (DBRunner site, HandlerFor site ())
newtype DBRunner site = DBRunner
{ forall site.
DBRunner site -> forall a. YesodDB site a -> HandlerFor site a
runDBRunner :: forall a. YesodDB site a -> HandlerFor site a
}
#if MIN_VERSION_persistent(2,5,0)
defaultGetDBRunner :: (SQL.IsSqlBackend backend, YesodPersistBackend site ~ backend)
=> (site -> Pool backend)
-> HandlerFor site (DBRunner site, HandlerFor site ())
#else
defaultGetDBRunner :: YesodPersistBackend site ~ SQL.SqlBackend
=> (site -> Pool SQL.SqlBackend)
-> HandlerFor site (DBRunner site, HandlerFor site ())
#endif
defaultGetDBRunner :: forall backend site.
(IsSqlBackend backend, YesodPersistBackend site ~ backend) =>
(site -> Pool backend)
-> HandlerFor site (DBRunner site, HandlerFor site ())
defaultGetDBRunner site -> Pool backend
getPool = do
pool <- (site -> Pool backend)
-> HandlerFor site site -> HandlerFor site (Pool backend)
forall a b. (a -> b) -> HandlerFor site a -> HandlerFor site b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap site -> Pool backend
getPool HandlerFor site site
HandlerFor site (HandlerSite (HandlerFor site))
forall (m :: * -> *). MonadHandler m => m (HandlerSite m)
getYesod
let withPrep backend
conn BaseBackend backend -> (Text -> IO Statement) -> t
f = BaseBackend backend -> (Text -> IO Statement) -> t
f (backend -> BaseBackend backend
forall backend.
HasPersistBackend backend =>
backend -> BaseBackend backend
persistBackend backend
conn) (SqlBackend -> Text -> IO Statement
SQL.getStmtConn (SqlBackend -> Text -> IO Statement)
-> SqlBackend -> Text -> IO Statement
forall a b. (a -> b) -> a -> b
$ backend -> BaseBackend backend
forall backend.
HasPersistBackend backend =>
backend -> BaseBackend backend
persistBackend backend
conn)
(relKey, (conn, local)) <- allocate
(do
(conn, local) <- takeResource pool
#if MIN_VERSION_persistent(2,9,0)
withPrep conn (\BaseBackend backend
c Text -> IO Statement
f -> SqlBackend
-> (Text -> IO Statement) -> Maybe IsolationLevel -> IO ()
SQL.connBegin BaseBackend backend
SqlBackend
c Text -> IO Statement
f Maybe IsolationLevel
forall a. Maybe a
Nothing)
#else
withPrep conn SQL.connBegin
#endif
return (conn, local)
)
(\(backend
conn, LocalPool backend
local) -> do
backend
-> (BaseBackend backend -> (Text -> IO Statement) -> IO ())
-> IO ()
forall {backend} {t}.
(BaseBackend backend ~ SqlBackend, HasPersistBackend backend) =>
backend
-> (BaseBackend backend -> (Text -> IO Statement) -> t) -> t
withPrep backend
conn BaseBackend backend -> (Text -> IO Statement) -> IO ()
SqlBackend -> (Text -> IO Statement) -> IO ()
SQL.connRollback
Pool backend -> LocalPool backend -> backend -> IO ()
forall a. Pool a -> LocalPool a -> a -> IO ()
destroyResource Pool backend
pool LocalPool backend
local backend
conn)
let cleanup = IO () -> HandlerFor site ()
forall a. IO a -> HandlerFor site a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> HandlerFor site ()) -> IO () -> HandlerFor site ()
forall a b. (a -> b) -> a -> b
$ do
backend
-> (BaseBackend backend -> (Text -> IO Statement) -> IO ())
-> IO ()
forall {backend} {t}.
(BaseBackend backend ~ SqlBackend, HasPersistBackend backend) =>
backend
-> (BaseBackend backend -> (Text -> IO Statement) -> t) -> t
withPrep backend
conn BaseBackend backend -> (Text -> IO Statement) -> IO ()
SqlBackend -> (Text -> IO Statement) -> IO ()
SQL.connCommit
LocalPool backend -> backend -> IO ()
forall a. LocalPool a -> a -> IO ()
putResource LocalPool backend
local backend
conn
_ <- ReleaseKey -> IO (Maybe (IO ()))
forall (m :: * -> *). MonadIO m => ReleaseKey -> m (Maybe (IO ()))
unprotect ReleaseKey
relKey
return ()
return (DBRunner $ \YesodDB site a
x -> ReaderT backend (HandlerFor site) a -> backend -> HandlerFor site a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (ReaderT backend (HandlerFor site) a
-> ReaderT backend (HandlerFor site) a
forall a. a -> a
unSqlPersistT ReaderT backend (HandlerFor site) a
YesodDB site a
x) backend
conn, cleanup)
runDBSource :: YesodPersistRunner site
=> ConduitT () a (YesodDB site) ()
-> ConduitT () a (HandlerFor site) ()
runDBSource :: forall site a.
YesodPersistRunner site =>
ConduitT () a (YesodDB site) ()
-> ConduitT () a (HandlerFor site) ()
runDBSource ConduitT
() a (ReaderT (YesodPersistBackend site) (HandlerFor site)) ()
src = do
(dbrunner, cleanup) <- HandlerFor site (DBRunner site, HandlerFor site ())
-> ConduitT
() a (HandlerFor site) (DBRunner site, HandlerFor site ())
forall (m :: * -> *) a. Monad m => m a -> ConduitT () a m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift HandlerFor site (DBRunner site, HandlerFor site ())
forall site.
YesodPersistRunner site =>
HandlerFor site (DBRunner site, HandlerFor site ())
getDBRunner
transPipe (runDBRunner dbrunner) src
lift cleanup
respondSourceDB :: YesodPersistRunner site
=> ContentType
-> ConduitT () (Flush Builder) (YesodDB site) ()
-> HandlerFor site TypedContent
respondSourceDB :: forall site.
YesodPersistRunner site =>
ContentType
-> ConduitT () (Flush Builder) (YesodDB site) ()
-> HandlerFor site TypedContent
respondSourceDB ContentType
ctype = ContentType
-> ConduitT () (Flush Builder) (HandlerFor site) ()
-> HandlerFor site TypedContent
forall site.
ContentType
-> ConduitT () (Flush Builder) (HandlerFor site) ()
-> HandlerFor site TypedContent
respondSource ContentType
ctype (ConduitT () (Flush Builder) (HandlerFor site) ()
-> HandlerFor site TypedContent)
-> (ConduitT
()
(Flush Builder)
(ReaderT (YesodPersistBackend site) (HandlerFor site))
()
-> ConduitT () (Flush Builder) (HandlerFor site) ())
-> ConduitT
()
(Flush Builder)
(ReaderT (YesodPersistBackend site) (HandlerFor site))
()
-> HandlerFor site TypedContent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConduitT
()
(Flush Builder)
(ReaderT (YesodPersistBackend site) (HandlerFor site))
()
-> ConduitT () (Flush Builder) (HandlerFor site) ()
forall site a.
YesodPersistRunner site =>
ConduitT () a (YesodDB site) ()
-> ConduitT () a (HandlerFor site) ()
runDBSource
#if MIN_VERSION_persistent(2,5,0)
get404 :: (MonadIO m, PersistStoreRead backend, PersistRecordBackend val backend)
=> Key val
-> ReaderT backend m val
#else
get404 :: (MonadIO m, PersistStore (PersistEntityBackend val), PersistEntity val)
=> Key val
-> ReaderT (PersistEntityBackend val) m val
#endif
get404 :: forall (m :: * -> *) backend val.
(MonadIO m, PersistStoreRead backend,
PersistRecordBackend val backend) =>
Key val -> ReaderT backend m val
get404 Key val
key = do
mres <- Key val -> ReaderT backend m (Maybe val)
forall backend record (m :: * -> *).
(PersistStoreRead backend, MonadIO m,
PersistRecordBackend record backend) =>
Key record -> ReaderT backend m (Maybe record)
forall record (m :: * -> *).
(MonadIO m, PersistRecordBackend record backend) =>
Key record -> ReaderT backend m (Maybe record)
get Key val
key
case mres of
Maybe val
Nothing -> ReaderT backend m val
forall (m :: * -> *) a. MonadIO m => m a
notFound'
Just val
res -> val -> ReaderT backend m val
forall a. a -> ReaderT backend m a
forall (m :: * -> *) a. Monad m => a -> m a
return val
res
#if MIN_VERSION_persistent(2,5,0)
getBy404 :: (PersistUniqueRead backend, PersistRecordBackend val backend, MonadIO m)
=> Unique val
-> ReaderT backend m (Entity val)
#else
getBy404 :: (PersistUnique (PersistEntityBackend val), PersistEntity val, MonadIO m)
=> Unique val
-> ReaderT (PersistEntityBackend val) m (Entity val)
#endif
getBy404 :: forall backend val (m :: * -> *).
(PersistUniqueRead backend, PersistRecordBackend val backend,
MonadIO m) =>
Unique val -> ReaderT backend m (Entity val)
getBy404 Unique val
key = do
mres <- Unique val -> ReaderT backend m (Maybe (Entity val))
forall backend record (m :: * -> *).
(PersistUniqueRead backend, MonadIO m,
PersistRecordBackend record backend) =>
Unique record -> ReaderT backend m (Maybe (Entity record))
forall record (m :: * -> *).
(MonadIO m, PersistRecordBackend record backend) =>
Unique record -> ReaderT backend m (Maybe (Entity record))
getBy Unique val
key
case mres of
Maybe (Entity val)
Nothing -> ReaderT backend m (Entity val)
forall (m :: * -> *) a. MonadIO m => m a
notFound'
Just Entity val
res -> Entity val -> ReaderT backend m (Entity val)
forall a. a -> ReaderT backend m a
forall (m :: * -> *) a. Monad m => a -> m a
return Entity val
res
#if MIN_VERSION_persistent(2,14,0)
insert400
:: (MonadIO m, PersistUniqueWrite backend, PersistRecordBackend val backend, SafeToInsert val)
=> val
-> ReaderT backend m (Key val)
#elif MIN_VERSION_persistent(2,5,0)
insert400
:: (MonadIO m, PersistUniqueWrite backend, PersistRecordBackend val backend)
=> val
-> ReaderT backend m (Key val)
#else
insert400
:: (MonadIO m, PersistUnique (PersistEntityBackend val), PersistEntity val)
=> val
-> ReaderT (PersistEntityBackend val) m (Key val)
#endif
insert400 :: forall (m :: * -> *) backend val.
(MonadIO m, PersistUniqueWrite backend,
PersistRecordBackend val backend, SafeToInsert val) =>
val -> ReaderT backend m (Key val)
insert400 val
datum = do
conflict <- val -> ReaderT backend m (Maybe (Unique val))
forall record backend (m :: * -> *).
(MonadIO m, PersistRecordBackend record backend,
PersistUniqueRead backend) =>
record -> ReaderT backend m (Maybe (Unique record))
checkUnique val
datum
case conflict of
Just Unique val
unique ->
#if MIN_VERSION_persistent(2, 12, 0)
Texts -> ReaderT backend m (Key val)
forall (m :: * -> *) a. MonadIO m => Texts -> m a
badRequest' (Texts -> ReaderT backend m (Key val))
-> Texts -> ReaderT backend m (Key val)
forall a b. (a -> b) -> a -> b
$ ((FieldNameHS, FieldNameDB) -> Text)
-> [(FieldNameHS, FieldNameDB)] -> Texts
forall a b. (a -> b) -> [a] -> [b]
map (FieldNameHS -> Text
unFieldNameHS (FieldNameHS -> Text)
-> ((FieldNameHS, FieldNameDB) -> FieldNameHS)
-> (FieldNameHS, FieldNameDB)
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FieldNameHS, FieldNameDB) -> FieldNameHS
forall a b. (a, b) -> a
fst) ([(FieldNameHS, FieldNameDB)] -> Texts)
-> [(FieldNameHS, FieldNameDB)] -> Texts
forall a b. (a -> b) -> a -> b
$ NonEmpty (FieldNameHS, FieldNameDB) -> [(FieldNameHS, FieldNameDB)]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (NonEmpty (FieldNameHS, FieldNameDB)
-> [(FieldNameHS, FieldNameDB)])
-> NonEmpty (FieldNameHS, FieldNameDB)
-> [(FieldNameHS, FieldNameDB)]
forall a b. (a -> b) -> a -> b
$ Unique val -> NonEmpty (FieldNameHS, FieldNameDB)
forall record.
PersistEntity record =>
Unique record -> NonEmpty (FieldNameHS, FieldNameDB)
persistUniqueToFieldNames Unique val
unique
#else
badRequest' $ map (unHaskellName . fst) $ persistUniqueToFieldNames unique
#endif
Maybe (Unique val)
Nothing -> val -> ReaderT backend m (Key val)
forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
PersistRecordBackend record backend, SafeToInsert record) =>
record -> ReaderT backend m (Key record)
forall record (m :: * -> *).
(MonadIO m, PersistRecordBackend record backend,
SafeToInsert record) =>
record -> ReaderT backend m (Key record)
insert val
datum
#if MIN_VERSION_persistent(2,14,0)
insert400_ :: (MonadIO m, PersistUniqueWrite backend, PersistRecordBackend val backend, SafeToInsert val)
=> val
-> ReaderT backend m ()
#elif MIN_VERSION_persistent(2,5,0)
insert400_ :: (MonadIO m, PersistUniqueWrite backend, PersistRecordBackend val backend)
=> val
-> ReaderT backend m ()
#else
insert400_ :: (MonadIO m, PersistUnique (PersistEntityBackend val), PersistEntity val)
=> val
-> ReaderT (PersistEntityBackend val) m ()
#endif
insert400_ :: forall (m :: * -> *) backend val.
(MonadIO m, PersistUniqueWrite backend,
PersistRecordBackend val backend, SafeToInsert val) =>
val -> ReaderT backend m ()
insert400_ val
datum = val -> ReaderT backend m (Key val)
forall (m :: * -> *) backend val.
(MonadIO m, PersistUniqueWrite backend,
PersistRecordBackend val backend, SafeToInsert val) =>
val -> ReaderT backend m (Key val)
insert400 val
datum ReaderT backend m (Key val)
-> ReaderT backend m () -> ReaderT backend m ()
forall a b.
ReaderT backend m a -> ReaderT backend m b -> ReaderT backend m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> ReaderT backend m ()
forall a. a -> ReaderT backend m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
notFound' :: MonadIO m => m a
notFound' :: forall (m :: * -> *) a. MonadIO m => m a
notFound' = IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$ HandlerContents -> IO a
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (HandlerContents -> IO a) -> HandlerContents -> IO a
forall a b. (a -> b) -> a -> b
$ ErrorResponse -> HandlerContents
HCError ErrorResponse
NotFound
badRequest' :: MonadIO m => Texts -> m a
badRequest' :: forall (m :: * -> *) a. MonadIO m => Texts -> m a
badRequest' = IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> (Texts -> IO a) -> Texts -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HandlerContents -> IO a
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (HandlerContents -> IO a)
-> (Texts -> HandlerContents) -> Texts -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorResponse -> HandlerContents
HCError (ErrorResponse -> HandlerContents)
-> (Texts -> ErrorResponse) -> Texts -> HandlerContents
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Texts -> ErrorResponse
InvalidArgs