module Yesod.Persist
( YesodPersist (..)
, defaultRunDB
, YesodPersistRunner (..)
, defaultGetDBRunner
, DBRunner (..)
, runDBSource
, respondSourceDB
, YesodDB
, get404
, getBy404
, module Database.Persist
, module Database.Persist.TH
) where
import Database.Persist
import Database.Persist.TH
import Database.Persist.Sql (SqlPersistT, unSqlPersistT)
import Control.Monad.Trans.Reader (runReaderT)
import Yesod.Core
import Data.Conduit
import Blaze.ByteString.Builder (Builder)
import Data.IORef.Lifted
import Data.Conduit.Pool
import Control.Monad.Trans.Resource
import qualified Database.Persist.Sql as SQL
type YesodDB site = YesodPersistBackend site (HandlerT site IO)
class Monad (YesodPersistBackend site (HandlerT site IO)) => 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
}
defaultGetDBRunner :: YesodPersistBackend site ~ SqlPersistT
=> (site -> Pool SQL.Connection)
-> HandlerT site IO (DBRunner site, HandlerT site IO ())
defaultGetDBRunner getPool = do
ididSucceed <- newIORef False
pool <- fmap getPool getYesod
managedConn <- takeResource pool
let conn = mrValue managedConn
let withPrep f = f conn (SQL.connPrepare conn)
(finishTransaction, ()) <- allocate (withPrep SQL.connBegin) $ \() -> do
didSucceed <- readIORef ididSucceed
withPrep $ if didSucceed
then SQL.connCommit
else SQL.connRollback
let cleanup = do
writeIORef ididSucceed True
release finishTransaction
mrReuse managedConn True
mrRelease managedConn
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
get404 :: ( PersistStore (t m)
, PersistEntity val
, Monad (t m)
, m ~ HandlerT site IO
, MonadTrans t
, PersistMonadBackend (t m) ~ PersistEntityBackend val
)
=> Key val -> t m val
get404 key = do
mres <- get key
case mres of
Nothing -> lift notFound
Just res -> return res
getBy404 :: ( PersistUnique (t m)
, PersistEntity val
, m ~ HandlerT site IO
, Monad (t m)
, MonadTrans t
, PersistEntityBackend val ~ PersistMonadBackend (t m)
)
=> Unique val -> t m (Entity val)
getBy404 key = do
mres <- getBy key
case mres of
Nothing -> lift notFound
Just res -> return res
instance MonadHandler m => MonadHandler (SqlPersistT m) where
type HandlerSite (SqlPersistT m) = HandlerSite m
liftHandlerT = lift . liftHandlerT
instance MonadWidget m => MonadWidget (SqlPersistT m) where
liftWidgetT = lift . liftWidgetT