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 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
unSqlPersistT :: a -> a
unSqlPersistT = id
type YesodDB site = ReaderT (YesodPersistBackend site) (HandlerT site IO)
class Monad (YesodDB site) => YesodPersist site where
type YesodPersistBackend site
runDB :: YesodDB site a -> HandlerT site IO a
defaultRunDB :: PersistConfig c
=> (site -> c)
-> (site -> PersistConfigPool c)
-> PersistConfigBackend c (HandlerT site IO) a
-> HandlerT site IO a
defaultRunDB getConfig getPool f = do
master <- getYesod
Database.Persist.runPool
(getConfig master)
f
(getPool master)
class YesodPersist site => YesodPersistRunner site where
getDBRunner :: HandlerT site IO (DBRunner site, HandlerT site IO ())
newtype DBRunner site = DBRunner
{ runDBRunner :: forall a. YesodDB site a -> HandlerT site IO a
}
#if MIN_VERSION_persistent(2,5,0)
defaultGetDBRunner :: (SQL.IsSqlBackend backend, YesodPersistBackend site ~ backend)
=> (site -> Pool backend)
-> HandlerT site IO (DBRunner site, HandlerT site IO ())
#else
defaultGetDBRunner :: YesodPersistBackend site ~ SQL.SqlBackend
=> (site -> Pool SQL.SqlBackend)
-> HandlerT site IO (DBRunner site, HandlerT site IO ())
#endif
defaultGetDBRunner getPool = do
pool <- fmap getPool getYesod
let withPrep conn f = f (persistBackend conn) (SQL.connPrepare $ persistBackend conn)
(relKey, (conn, local)) <- allocate
(do
(conn, local) <- takeResource pool
withPrep conn SQL.connBegin
return (conn, local)
)
(\(conn, local) -> do
withPrep conn SQL.connRollback
destroyResource pool local conn)
let cleanup = liftIO $ do
withPrep conn SQL.connCommit
putResource local conn
_ <- unprotect relKey
return ()
return (DBRunner $ \x -> runReaderT (unSqlPersistT x) conn, cleanup)
runDBSource :: YesodPersistRunner site
=> Source (YesodDB site) a
-> Source (HandlerT site IO) a
runDBSource src = do
(dbrunner, cleanup) <- lift getDBRunner
transPipe (runDBRunner dbrunner) src
lift cleanup
respondSourceDB :: YesodPersistRunner site
=> ContentType
-> Source (YesodDB site) (Flush Builder)
-> HandlerT site IO TypedContent
respondSourceDB ctype = respondSource ctype . runDBSource
#if MIN_VERSION_persistent(2,5,0)
get404 :: (MonadIO m, PersistStore 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 key = do
mres <- get key
case mres of
Nothing -> notFound'
Just res -> return res
#if MIN_VERSION_persistent(2,5,0)
getBy404 :: (PersistUnique 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 key = do
mres <- getBy key
case mres of
Nothing -> notFound'
Just res -> return res
#if 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 datum = do
conflict <- checkUnique datum
case conflict of
Just unique ->
badRequest' $ map (unHaskellName . fst) $ persistUniqueToFieldNames unique
Nothing -> insert datum
#if 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_ datum = insert400 datum >> return ()
notFound' :: MonadIO m => m a
notFound' = liftIO $ throwIO $ HCError NotFound
badRequest' :: MonadIO m => Texts -> m a
badRequest' = liftIO . throwIO . HCError . InvalidArgs