{-|
Module: Database.Persist.Monad

Defines the 'SqlQueryT' monad transformer that has a 'MonadSqlQuery' instance
to execute @persistent@ database operations.

Usage:

@
myFunction :: (MonadSqlQuery m, MonadIO m) => m ()
myFunction = do
  insert_ $ Person { name = \"Alice\", age = Just 25 }
  insert_ $ Person { name = \"Bob\", age = Nothing }

  -- some other business logic

  personList <- selectList [] []
  liftIO $ print (personList :: [Person])

  -- everything in here will run in a transaction
  withTransaction $
    selectFirst [PersonAge >. 30] [] >>= \\case
      Nothing -> insert_ $ Person { name = \"Claire\", age = Just 50 }
      Just (Entity key person) -> replace key person{ age = Just (age person - 10) }

  -- some more business logic

  return ()
@
-}

{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Database.Persist.Monad
  (
  -- * Type class for executing database queries
    MonadSqlQuery
  , withTransaction
  , SqlQueryRep(..)

  -- * SqlQueryT monad transformer
  , SqlQueryT
  , runSqlQueryT

  -- * Lifted functions
  , 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

{- SqlQueryT monad -}

data SqlQueryEnv = SqlQueryEnv
  { SqlQueryEnv -> Pool SqlBackend
backendPool :: Pool SqlBackend
  , SqlQueryEnv -> Maybe SqlBackend
currentConn :: Maybe SqlBackend
  }

-- | The monad transformer that implements 'MonadSqlQuery'.
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

{- Running SqlQueryT -}

-- | Run the 'SqlQueryT' monad transformer with the given backend.
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
.. }

-- | Start a new transaction and get the connection.
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 }