module Yesod.Persist.Core
( YesodPersist (..)
, defaultRunDB
, YesodPersistRunner (..)
, defaultGetDBRunner
, DBRunner (..)
, runDBSource
, respondSourceDB
, YesodDB
, get404
, getBy404
) where
import Database.Persist
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.Pool
import Control.Monad.Trans.Resource
import Control.Exception (throwIO)
import Yesod.Core.Types (HandlerContents (HCError))
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 :: YesodPersistBackend site (HandlerT site IO) 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. YesodPersistBackend site (HandlerT site IO) a -> HandlerT site IO a
}
defaultGetDBRunner :: YesodPersistBackend site ~ SqlPersistT
=> (site -> Pool SQL.Connection)
-> HandlerT site IO (DBRunner site, HandlerT site IO ())
defaultGetDBRunner getPool = do
pool <- fmap getPool getYesod
let withPrep conn f = f conn (SQL.connPrepare 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 (YesodPersistBackend site (HandlerT site IO)) a
-> Source (HandlerT site IO) a
runDBSource src = do
(dbrunner, cleanup) <- lift getDBRunner
transPipe (runDBRunner dbrunner) src
lift cleanup
respondSourceDB :: YesodPersistRunner site
=> ContentType
-> Source (YesodPersistBackend site (HandlerT site IO)) (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 -> 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 -> notFound'
Just res -> return res
notFound' :: MonadIO m => m a
notFound' = liftIO $ throwIO $ HCError NotFound
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