{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Database.Persist.Monad
(
MonadSqlQuery
, withTransaction
, SqlQueryRep(..)
, SqlQueryT
, runSqlQueryT
, module Database.Persist.Monad.Shim
) where
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.IO.Unlift (MonadUnliftIO(..), wrappedWithRunInIO)
import Control.Monad.Reader (ReaderT, ask, local, runReaderT)
import Control.Monad.Trans.Class (MonadTrans(..))
import Control.Monad.Trans.Resource (MonadResource)
import Data.Acquire (withAcquire)
import Data.Pool (Pool)
import Data.Pool.Acquire (poolToAcquire)
import Database.Persist.Sql (SqlBackend, runSqlConn)
import Database.Persist.Monad.Class
import Database.Persist.Monad.Shim
import Database.Persist.Monad.SqlQueryRep
data SqlQueryEnv = SqlQueryEnv
{ SqlQueryEnv -> Pool SqlBackend
backendPool :: Pool SqlBackend
, SqlQueryEnv -> Maybe SqlBackend
currentConn :: Maybe SqlBackend
}
newtype SqlQueryT m a = SqlQueryT
{ SqlQueryT m a -> ReaderT SqlQueryEnv m a
unSqlQueryT :: ReaderT SqlQueryEnv m a
} deriving
( a -> SqlQueryT m b -> SqlQueryT m a
(a -> b) -> SqlQueryT m a -> SqlQueryT m b
(forall a b. (a -> b) -> SqlQueryT m a -> SqlQueryT m b)
-> (forall a b. a -> SqlQueryT m b -> SqlQueryT m a)
-> Functor (SqlQueryT m)
forall a b. a -> SqlQueryT m b -> SqlQueryT m a
forall a b. (a -> b) -> SqlQueryT m a -> SqlQueryT m b
forall (m :: * -> *) a b.
Functor m =>
a -> SqlQueryT m b -> SqlQueryT m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> SqlQueryT m a -> SqlQueryT m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> SqlQueryT m b -> SqlQueryT m a
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> SqlQueryT m b -> SqlQueryT m a
fmap :: (a -> b) -> SqlQueryT m a -> SqlQueryT m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> SqlQueryT m a -> SqlQueryT m b
Functor
, Functor (SqlQueryT m)
a -> SqlQueryT m a
Functor (SqlQueryT m)
-> (forall a. a -> SqlQueryT m a)
-> (forall a b.
SqlQueryT m (a -> b) -> SqlQueryT m a -> SqlQueryT m b)
-> (forall a b c.
(a -> b -> c) -> SqlQueryT m a -> SqlQueryT m b -> SqlQueryT m c)
-> (forall a b. SqlQueryT m a -> SqlQueryT m b -> SqlQueryT m b)
-> (forall a b. SqlQueryT m a -> SqlQueryT m b -> SqlQueryT m a)
-> Applicative (SqlQueryT m)
SqlQueryT m a -> SqlQueryT m b -> SqlQueryT m b
SqlQueryT m a -> SqlQueryT m b -> SqlQueryT m a
SqlQueryT m (a -> b) -> SqlQueryT m a -> SqlQueryT m b
(a -> b -> c) -> SqlQueryT m a -> SqlQueryT m b -> SqlQueryT m c
forall a. a -> SqlQueryT m a
forall a b. SqlQueryT m a -> SqlQueryT m b -> SqlQueryT m a
forall a b. SqlQueryT m a -> SqlQueryT m b -> SqlQueryT m b
forall a b. SqlQueryT m (a -> b) -> SqlQueryT m a -> SqlQueryT m b
forall a b c.
(a -> b -> c) -> SqlQueryT m a -> SqlQueryT m b -> SqlQueryT m c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
forall (m :: * -> *). Applicative m => Functor (SqlQueryT m)
forall (m :: * -> *) a. Applicative m => a -> SqlQueryT m a
forall (m :: * -> *) a b.
Applicative m =>
SqlQueryT m a -> SqlQueryT m b -> SqlQueryT m a
forall (m :: * -> *) a b.
Applicative m =>
SqlQueryT m a -> SqlQueryT m b -> SqlQueryT m b
forall (m :: * -> *) a b.
Applicative m =>
SqlQueryT m (a -> b) -> SqlQueryT m a -> SqlQueryT m b
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> SqlQueryT m a -> SqlQueryT m b -> SqlQueryT m c
<* :: SqlQueryT m a -> SqlQueryT m b -> SqlQueryT m a
$c<* :: forall (m :: * -> *) a b.
Applicative m =>
SqlQueryT m a -> SqlQueryT m b -> SqlQueryT m a
*> :: SqlQueryT m a -> SqlQueryT m b -> SqlQueryT m b
$c*> :: forall (m :: * -> *) a b.
Applicative m =>
SqlQueryT m a -> SqlQueryT m b -> SqlQueryT m b
liftA2 :: (a -> b -> c) -> SqlQueryT m a -> SqlQueryT m b -> SqlQueryT m c
$cliftA2 :: forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> SqlQueryT m a -> SqlQueryT m b -> SqlQueryT m c
<*> :: SqlQueryT m (a -> b) -> SqlQueryT m a -> SqlQueryT m b
$c<*> :: forall (m :: * -> *) a b.
Applicative m =>
SqlQueryT m (a -> b) -> SqlQueryT m a -> SqlQueryT m b
pure :: a -> SqlQueryT m a
$cpure :: forall (m :: * -> *) a. Applicative m => a -> SqlQueryT m a
$cp1Applicative :: forall (m :: * -> *). Applicative m => Functor (SqlQueryT m)
Applicative
, Applicative (SqlQueryT m)
a -> SqlQueryT m a
Applicative (SqlQueryT m)
-> (forall a b.
SqlQueryT m a -> (a -> SqlQueryT m b) -> SqlQueryT m b)
-> (forall a b. SqlQueryT m a -> SqlQueryT m b -> SqlQueryT m b)
-> (forall a. a -> SqlQueryT m a)
-> Monad (SqlQueryT m)
SqlQueryT m a -> (a -> SqlQueryT m b) -> SqlQueryT m b
SqlQueryT m a -> SqlQueryT m b -> SqlQueryT m b
forall a. a -> SqlQueryT m a
forall a b. SqlQueryT m a -> SqlQueryT m b -> SqlQueryT m b
forall a b. SqlQueryT m a -> (a -> SqlQueryT m b) -> SqlQueryT m b
forall (m :: * -> *). Monad m => Applicative (SqlQueryT m)
forall (m :: * -> *) a. Monad m => a -> SqlQueryT m a
forall (m :: * -> *) a b.
Monad m =>
SqlQueryT m a -> SqlQueryT m b -> SqlQueryT m b
forall (m :: * -> *) a b.
Monad m =>
SqlQueryT m a -> (a -> SqlQueryT m b) -> SqlQueryT m b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> SqlQueryT m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> SqlQueryT m a
>> :: SqlQueryT m a -> SqlQueryT m b -> SqlQueryT m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
SqlQueryT m a -> SqlQueryT m b -> SqlQueryT m b
>>= :: SqlQueryT m a -> (a -> SqlQueryT m b) -> SqlQueryT m b
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
SqlQueryT m a -> (a -> SqlQueryT m b) -> SqlQueryT m b
$cp1Monad :: forall (m :: * -> *). Monad m => Applicative (SqlQueryT m)
Monad
, Monad (SqlQueryT m)
Monad (SqlQueryT m)
-> (forall a. IO a -> SqlQueryT m a) -> MonadIO (SqlQueryT m)
IO a -> SqlQueryT m a
forall a. IO a -> SqlQueryT m a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
forall (m :: * -> *). MonadIO m => Monad (SqlQueryT m)
forall (m :: * -> *) a. MonadIO m => IO a -> SqlQueryT m a
liftIO :: IO a -> SqlQueryT m a
$cliftIO :: forall (m :: * -> *) a. MonadIO m => IO a -> SqlQueryT m a
$cp1MonadIO :: forall (m :: * -> *). MonadIO m => Monad (SqlQueryT m)
MonadIO
, m a -> SqlQueryT m a
(forall (m :: * -> *) a. Monad m => m a -> SqlQueryT m a)
-> MonadTrans SqlQueryT
forall (m :: * -> *) a. Monad m => m a -> SqlQueryT m a
forall (t :: (* -> *) -> * -> *).
(forall (m :: * -> *) a. Monad m => m a -> t m a) -> MonadTrans t
lift :: m a -> SqlQueryT m a
$clift :: forall (m :: * -> *) a. Monad m => m a -> SqlQueryT m a
MonadTrans
, MonadIO (SqlQueryT m)
MonadIO (SqlQueryT m)
-> (forall a. ResourceT IO a -> SqlQueryT m a)
-> MonadResource (SqlQueryT m)
ResourceT IO a -> SqlQueryT m a
forall a. ResourceT IO a -> SqlQueryT m a
forall (m :: * -> *).
MonadIO m -> (forall a. ResourceT IO a -> m a) -> MonadResource m
forall (m :: * -> *). MonadResource m => MonadIO (SqlQueryT m)
forall (m :: * -> *) a.
MonadResource m =>
ResourceT IO a -> SqlQueryT m a
liftResourceT :: ResourceT IO a -> SqlQueryT m a
$cliftResourceT :: forall (m :: * -> *) a.
MonadResource m =>
ResourceT IO a -> SqlQueryT m a
$cp1MonadResource :: forall (m :: * -> *). MonadResource m => MonadIO (SqlQueryT m)
MonadResource
)
instance MonadUnliftIO m => MonadSqlQuery (SqlQueryT m) where
runQueryRep :: SqlQueryRep record a -> SqlQueryT m a
runQueryRep SqlQueryRep record a
queryRep = do
SqlQueryEnv{Maybe SqlBackend
currentConn :: Maybe SqlBackend
currentConn :: SqlQueryEnv -> Maybe SqlBackend
currentConn} <- ReaderT SqlQueryEnv m SqlQueryEnv -> SqlQueryT m SqlQueryEnv
forall (m :: * -> *) a. ReaderT SqlQueryEnv m a -> SqlQueryT m a
SqlQueryT ReaderT SqlQueryEnv m SqlQueryEnv
forall r (m :: * -> *). MonadReader r m => m r
ask
case Maybe SqlBackend
currentConn of
Just SqlBackend
conn -> SqlBackend -> SqlQueryT m a
runWithConn SqlBackend
conn
Maybe SqlBackend
Nothing -> (SqlBackend -> SqlQueryT m a) -> SqlQueryT m a
forall (m :: * -> *) a.
MonadUnliftIO m =>
(SqlBackend -> SqlQueryT m a) -> SqlQueryT m a
withTransactionConn SqlBackend -> SqlQueryT m a
runWithConn
where
runWithConn :: SqlBackend -> SqlQueryT m a
runWithConn = ReaderT SqlBackend (SqlQueryT m) a -> SqlBackend -> SqlQueryT m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (SqlQueryRep record a -> ReaderT SqlBackend (SqlQueryT m) a
forall (m :: * -> *) record a.
MonadUnliftIO m =>
SqlQueryRep record a -> SqlPersistT m a
runSqlQueryRep SqlQueryRep record a
queryRep)
withTransaction :: SqlQueryT m a -> SqlQueryT m a
withTransaction SqlQueryT m a
action = (SqlBackend -> SqlQueryT m a) -> SqlQueryT m a
forall (m :: * -> *) a.
MonadUnliftIO m =>
(SqlBackend -> SqlQueryT m a) -> SqlQueryT m a
withTransactionConn ((SqlBackend -> SqlQueryT m a) -> SqlQueryT m a)
-> (SqlBackend -> SqlQueryT m a) -> SqlQueryT m a
forall a b. (a -> b) -> a -> b
$ \SqlBackend
_ -> SqlQueryT m a
action
instance MonadUnliftIO m => MonadUnliftIO (SqlQueryT m) where
withRunInIO :: ((forall a. SqlQueryT m a -> IO a) -> IO b) -> SqlQueryT m b
withRunInIO = (ReaderT SqlQueryEnv m b -> SqlQueryT m b)
-> (forall a. SqlQueryT m a -> ReaderT SqlQueryEnv m a)
-> ((forall a. SqlQueryT m a -> IO a) -> IO b)
-> SqlQueryT m b
forall (n :: * -> *) b (m :: * -> *).
MonadUnliftIO n =>
(n b -> m b)
-> (forall a. m a -> n a)
-> ((forall a. m a -> IO a) -> IO b)
-> m b
wrappedWithRunInIO ReaderT SqlQueryEnv m b -> SqlQueryT m b
forall (m :: * -> *) a. ReaderT SqlQueryEnv m a -> SqlQueryT m a
SqlQueryT forall a. SqlQueryT m a -> ReaderT SqlQueryEnv m a
forall (m :: * -> *) a. SqlQueryT m a -> ReaderT SqlQueryEnv m a
unSqlQueryT
runSqlQueryT :: Pool SqlBackend -> SqlQueryT m a -> m a
runSqlQueryT :: Pool SqlBackend -> SqlQueryT m a -> m a
runSqlQueryT Pool SqlBackend
backendPool = (ReaderT SqlQueryEnv m a -> SqlQueryEnv -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
`runReaderT` SqlQueryEnv
env) (ReaderT SqlQueryEnv m a -> m a)
-> (SqlQueryT m a -> ReaderT SqlQueryEnv m a)
-> SqlQueryT m a
-> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SqlQueryT m a -> ReaderT SqlQueryEnv m a
forall (m :: * -> *) a. SqlQueryT m a -> ReaderT SqlQueryEnv m a
unSqlQueryT
where
env :: SqlQueryEnv
env = SqlQueryEnv :: Pool SqlBackend -> Maybe SqlBackend -> SqlQueryEnv
SqlQueryEnv { currentConn :: Maybe SqlBackend
currentConn = Maybe SqlBackend
forall a. Maybe a
Nothing, Pool SqlBackend
backendPool :: Pool SqlBackend
backendPool :: Pool SqlBackend
.. }
withTransactionConn :: MonadUnliftIO m => (SqlBackend -> SqlQueryT m a) -> SqlQueryT m a
withTransactionConn :: (SqlBackend -> SqlQueryT m a) -> SqlQueryT m a
withTransactionConn SqlBackend -> SqlQueryT m a
f = do
SqlQueryEnv{Pool SqlBackend
backendPool :: Pool SqlBackend
backendPool :: SqlQueryEnv -> Pool SqlBackend
backendPool} <- ReaderT SqlQueryEnv m SqlQueryEnv -> SqlQueryT m SqlQueryEnv
forall (m :: * -> *) a. ReaderT SqlQueryEnv m a -> SqlQueryT m a
SqlQueryT ReaderT SqlQueryEnv m SqlQueryEnv
forall r (m :: * -> *). MonadReader r m => m r
ask
Acquire SqlBackend
-> (SqlBackend -> SqlQueryT m a) -> SqlQueryT m a
forall (m :: * -> *) a b.
MonadUnliftIO m =>
Acquire a -> (a -> m b) -> m b
withAcquire (Pool SqlBackend -> Acquire SqlBackend
forall a. Pool a -> Acquire a
poolToAcquire Pool SqlBackend
backendPool) ((SqlBackend -> SqlQueryT m a) -> SqlQueryT m a)
-> (SqlBackend -> SqlQueryT m a) -> SqlQueryT m a
forall a b. (a -> b) -> a -> b
$ \SqlBackend
conn ->
ReaderT SqlQueryEnv m a -> SqlQueryT m a
forall (m :: * -> *) a. ReaderT SqlQueryEnv m a -> SqlQueryT m a
SqlQueryT (ReaderT SqlQueryEnv m a -> SqlQueryT m a)
-> (SqlQueryT m a -> ReaderT SqlQueryEnv m a)
-> SqlQueryT m a
-> SqlQueryT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SqlQueryEnv -> SqlQueryEnv)
-> ReaderT SqlQueryEnv m a -> ReaderT SqlQueryEnv m a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (SqlBackend -> SqlQueryEnv -> SqlQueryEnv
setCurrentConn SqlBackend
conn) (ReaderT SqlQueryEnv m a -> ReaderT SqlQueryEnv m a)
-> (SqlQueryT m a -> ReaderT SqlQueryEnv m a)
-> SqlQueryT m a
-> ReaderT SqlQueryEnv m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SqlQueryT m a -> ReaderT SqlQueryEnv m a
forall (m :: * -> *) a. SqlQueryT m a -> ReaderT SqlQueryEnv m a
unSqlQueryT (SqlQueryT m a -> SqlQueryT m a) -> SqlQueryT m a -> SqlQueryT m a
forall a b. (a -> b) -> a -> b
$
ReaderT SqlBackend (SqlQueryT m) a -> SqlBackend -> SqlQueryT m a
forall backend (m :: * -> *) a.
(MonadUnliftIO m, BackendCompatible SqlBackend backend) =>
ReaderT backend m a -> backend -> m a
runSqlConn (SqlQueryT m a -> ReaderT SqlBackend (SqlQueryT m) a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (SqlQueryT m a -> ReaderT SqlBackend (SqlQueryT m) a)
-> SqlQueryT m a -> ReaderT SqlBackend (SqlQueryT m) a
forall a b. (a -> b) -> a -> b
$ SqlBackend -> SqlQueryT m a
f SqlBackend
conn) SqlBackend
conn
where
setCurrentConn :: SqlBackend -> SqlQueryEnv -> SqlQueryEnv
setCurrentConn SqlBackend
conn SqlQueryEnv
env = SqlQueryEnv
env { currentConn :: Maybe SqlBackend
currentConn = SqlBackend -> Maybe SqlBackend
forall a. a -> Maybe a
Just SqlBackend
conn }