module Database.PostgreSQL.Transact where
import Control.Monad.Trans.Reader
import qualified Database.PostgreSQL.Simple as Simple
import Database.PostgreSQL.Simple (ToRow, FromRow, Connection, SqlError (..))
import Database.PostgreSQL.Simple.Types as Simple
import qualified Database.PostgreSQL.Simple.Transaction as Simple
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Control.Monad.Trans.Control
import Control.Monad.Catch
import Data.Int
import Control.Monad
import qualified Data.ByteString as BS
import qualified Control.Monad.Fail as Fail
import Control.Applicative
import Data.Typeable

newtype DBT m a = DBT { DBT m a -> ReaderT Connection m a
unDBT :: ReaderT Connection m a }
  deriving (m a -> DBT m a
(forall (m :: * -> *) a. Monad m => m a -> DBT m a)
-> MonadTrans DBT
forall (m :: * -> *) a. Monad m => m a -> DBT m a
forall (t :: (* -> *) -> * -> *).
(forall (m :: * -> *) a. Monad m => m a -> t m a) -> MonadTrans t
lift :: m a -> DBT m a
$clift :: forall (m :: * -> *) a. Monad m => m a -> DBT m a
MonadTrans, Monad (DBT m)
e -> DBT m a
Monad (DBT m)
-> (forall e a. Exception e => e -> DBT m a) -> MonadThrow (DBT m)
forall e a. Exception e => e -> DBT m a
forall (m :: * -> *).
Monad m -> (forall e a. Exception e => e -> m a) -> MonadThrow m
forall (m :: * -> *). MonadThrow m => Monad (DBT m)
forall (m :: * -> *) e a.
(MonadThrow m, Exception e) =>
e -> DBT m a
throwM :: e -> DBT m a
$cthrowM :: forall (m :: * -> *) e a.
(MonadThrow m, Exception e) =>
e -> DBT m a
$cp1MonadThrow :: forall (m :: * -> *). MonadThrow m => Monad (DBT m)
MonadThrow)

instance (Applicative m, Semigroup a) => Semigroup (DBT m a) where
  <> :: DBT m a -> DBT m a -> DBT m a
(<>) = (a -> a -> a) -> DBT m a -> DBT m a -> DBT m a
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> a -> a
forall a. Semigroup a => a -> a -> a
(<>)

instance (Applicative m, Monoid a) => Monoid (DBT m a) where
  mempty :: DBT m a
mempty = a -> DBT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
forall a. Monoid a => a
mempty
  mappend :: DBT m a -> DBT m a -> DBT m a
mappend = DBT m a -> DBT m a -> DBT m a
forall a. Semigroup a => a -> a -> a
(<>)

type DB = DBT IO

instance Functor m => Functor (DBT m) where
  fmap :: (a -> b) -> DBT m a -> DBT m b
fmap a -> b
f = ReaderT Connection m b -> DBT m b
forall (m :: * -> *) a. ReaderT Connection m a -> DBT m a
DBT (ReaderT Connection m b -> DBT m b)
-> (DBT m a -> ReaderT Connection m b) -> DBT m a -> DBT m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> b) -> ReaderT Connection m a -> ReaderT Connection m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (ReaderT Connection m a -> ReaderT Connection m b)
-> (DBT m a -> ReaderT Connection m a)
-> DBT m a
-> ReaderT Connection m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DBT m a -> ReaderT Connection m a
forall (m :: * -> *) a. DBT m a -> ReaderT Connection m a
unDBT

instance Applicative m => Applicative (DBT m) where
  pure :: a -> DBT m a
pure = ReaderT Connection m a -> DBT m a
forall (m :: * -> *) a. ReaderT Connection m a -> DBT m a
DBT (ReaderT Connection m a -> DBT m a)
-> (a -> ReaderT Connection m a) -> a -> DBT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ReaderT Connection m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  DBT m (a -> b)
f <*> :: DBT m (a -> b) -> DBT m a -> DBT m b
<*> DBT m a
v = ReaderT Connection m b -> DBT m b
forall (m :: * -> *) a. ReaderT Connection m a -> DBT m a
DBT (ReaderT Connection m b -> DBT m b)
-> ReaderT Connection m b -> DBT m b
forall a b. (a -> b) -> a -> b
$ DBT m (a -> b) -> ReaderT Connection m (a -> b)
forall (m :: * -> *) a. DBT m a -> ReaderT Connection m a
unDBT DBT m (a -> b)
f ReaderT Connection m (a -> b)
-> ReaderT Connection m a -> ReaderT Connection m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> DBT m a -> ReaderT Connection m a
forall (m :: * -> *) a. DBT m a -> ReaderT Connection m a
unDBT DBT m a
v

instance MonadIO m => MonadIO (DBT m) where
  liftIO :: IO a -> DBT m a
liftIO = m a -> DBT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> DBT m a) -> (IO a -> m a) -> IO a -> DBT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO

instance Monad m => Monad (DBT m) where
  return :: a -> DBT m a
return = m a -> DBT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> DBT m a) -> (a -> m a) -> a -> DBT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return
  DBT ReaderT Connection m a
m >>= :: DBT m a -> (a -> DBT m b) -> DBT m b
>>= a -> DBT m b
k = ReaderT Connection m b -> DBT m b
forall (m :: * -> *) a. ReaderT Connection m a -> DBT m a
DBT (ReaderT Connection m b -> DBT m b)
-> ReaderT Connection m b -> DBT m b
forall a b. (a -> b) -> a -> b
$ ReaderT Connection m a
m ReaderT Connection m a
-> (a -> ReaderT Connection m b) -> ReaderT Connection m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= DBT m b -> ReaderT Connection m b
forall (m :: * -> *) a. DBT m a -> ReaderT Connection m a
unDBT (DBT m b -> ReaderT Connection m b)
-> (a -> DBT m b) -> a -> ReaderT Connection m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> DBT m b
k

instance Fail.MonadFail m => Fail.MonadFail (DBT m) where
  fail :: String -> DBT m a
fail = m a -> DBT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> DBT m a) -> (String -> m a) -> String -> DBT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail

isClass25 :: SqlError -> Bool
isClass25 :: SqlError -> Bool
isClass25 SqlError{ByteString
ExecStatus
sqlState :: SqlError -> ByteString
sqlExecStatus :: SqlError -> ExecStatus
sqlErrorMsg :: SqlError -> ByteString
sqlErrorDetail :: SqlError -> ByteString
sqlErrorHint :: SqlError -> ByteString
sqlErrorHint :: ByteString
sqlErrorDetail :: ByteString
sqlErrorMsg :: ByteString
sqlExecStatus :: ExecStatus
sqlState :: ByteString
..} = Int -> ByteString -> ByteString
BS.take Int
2 ByteString
sqlState ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"25"

isNoTransaction :: SqlError -> Bool
isNoTransaction :: SqlError -> Bool
isNoTransaction SqlError{ByteString
ExecStatus
sqlErrorHint :: ByteString
sqlErrorDetail :: ByteString
sqlErrorMsg :: ByteString
sqlExecStatus :: ExecStatus
sqlState :: ByteString
sqlState :: SqlError -> ByteString
sqlExecStatus :: SqlError -> ExecStatus
sqlErrorMsg :: SqlError -> ByteString
sqlErrorDetail :: SqlError -> ByteString
sqlErrorHint :: SqlError -> ByteString
..} = ByteString
sqlState ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"25P01"

instance (MonadIO m, MonadMask m) => MonadCatch (DBT m) where
  catch :: DBT m a -> (e -> DBT m a) -> DBT m a
catch (DBT ReaderT Connection m a
act) e -> DBT m a
handler = ReaderT Connection m a -> DBT m a
forall (m :: * -> *) a. ReaderT Connection m a -> DBT m a
DBT (ReaderT Connection m a -> DBT m a)
-> ReaderT Connection m a -> DBT m a
forall a b. (a -> b) -> a -> b
$ ((forall a. ReaderT Connection m a -> ReaderT Connection m a)
 -> ReaderT Connection m a)
-> ReaderT Connection m a
forall (m :: * -> *) b.
MonadMask m =>
((forall a. m a -> m a) -> m b) -> m b
mask (((forall a. ReaderT Connection m a -> ReaderT Connection m a)
  -> ReaderT Connection m a)
 -> ReaderT Connection m a)
-> ((forall a. ReaderT Connection m a -> ReaderT Connection m a)
    -> ReaderT Connection m a)
-> ReaderT Connection m a
forall a b. (a -> b) -> a -> b
$ \forall a. ReaderT Connection m a -> ReaderT Connection m a
restore -> do
    Connection
conn <- ReaderT Connection m Connection
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
    Savepoint
sp   <- IO Savepoint -> ReaderT Connection m Savepoint
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Savepoint -> ReaderT Connection m Savepoint)
-> IO Savepoint -> ReaderT Connection m Savepoint
forall a b. (a -> b) -> a -> b
$ Connection -> IO Savepoint
Simple.newSavepoint Connection
conn
    let setup :: ReaderT Connection m a
setup = ReaderT Connection m a
-> (e -> ReaderT Connection m a) -> ReaderT Connection m a
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
catch (ReaderT Connection m a -> ReaderT Connection m a
forall a. ReaderT Connection m a -> ReaderT Connection m a
restore ReaderT Connection m a
act) ((e -> ReaderT Connection m a) -> ReaderT Connection m a)
-> (e -> ReaderT Connection m a) -> ReaderT Connection m a
forall a b. (a -> b) -> a -> b
$ \e
e -> do
                  IO () -> ReaderT Connection m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT Connection m ())
-> IO () -> ReaderT Connection m ()
forall a b. (a -> b) -> a -> b
$ Connection -> Savepoint -> IO ()
Simple.rollbackToSavepoint Connection
conn Savepoint
sp
                    IO () -> (SqlError -> IO ()) -> IO ()
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` (\SqlError
re -> if SqlError -> Bool
isNoTransaction SqlError
re then () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure () else SqlError -> IO ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM SqlError
re)
                  if Proxy Abort -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy Abort
forall k (t :: k). Proxy t
Proxy @Abort) TypeRep -> TypeRep -> Bool
forall a. Eq a => a -> a -> Bool
== e -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf e
e
                    then (Abort -> ReaderT Connection m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM Abort
Abort)
                    else DBT m a -> ReaderT Connection m a
forall (m :: * -> *) a. DBT m a -> ReaderT Connection m a
unDBT (DBT m a -> ReaderT Connection m a)
-> DBT m a -> ReaderT Connection m a
forall a b. (a -> b) -> a -> b
$ e -> DBT m a
handler e
e

    ReaderT Connection m a
setup ReaderT Connection m a
-> ReaderT Connection m (Either () ()) -> ReaderT Connection m a
forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
`finally` IO (Either () ()) -> ReaderT Connection m (Either () ())
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ((SqlError -> Maybe ()) -> IO () -> IO (Either () ())
forall (m :: * -> *) e b a.
(MonadCatch m, Exception e) =>
(e -> Maybe b) -> m a -> m (Either b a)
tryJust (Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> (SqlError -> Bool) -> SqlError -> Maybe ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SqlError -> Bool
isClass25) (Connection -> Savepoint -> IO ()
Simple.releaseSavepoint Connection
conn Savepoint
sp))

instance (MonadIO m, MonadMask m) => MonadMask (DBT m) where
  mask :: ((forall a. DBT m a -> DBT m a) -> DBT m b) -> DBT m b
mask (forall a. DBT m a -> DBT m a) -> DBT m b
a = ReaderT Connection m b -> DBT m b
forall (m :: * -> *) a. ReaderT Connection m a -> DBT m a
DBT (ReaderT Connection m b -> DBT m b)
-> ReaderT Connection m b -> DBT m b
forall a b. (a -> b) -> a -> b
$ ((forall a. ReaderT Connection m a -> ReaderT Connection m a)
 -> ReaderT Connection m b)
-> ReaderT Connection m b
forall (m :: * -> *) b.
MonadMask m =>
((forall a. m a -> m a) -> m b) -> m b
mask (((forall a. ReaderT Connection m a -> ReaderT Connection m a)
  -> ReaderT Connection m b)
 -> ReaderT Connection m b)
-> ((forall a. ReaderT Connection m a -> ReaderT Connection m a)
    -> ReaderT Connection m b)
-> ReaderT Connection m b
forall a b. (a -> b) -> a -> b
$ \forall a. ReaderT Connection m a -> ReaderT Connection m a
u -> DBT m b -> ReaderT Connection m b
forall (m :: * -> *) a. DBT m a -> ReaderT Connection m a
unDBT ((forall a. DBT m a -> DBT m a) -> DBT m b
a ((forall a. DBT m a -> DBT m a) -> DBT m b)
-> (forall a. DBT m a -> DBT m a) -> DBT m b
forall a b. (a -> b) -> a -> b
$ (ReaderT Connection m a -> ReaderT Connection m a)
-> DBT m a -> DBT m a
forall (m :: * -> *) a.
(ReaderT Connection m a -> ReaderT Connection m a)
-> DBT m a -> DBT m a
q ReaderT Connection m a -> ReaderT Connection m a
forall a. ReaderT Connection m a -> ReaderT Connection m a
u)
    where q :: (ReaderT Connection m a -> ReaderT Connection m a) -> DBT m a -> DBT m a
          q :: (ReaderT Connection m a -> ReaderT Connection m a)
-> DBT m a -> DBT m a
q ReaderT Connection m a -> ReaderT Connection m a
u (DBT ReaderT Connection m a
b) = ReaderT Connection m a -> DBT m a
forall (m :: * -> *) a. ReaderT Connection m a -> DBT m a
DBT (ReaderT Connection m a -> DBT m a)
-> ReaderT Connection m a -> DBT m a
forall a b. (a -> b) -> a -> b
$ ReaderT Connection m a -> ReaderT Connection m a
u ReaderT Connection m a
b

  uninterruptibleMask :: ((forall a. DBT m a -> DBT m a) -> DBT m b) -> DBT m b
uninterruptibleMask (forall a. DBT m a -> DBT m a) -> DBT m b
a =
    ReaderT Connection m b -> DBT m b
forall (m :: * -> *) a. ReaderT Connection m a -> DBT m a
DBT (ReaderT Connection m b -> DBT m b)
-> ReaderT Connection m b -> DBT m b
forall a b. (a -> b) -> a -> b
$ ((forall a. ReaderT Connection m a -> ReaderT Connection m a)
 -> ReaderT Connection m b)
-> ReaderT Connection m b
forall (m :: * -> *) b.
MonadMask m =>
((forall a. m a -> m a) -> m b) -> m b
uninterruptibleMask (((forall a. ReaderT Connection m a -> ReaderT Connection m a)
  -> ReaderT Connection m b)
 -> ReaderT Connection m b)
-> ((forall a. ReaderT Connection m a -> ReaderT Connection m a)
    -> ReaderT Connection m b)
-> ReaderT Connection m b
forall a b. (a -> b) -> a -> b
$ \forall a. ReaderT Connection m a -> ReaderT Connection m a
u -> DBT m b -> ReaderT Connection m b
forall (m :: * -> *) a. DBT m a -> ReaderT Connection m a
unDBT ((forall a. DBT m a -> DBT m a) -> DBT m b
a ((forall a. DBT m a -> DBT m a) -> DBT m b)
-> (forall a. DBT m a -> DBT m a) -> DBT m b
forall a b. (a -> b) -> a -> b
$ (ReaderT Connection m a -> ReaderT Connection m a)
-> DBT m a -> DBT m a
forall (m :: * -> *) a.
(ReaderT Connection m a -> ReaderT Connection m a)
-> DBT m a -> DBT m a
q ReaderT Connection m a -> ReaderT Connection m a
forall a. ReaderT Connection m a -> ReaderT Connection m a
u)
      where q :: (ReaderT Connection m a -> ReaderT Connection m a) -> DBT m a -> DBT m a
            q :: (ReaderT Connection m a -> ReaderT Connection m a)
-> DBT m a -> DBT m a
q ReaderT Connection m a -> ReaderT Connection m a
u (DBT ReaderT Connection m a
b) = ReaderT Connection m a -> DBT m a
forall (m :: * -> *) a. ReaderT Connection m a -> DBT m a
DBT (ReaderT Connection m a -> DBT m a)
-> ReaderT Connection m a -> DBT m a
forall a b. (a -> b) -> a -> b
$ ReaderT Connection m a -> ReaderT Connection m a
u ReaderT Connection m a
b

  generalBracket :: DBT m a
-> (a -> ExitCase b -> DBT m c) -> (a -> DBT m b) -> DBT m (b, c)
generalBracket DBT m a
acquire a -> ExitCase b -> DBT m c
release a -> DBT m b
use = ReaderT Connection m (b, c) -> DBT m (b, c)
forall (m :: * -> *) a. ReaderT Connection m a -> DBT m a
DBT (ReaderT Connection m (b, c) -> DBT m (b, c))
-> ReaderT Connection m (b, c) -> DBT m (b, c)
forall a b. (a -> b) -> a -> b
$
    ReaderT Connection m a
-> (a -> ExitCase b -> ReaderT Connection m c)
-> (a -> ReaderT Connection m b)
-> ReaderT Connection m (b, c)
forall (m :: * -> *) a b c.
MonadMask m =>
m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c)
generalBracket
      (DBT m a -> ReaderT Connection m a
forall (m :: * -> *) a. DBT m a -> ReaderT Connection m a
unDBT DBT m a
acquire)
      (\a
resource ExitCase b
exitCase -> DBT m c -> ReaderT Connection m c
forall (m :: * -> *) a. DBT m a -> ReaderT Connection m a
unDBT (a -> ExitCase b -> DBT m c
release a
resource ExitCase b
exitCase))
      (\a
resource -> DBT m b -> ReaderT Connection m b
forall (m :: * -> *) a. DBT m a -> ReaderT Connection m a
unDBT (a -> DBT m b
use a
resource))

getConnection :: Monad m => DBT m Connection
getConnection :: DBT m Connection
getConnection = ReaderT Connection m Connection -> DBT m Connection
forall (m :: * -> *) a. ReaderT Connection m a -> DBT m a
DBT ReaderT Connection m Connection
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask

runDBT :: MonadBaseControl IO m => DBT m a -> Simple.IsolationLevel -> Connection -> m a
runDBT :: DBT m a -> IsolationLevel -> Connection -> m a
runDBT DBT m a
action IsolationLevel
level Connection
conn
  = (RunInBase m IO -> IO (StM m a)) -> m a
forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
(RunInBase m b -> b (StM m a)) -> m a
control
  ((RunInBase m IO -> IO (StM m a)) -> m a)
-> (RunInBase m IO -> IO (StM m a)) -> m a
forall a b. (a -> b) -> a -> b
$ \RunInBase m IO
run -> IsolationLevel -> Connection -> IO (StM m a) -> IO (StM m a)
forall a. IsolationLevel -> Connection -> IO a -> IO a
Simple.withTransactionLevel IsolationLevel
level Connection
conn
  (IO (StM m a) -> IO (StM m a)) -> IO (StM m a) -> IO (StM m a)
forall a b. (a -> b) -> a -> b
$ m a -> IO (StM m a)
RunInBase m IO
run
  (m a -> IO (StM m a)) -> m a -> IO (StM m a)
forall a b. (a -> b) -> a -> b
$ ReaderT Connection m a -> Connection -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (DBT m a -> ReaderT Connection m a
forall (m :: * -> *) a. DBT m a -> ReaderT Connection m a
unDBT DBT m a
action) Connection
conn

runDBTSerializable :: MonadBaseControl IO m => DBT m a -> Connection -> m a
runDBTSerializable :: DBT m a -> Connection -> m a
runDBTSerializable DBT m a
action Connection
conn
  = (RunInBase m IO -> IO (StM m a)) -> m a
forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
(RunInBase m b -> b (StM m a)) -> m a
control
  ((RunInBase m IO -> IO (StM m a)) -> m a)
-> (RunInBase m IO -> IO (StM m a)) -> m a
forall a b. (a -> b) -> a -> b
$ \RunInBase m IO
run -> Connection -> IO (StM m a) -> IO (StM m a)
forall a. Connection -> IO a -> IO a
Simple.withTransactionSerializable Connection
conn
  (IO (StM m a) -> IO (StM m a)) -> IO (StM m a) -> IO (StM m a)
forall a b. (a -> b) -> a -> b
$ m a -> IO (StM m a)
RunInBase m IO
run
  (m a -> IO (StM m a)) -> m a -> IO (StM m a)
forall a b. (a -> b) -> a -> b
$ ReaderT Connection m a -> Connection -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (DBT m a -> ReaderT Connection m a
forall (m :: * -> *) a. DBT m a -> ReaderT Connection m a
unDBT DBT m a
action) Connection
conn

runDBTNoTransaction :: DBT m a -> Connection -> m a
runDBTNoTransaction :: DBT m a -> Connection -> m a
runDBTNoTransaction DBT m a
action Connection
conn = ReaderT Connection m a -> Connection -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (DBT m a -> ReaderT Connection m a
forall (m :: * -> *) a. DBT m a -> ReaderT Connection m a
unDBT DBT m a
action) Connection
conn

-- | Perform a @SELECT@ or other SQL query that is expected to return
-- results. All results are retrieved and converted before this
-- function returns.
--
-- When processing large results, this function will consume a lot of
-- client-side memory.  Consider using 'fold' instead.
--
-- Exceptions that may be thrown:
--
-- * 'FormatError': the query string could not be formatted correctly.
--
-- * 'QueryError': the result contains no columns (i.e. you should be
--   using 'execute' instead of 'query').
--
-- * 'ResultError': result conversion failed.
--
-- * 'SqlError':  the postgresql backend returned an error,  e.g.
--   a syntax or type error,  or an incorrect table or column name.
query :: (ToRow a, FromRow b, MonadIO m) => Query -> a -> DBT m [b]
query :: Query -> a -> DBT m [b]
query Query
q a
x = DBT m Connection
forall (m :: * -> *). Monad m => DBT m Connection
getConnection DBT m Connection -> (Connection -> DBT m [b]) -> DBT m [b]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Connection
conn -> IO [b] -> DBT m [b]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [b] -> DBT m [b]) -> IO [b] -> DBT m [b]
forall a b. (a -> b) -> a -> b
$ Connection -> Query -> a -> IO [b]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
Simple.query Connection
conn Query
q a
x

-- | A version of 'query' that does not perform query substitution.
query_ :: (FromRow b, MonadIO m) => Query -> DBT m [b]
query_ :: Query -> DBT m [b]
query_ Query
q = DBT m Connection
forall (m :: * -> *). Monad m => DBT m Connection
getConnection DBT m Connection -> (Connection -> DBT m [b]) -> DBT m [b]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Connection
conn -> IO [b] -> DBT m [b]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [b] -> DBT m [b]) -> IO [b] -> DBT m [b]
forall a b. (a -> b) -> a -> b
$ Connection -> Query -> IO [b]
forall r. FromRow r => Connection -> Query -> IO [r]
Simple.query_ Connection
conn Query
q

-- | Execute an @INSERT@, @UPDATE@, or other SQL query that is not
-- expected to return results.
--
-- Returns the number of rows affected.
--
-- Throws 'FormatError' if the query could not be formatted correctly, or
-- a 'SqlError' exception if the backend returns an error.
execute :: (ToRow q, MonadIO m) => Query -> q -> DBT m Int64
execute :: Query -> q -> DBT m Int64
execute Query
q q
x = DBT m Connection
forall (m :: * -> *). Monad m => DBT m Connection
getConnection DBT m Connection -> (Connection -> DBT m Int64) -> DBT m Int64
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Connection
conn -> IO Int64 -> DBT m Int64
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int64 -> DBT m Int64) -> IO Int64 -> DBT m Int64
forall a b. (a -> b) -> a -> b
$ Connection -> Query -> q -> IO Int64
forall q. ToRow q => Connection -> Query -> q -> IO Int64
Simple.execute Connection
conn Query
q q
x

-- | A version of execute that does not perform query substitution.
execute_ :: MonadIO m => Query -> DBT m Int64
execute_ :: Query -> DBT m Int64
execute_ Query
q = DBT m Connection
forall (m :: * -> *). Monad m => DBT m Connection
getConnection DBT m Connection -> (Connection -> DBT m Int64) -> DBT m Int64
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Connection
conn -> IO Int64 -> DBT m Int64
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int64 -> DBT m Int64) -> IO Int64 -> DBT m Int64
forall a b. (a -> b) -> a -> b
$ Connection -> Query -> IO Int64
Simple.execute_ Connection
conn Query
q

-- | Execute a multi-row @INSERT@, @UPDATE@, or other SQL query that is not
-- expected to return results.
--
-- Returns the number of rows affected.   If the list of parameters is empty,
-- this function will simply return 0 without issuing the query to the backend.
-- If this is not desired, consider using the 'Values' constructor instead.
--
-- Throws 'FormatError' if the query could not be formatted correctly, or
-- a 'SqlError' exception if the backend returns an error.
--
-- For example,  here's a command that inserts two rows into a table
-- with two columns:
--
-- @
-- executeMany [sql|
--     INSERT INTO sometable VALUES (?,?)
--  |] [(1, \"hello\"),(2, \"world\")]
-- @
--
-- Here's an canonical example of a multi-row update command:
--
-- @
-- executeMany [sql|
--     UPDATE sometable
--        SET sometable.y = upd.y
--       FROM (VALUES (?,?)) as upd(x,y)
--      WHERE sometable.x = upd.x
--  |] [(1, \"hello\"),(2, \"world\")]
-- @

executeMany :: (ToRow q, MonadIO m) => Query -> [q] -> DBT m Int64
executeMany :: Query -> [q] -> DBT m Int64
executeMany Query
q [q]
xs = DBT m Connection
forall (m :: * -> *). Monad m => DBT m Connection
getConnection DBT m Connection -> (Connection -> DBT m Int64) -> DBT m Int64
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Connection
conn -> IO Int64 -> DBT m Int64
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int64 -> DBT m Int64) -> IO Int64 -> DBT m Int64
forall a b. (a -> b) -> a -> b
$ Connection -> Query -> [q] -> IO Int64
forall q. ToRow q => Connection -> Query -> [q] -> IO Int64
Simple.executeMany Connection
conn Query
q [q]
xs

-- | Execute @INSERT ... RETURNING@, @UPDATE ... RETURNING@, or other SQL
-- query that accepts multi-row input and is expected to return results.
-- Note that it is possible to write
--    @'query' conn "INSERT ... RETURNING ..." ...@
-- in cases where you are only inserting a single row,  and do not need
-- functionality analogous to 'executeMany'.
--
-- If the list of parameters is empty,  this function will simply return @[]@
-- without issuing the query to the backend.   If this is not desired,
-- consider using the 'Values' constructor instead.
--
-- Throws 'FormatError' if the query could not be formatted correctly.
returning :: (ToRow q, FromRow r, MonadIO m) => Query -> [q] -> DBT m [r]
returning :: Query -> [q] -> DBT m [r]
returning Query
q [q]
xs = DBT m Connection
forall (m :: * -> *). Monad m => DBT m Connection
getConnection DBT m Connection -> (Connection -> DBT m [r]) -> DBT m [r]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Connection
conn -> IO [r] -> DBT m [r]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [r] -> DBT m [r]) -> IO [r] -> DBT m [r]
forall a b. (a -> b) -> a -> b
$ Connection -> Query -> [q] -> IO [r]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> [q] -> IO [r]
Simple.returning Connection
conn Query
q [q]
xs


-- | Format a query string.
--
-- This function is exposed to help with debugging and logging. Do not
-- use it to prepare queries for execution.
--
-- String parameters are escaped according to the character set in use
-- on the 'Connection'.
--
-- Throws 'FormatError' if the query string could not be formatted
-- correctly.
formatQuery :: (ToRow q, MonadIO m) => Query -> q -> DBT m BS.ByteString
formatQuery :: Query -> q -> DBT m ByteString
formatQuery Query
q q
xs = DBT m Connection
forall (m :: * -> *). Monad m => DBT m Connection
getConnection DBT m Connection
-> (Connection -> DBT m ByteString) -> DBT m ByteString
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Connection
conn -> IO ByteString -> DBT m ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> DBT m ByteString)
-> IO ByteString -> DBT m ByteString
forall a b. (a -> b) -> a -> b
$ Connection -> Query -> q -> IO ByteString
forall q. ToRow q => Connection -> Query -> q -> IO ByteString
Simple.formatQuery Connection
conn Query
q q
xs

queryOne :: (MonadIO m, ToRow a, FromRow b) => Query -> a -> DBT m (Maybe b)
queryOne :: Query -> a -> DBT m (Maybe b)
queryOne Query
q a
x = do
  [b]
rows <- Query -> a -> DBT m [b]
forall a b (m :: * -> *).
(ToRow a, FromRow b, MonadIO m) =>
Query -> a -> DBT m [b]
query Query
q a
x
  case [b]
rows of
    []  -> Maybe b -> DBT m (Maybe b)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe b
forall a. Maybe a
Nothing
    [b
a] -> Maybe b -> DBT m (Maybe b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe b -> DBT m (Maybe b)) -> Maybe b -> DBT m (Maybe b)
forall a b. (a -> b) -> a -> b
$ b -> Maybe b
forall a. a -> Maybe a
Just b
a
    [b]
_   -> Maybe b -> DBT m (Maybe b)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe b
forall a. Maybe a
Nothing

queryOne_ :: (MonadIO m, FromRow b) => Query -> DBT m (Maybe b)
queryOne_ :: Query -> DBT m (Maybe b)
queryOne_ Query
q = do
  [b]
rows <- Query -> DBT m [b]
forall b (m :: * -> *).
(FromRow b, MonadIO m) =>
Query -> DBT m [b]
query_ Query
q
  case [b]
rows of
    []  -> Maybe b -> DBT m (Maybe b)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe b
forall a. Maybe a
Nothing
    [b
x] -> Maybe b -> DBT m (Maybe b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe b -> DBT m (Maybe b)) -> Maybe b -> DBT m (Maybe b)
forall a b. (a -> b) -> a -> b
$ b -> Maybe b
forall a. a -> Maybe a
Just b
x
    [b]
_   -> Maybe b -> DBT m (Maybe b)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe b
forall a. Maybe a
Nothing

-- | Create a 'Savepoint'.
savepoint :: MonadIO m => DBT m Savepoint
savepoint :: DBT m Savepoint
savepoint = DBT m Connection
forall (m :: * -> *). Monad m => DBT m Connection
getConnection DBT m Connection
-> (Connection -> DBT m Savepoint) -> DBT m Savepoint
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO Savepoint -> DBT m Savepoint
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Savepoint -> DBT m Savepoint)
-> (Connection -> IO Savepoint) -> Connection -> DBT m Savepoint
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Connection -> IO Savepoint
Simple.newSavepoint

-- | Release the 'Savepoint' and discard the effects.
rollbackToAndReleaseSavepoint :: MonadIO m => Savepoint -> DBT m ()
rollbackToAndReleaseSavepoint :: Savepoint -> DBT m ()
rollbackToAndReleaseSavepoint Savepoint
sp = DBT m Connection
forall (m :: * -> *). Monad m => DBT m Connection
getConnection DBT m Connection -> (Connection -> DBT m ()) -> DBT m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO () -> DBT m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> DBT m ())
-> (Connection -> IO ()) -> Connection -> DBT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Connection -> Savepoint -> IO ())
-> Savepoint -> Connection -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Connection -> Savepoint -> IO ()
Simple.rollbackToAndReleaseSavepoint Savepoint
sp

-- | Run an action and discard the effects but return the result
rollback :: (MonadMask m, MonadIO m) => DBT m a -> DBT m a
rollback :: DBT m a -> DBT m a
rollback DBT m a
actionToRollback = ((forall a. DBT m a -> DBT m a) -> DBT m a) -> DBT m a
forall (m :: * -> *) b.
MonadMask m =>
((forall a. m a -> m a) -> m b) -> m b
mask (((forall a. DBT m a -> DBT m a) -> DBT m a) -> DBT m a)
-> ((forall a. DBT m a -> DBT m a) -> DBT m a) -> DBT m a
forall a b. (a -> b) -> a -> b
$ \forall a. DBT m a -> DBT m a
restore -> do
  Savepoint
sp <- DBT m Savepoint
forall (m :: * -> *). MonadIO m => DBT m Savepoint
savepoint
  DBT m a -> DBT m a
forall a. DBT m a -> DBT m a
restore DBT m a
actionToRollback DBT m a -> DBT m () -> DBT m a
forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
`finally` Savepoint -> DBT m ()
forall (m :: * -> *). MonadIO m => Savepoint -> DBT m ()
rollbackToAndReleaseSavepoint Savepoint
sp

data Abort = Abort
  deriving (Int -> Abort -> ShowS
[Abort] -> ShowS
Abort -> String
(Int -> Abort -> ShowS)
-> (Abort -> String) -> ([Abort] -> ShowS) -> Show Abort
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Abort] -> ShowS
$cshowList :: [Abort] -> ShowS
show :: Abort -> String
$cshow :: Abort -> String
showsPrec :: Int -> Abort -> ShowS
$cshowsPrec :: Int -> Abort -> ShowS
Show, Abort -> Abort -> Bool
(Abort -> Abort -> Bool) -> (Abort -> Abort -> Bool) -> Eq Abort
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Abort -> Abort -> Bool
$c/= :: Abort -> Abort -> Bool
== :: Abort -> Abort -> Bool
$c== :: Abort -> Abort -> Bool
Eq, Typeable)

instance Exception Abort

-- | A 'abort' is a similar to 'rollback' but calls 'ROLLBACK' to abort the
--   transaction. 'abort's is global. It affects everything before and after
--   it is called. Duplicate 'abort's do nothing.
--   Calling 'abort' throws an 'Abort' exception that is not caught
--   by the transaction running functions. If you call 'abort' you need to
--   also be prepared to handle the 'Abort' exception.
abort :: (MonadMask m, MonadIO m) => DBT m a -> DBT m a
abort :: DBT m a -> DBT m a
abort = (DBT m a -> DBT m Any -> DBT m a)
-> DBT m Any -> DBT m a -> DBT m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip DBT m a -> DBT m Any -> DBT m a
forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
finally (Abort -> DBT m Any
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM Abort
Abort)