Yesod.Persist.Core
This commit is contained in:
Michael Snoyman
parent
8e5c419dd5
commit
c8146210c6
@ -1,158 +1,7 @@
|
|||||||
{-# LANGUAGE TypeFamilies #-}
|
|
||||||
{-# LANGUAGE FlexibleContexts #-}
|
|
||||||
{-# LANGUAGE RankNTypes #-}
|
|
||||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
||||||
module Yesod.Persist
|
module Yesod.Persist
|
||||||
( YesodPersist (..)
|
( module X
|
||||||
, defaultRunDB
|
|
||||||
, YesodPersistRunner (..)
|
|
||||||
, defaultGetDBRunner
|
|
||||||
, DBRunner (..)
|
|
||||||
, runDBSource
|
|
||||||
, respondSourceDB
|
|
||||||
, YesodDB
|
|
||||||
, get404
|
|
||||||
, getBy404
|
|
||||||
, module Database.Persist
|
|
||||||
, module Database.Persist.TH
|
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Database.Persist
|
import Database.Persist as X
|
||||||
import Database.Persist.TH
|
import Database.Persist.TH as X
|
||||||
import Database.Persist.Sql (SqlPersistT, unSqlPersistT)
|
import Yesod.Persist.Core as X
|
||||||
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
|
|
||||||
|
|
||||||
-- | Helper for creating 'runDB'.
|
|
||||||
--
|
|
||||||
-- Since 1.2.0
|
|
||||||
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)
|
|
||||||
|
|
||||||
-- |
|
|
||||||
--
|
|
||||||
-- Since 1.2.0
|
|
||||||
class YesodPersist site => YesodPersistRunner site where
|
|
||||||
-- | This function differs from 'runDB' in that it returns a database
|
|
||||||
-- runner function, as opposed to simply running a single action. This will
|
|
||||||
-- usually mean that a connection is taken from a pool and then reused for
|
|
||||||
-- each invocation. This can be useful for creating streaming responses;
|
|
||||||
-- see 'runDBSource'.
|
|
||||||
--
|
|
||||||
-- It additionally returns a cleanup function to free the connection. If
|
|
||||||
-- your code finishes successfully, you /must/ call this cleanup to
|
|
||||||
-- indicate changes should be committed. Otherwise, for SQL backends at
|
|
||||||
-- least, a rollback will be used instead.
|
|
||||||
--
|
|
||||||
-- Since 1.2.0
|
|
||||||
getDBRunner :: HandlerT site IO (DBRunner site, HandlerT site IO ())
|
|
||||||
|
|
||||||
newtype DBRunner site = DBRunner
|
|
||||||
{ runDBRunner :: forall a. YesodDB site a -> HandlerT site IO a
|
|
||||||
}
|
|
||||||
|
|
||||||
-- | Helper for implementing 'getDBRunner'.
|
|
||||||
--
|
|
||||||
-- Since 1.2.0
|
|
||||||
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)
|
|
||||||
|
|
||||||
-- | Like 'runDB', but transforms a @Source@. See 'respondSourceDB' for an
|
|
||||||
-- example, practical use case.
|
|
||||||
--
|
|
||||||
-- Since 1.2.0
|
|
||||||
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
|
|
||||||
|
|
||||||
-- | Extends 'respondSource' to create a streaming database response body.
|
|
||||||
respondSourceDB :: YesodPersistRunner site
|
|
||||||
=> ContentType
|
|
||||||
-> Source (YesodDB site) (Flush Builder)
|
|
||||||
-> HandlerT site IO TypedContent
|
|
||||||
respondSourceDB ctype = respondSource ctype . runDBSource
|
|
||||||
|
|
||||||
-- | Get the given entity by ID, or return a 404 not found if it doesn't exist.
|
|
||||||
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
|
|
||||||
|
|
||||||
-- | Get the given entity by unique key, or return a 404 not found if it doesn't
|
|
||||||
-- exist.
|
|
||||||
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
|
|
||||||
|
|||||||
158
yesod-persistent/Yesod/Persist/Core.hs
Normal file
158
yesod-persistent/Yesod/Persist/Core.hs
Normal file
@ -0,0 +1,158 @@
|
|||||||
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
|
{-# LANGUAGE RankNTypes #-}
|
||||||
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||||
|
-- | Defines the core functionality of this package. This package is
|
||||||
|
-- distinguished from Yesod.Persist in that the latter additionally exports the
|
||||||
|
-- persistent modules themselves.
|
||||||
|
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.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
|
||||||
|
|
||||||
|
-- | Helper for creating 'runDB'.
|
||||||
|
--
|
||||||
|
-- Since 1.2.0
|
||||||
|
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)
|
||||||
|
|
||||||
|
-- |
|
||||||
|
--
|
||||||
|
-- Since 1.2.0
|
||||||
|
class YesodPersist site => YesodPersistRunner site where
|
||||||
|
-- | This function differs from 'runDB' in that it returns a database
|
||||||
|
-- runner function, as opposed to simply running a single action. This will
|
||||||
|
-- usually mean that a connection is taken from a pool and then reused for
|
||||||
|
-- each invocation. This can be useful for creating streaming responses;
|
||||||
|
-- see 'runDBSource'.
|
||||||
|
--
|
||||||
|
-- It additionally returns a cleanup function to free the connection. If
|
||||||
|
-- your code finishes successfully, you /must/ call this cleanup to
|
||||||
|
-- indicate changes should be committed. Otherwise, for SQL backends at
|
||||||
|
-- least, a rollback will be used instead.
|
||||||
|
--
|
||||||
|
-- Since 1.2.0
|
||||||
|
getDBRunner :: HandlerT site IO (DBRunner site, HandlerT site IO ())
|
||||||
|
|
||||||
|
newtype DBRunner site = DBRunner
|
||||||
|
{ runDBRunner :: forall a. YesodDB site a -> HandlerT site IO a
|
||||||
|
}
|
||||||
|
|
||||||
|
-- | Helper for implementing 'getDBRunner'.
|
||||||
|
--
|
||||||
|
-- Since 1.2.0
|
||||||
|
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)
|
||||||
|
|
||||||
|
-- | Like 'runDB', but transforms a @Source@. See 'respondSourceDB' for an
|
||||||
|
-- example, practical use case.
|
||||||
|
--
|
||||||
|
-- Since 1.2.0
|
||||||
|
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
|
||||||
|
|
||||||
|
-- | Extends 'respondSource' to create a streaming database response body.
|
||||||
|
respondSourceDB :: YesodPersistRunner site
|
||||||
|
=> ContentType
|
||||||
|
-> Source (YesodDB site) (Flush Builder)
|
||||||
|
-> HandlerT site IO TypedContent
|
||||||
|
respondSourceDB ctype = respondSource ctype . runDBSource
|
||||||
|
|
||||||
|
-- | Get the given entity by ID, or return a 404 not found if it doesn't exist.
|
||||||
|
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
|
||||||
|
|
||||||
|
-- | Get the given entity by unique key, or return a 404 not found if it doesn't
|
||||||
|
-- exist.
|
||||||
|
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
|
||||||
@ -1,5 +1,5 @@
|
|||||||
name: yesod-persistent
|
name: yesod-persistent
|
||||||
version: 1.2.0
|
version: 1.2.1
|
||||||
license: MIT
|
license: MIT
|
||||||
license-file: LICENSE
|
license-file: LICENSE
|
||||||
author: Michael Snoyman <michael@snoyman.com>
|
author: Michael Snoyman <michael@snoyman.com>
|
||||||
@ -14,7 +14,7 @@ description: Some helpers for using Persistent from Yesod.
|
|||||||
|
|
||||||
library
|
library
|
||||||
build-depends: base >= 4 && < 5
|
build-depends: base >= 4 && < 5
|
||||||
, yesod-core >= 1.2 && < 1.3
|
, yesod-core >= 1.2.2 && < 1.3
|
||||||
, persistent >= 1.2 && < 1.3
|
, persistent >= 1.2 && < 1.3
|
||||||
, persistent-template >= 1.2 && < 1.3
|
, persistent-template >= 1.2 && < 1.3
|
||||||
, transformers >= 0.2.2 && < 0.4
|
, transformers >= 0.2.2 && < 0.4
|
||||||
@ -24,6 +24,7 @@ library
|
|||||||
, pool-conduit
|
, pool-conduit
|
||||||
, resourcet
|
, resourcet
|
||||||
exposed-modules: Yesod.Persist
|
exposed-modules: Yesod.Persist
|
||||||
|
Yesod.Persist.Core
|
||||||
ghc-options: -Wall
|
ghc-options: -Wall
|
||||||
|
|
||||||
test-suite test
|
test-suite test
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user