{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-partial-type-signatures #-}

{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}

module Database.Beam.Postgres.Connection
  ( Pg(..), PgF(..)

  , liftIOWithHandle

  , runBeamPostgres, runBeamPostgresDebug

  , pgRenderSyntax, runPgRowReader, getFields

  , withPgDebug

  , postgresUriSyntax ) where

import           Control.Exception (SomeException(..), throwIO)
import           Control.Monad.Base (MonadBase(..))
import           Control.Monad.Free.Church
import           Control.Monad.IO.Class
import           Control.Monad.Trans.Control (MonadBaseControl(..))

import           Database.Beam hiding (runDelete, runUpdate, runInsert, insert)
import           Database.Beam.Backend.SQL.BeamExtensions
import           Database.Beam.Backend.SQL.Row ( FromBackendRowF(..), FromBackendRowM(..)
                                               , BeamRowReadError(..), ColumnParseError(..) )
import           Database.Beam.Backend.URI
import           Database.Beam.Schema.Tables

import           Database.Beam.Postgres.Syntax
import           Database.Beam.Postgres.Full
import           Database.Beam.Postgres.Types

import qualified Database.PostgreSQL.LibPQ as Pg hiding
  (Connection, escapeStringConn, escapeIdentifier, escapeByteaConn, exec)
import qualified Database.PostgreSQL.Simple as Pg
import qualified Database.PostgreSQL.Simple.FromField as Pg
import qualified Database.PostgreSQL.Simple.Internal as Pg
  ( Field(..), RowParser(..)
  , escapeStringConn, escapeIdentifier, escapeByteaConn
  , exec, throwResultError )
import qualified Database.PostgreSQL.Simple.Internal as PgI
import qualified Database.PostgreSQL.Simple.Ok as Pg
import qualified Database.PostgreSQL.Simple.Types as Pg (Query(..))

import           Control.Monad.Reader
import           Control.Monad.State
import qualified Control.Monad.Fail as Fail

import           Data.ByteString (ByteString)
import           Data.ByteString.Builder (toLazyByteString, byteString)
import qualified Data.ByteString.Lazy as BL
import           Data.Maybe (listToMaybe, fromMaybe)
import           Data.Proxy
import           Data.String
import qualified Data.Text as T
import           Data.Text.Encoding (decodeUtf8)
import           Data.Typeable (cast)
#if !MIN_VERSION_base(4, 11, 0)
import           Data.Semigroup
#endif

import           Foreign.C.Types

import           Network.URI (uriToString)

data PgStream a = PgStreamDone     (Either BeamRowReadError a)
                | PgStreamContinue (Maybe PgI.Row -> IO (PgStream a))

-- | 'BeamURIOpeners' for the standard @postgresql:@ URI scheme. See the
-- postgres documentation for more details on the formatting. See documentation
-- for 'BeamURIOpeners' for more information on how to use this with beam
postgresUriSyntax :: c Postgres Pg.Connection Pg
                  -> BeamURIOpeners c
postgresUriSyntax :: forall (c :: * -> * -> (* -> *) -> *).
c Postgres Connection Pg -> BeamURIOpeners c
postgresUriSyntax =
    forall hdl (m :: * -> *) (c :: * -> * -> (* -> *) -> *) be.
(forall a. hdl -> m a -> IO a)
-> String
-> (URI -> IO (hdl, IO ()))
-> c be hdl m
-> BeamURIOpeners c
mkUriOpener forall a. Connection -> Pg a -> IO a
runBeamPostgres String
"postgresql:"
        (\URI
uri -> do
            let pgConnStr :: ByteString
pgConnStr = forall a. IsString a => String -> a
fromString ((String -> String) -> URI -> String -> String
uriToString forall a. a -> a
id URI
uri String
"")
            Connection
hdl <- ByteString -> IO Connection
Pg.connectPostgreSQL ByteString
pgConnStr
            forall (f :: * -> *) a. Applicative f => a -> f a
pure (Connection
hdl, Connection -> IO ()
Pg.close Connection
hdl))

-- * Syntax rendering

pgRenderSyntax ::
  Pg.Connection -> PgSyntax -> IO ByteString
pgRenderSyntax :: Connection -> PgSyntax -> IO ByteString
pgRenderSyntax Connection
conn (PgSyntax PgSyntaxM ()
mkQuery) =
  Builder -> ByteString
renderBuilder forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a.
F f a -> forall r. (a -> r) -> (f r -> r) -> r
runF PgSyntaxM ()
mkQuery forall {f :: * -> *} {p} {a}. Applicative f => p -> a -> f a
finish PgSyntaxF (Builder -> IO Builder) -> Builder -> IO Builder
step forall a. Monoid a => a
mempty
  where
    renderBuilder :: Builder -> ByteString
renderBuilder = ByteString -> ByteString
BL.toStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
toLazyByteString

    step :: PgSyntaxF (Builder -> IO Builder) -> Builder -> IO Builder
step (EmitBuilder Builder
b Builder -> IO Builder
next) Builder
a = Builder -> IO Builder
next (Builder
a forall a. Semigroup a => a -> a -> a
<> Builder
b)
    step (EmitByteString ByteString
b Builder -> IO Builder
next) Builder
a = Builder -> IO Builder
next (Builder
a forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
byteString ByteString
b)
    step (EscapeString ByteString
b Builder -> IO Builder
next) Builder
a = do
      ByteString
res <- forall {m :: * -> *} {a} {b}.
(MonadFail m, Show a) =>
String -> m (Either a b) -> m b
wrapError String
"EscapeString" (Connection -> ByteString -> IO (Either ByteString ByteString)
Pg.escapeStringConn Connection
conn ByteString
b)
      Builder -> IO Builder
next (Builder
a forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
byteString ByteString
res)
    step (EscapeBytea ByteString
b Builder -> IO Builder
next) Builder
a = do
      ByteString
res <- forall {m :: * -> *} {a} {b}.
(MonadFail m, Show a) =>
String -> m (Either a b) -> m b
wrapError String
"EscapeBytea" (Connection -> ByteString -> IO (Either ByteString ByteString)
Pg.escapeByteaConn Connection
conn ByteString
b)
      Builder -> IO Builder
next (Builder
a forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
byteString ByteString
res)
    step (EscapeIdentifier ByteString
b Builder -> IO Builder
next) Builder
a = do
      ByteString
res <- forall {m :: * -> *} {a} {b}.
(MonadFail m, Show a) =>
String -> m (Either a b) -> m b
wrapError String
"EscapeIdentifier" (Connection -> ByteString -> IO (Either ByteString ByteString)
Pg.escapeIdentifier Connection
conn ByteString
b)
      Builder -> IO Builder
next (Builder
a forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
byteString ByteString
res)

    finish :: p -> a -> f a
finish p
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure

    wrapError :: String -> m (Either a b) -> m b
wrapError String
step' m (Either a b)
go = do
      Either a b
res <- m (Either a b)
go
      case Either a b
res of
        Right b
res' -> forall (f :: * -> *) a. Applicative f => a -> f a
pure b
res'
        Left a
res' -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
step' forall a. Semigroup a => a -> a -> a
<> String
": " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show a
res')

-- * Run row readers

getFields :: Pg.Result -> IO [Pg.Field]
getFields :: Result -> IO [Field]
getFields Result
res = do
  Pg.Col CInt
colCount <- Result -> IO Column
Pg.nfields Result
res

  let getField :: CInt -> IO Field
getField CInt
col =
        Result -> Column -> Oid -> Field
Pg.Field Result
res (CInt -> Column
Pg.Col CInt
col) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Result -> Column -> IO Oid
Pg.ftype Result
res (CInt -> Column
Pg.Col CInt
col)

  forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM CInt -> IO Field
getField [CInt
0..CInt
colCount forall a. Num a => a -> a -> a
- CInt
1]

runPgRowReader ::
  Pg.Connection -> Pg.Row -> Pg.Result -> [Pg.Field] -> FromBackendRowM Postgres a -> IO (Either BeamRowReadError a)
runPgRowReader :: forall a.
Connection
-> Row
-> Result
-> [Field]
-> FromBackendRowM Postgres a
-> IO (Either BeamRowReadError a)
runPgRowReader Connection
conn Row
rowIdx Result
res [Field]
fields (FromBackendRowM F (FromBackendRowF Postgres) a
readRow) =
  Result -> IO Column
Pg.nfields Result
res forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(Pg.Col CInt
colCount) ->
  forall (f :: * -> *) a.
F f a -> forall r. (a -> r) -> (f r -> r) -> r
runF F (FromBackendRowF Postgres) a
readRow forall {f :: * -> *} {b} {p} {p} {p} {a}.
Applicative f =>
b -> p -> p -> p -> f (Either a b)
finish forall x.
FromBackendRowF
  Postgres
  (CInt -> CInt -> [Field] -> IO (Either BeamRowReadError x))
-> CInt -> CInt -> [Field] -> IO (Either BeamRowReadError x)
step CInt
0 CInt
colCount [Field]
fields
  where

    step :: forall x. FromBackendRowF Postgres (CInt -> CInt -> [PgI.Field] -> IO (Either BeamRowReadError x))
         -> CInt -> CInt -> [PgI.Field] -> IO (Either BeamRowReadError x)
    step :: forall x.
FromBackendRowF
  Postgres
  (CInt -> CInt -> [Field] -> IO (Either BeamRowReadError x))
-> CInt -> CInt -> [Field] -> IO (Either BeamRowReadError x)
step (ParseOneField a -> CInt -> CInt -> [Field] -> IO (Either BeamRowReadError x)
_) CInt
curCol CInt
colCount [] = forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> Either a b
Left (Maybe Int -> ColumnParseError -> BeamRowReadError
BeamRowReadError (forall a. a -> Maybe a
Just (forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
curCol)) (Int -> ColumnParseError
ColumnNotEnoughColumns (forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
colCount))))
    step (ParseOneField a -> CInt -> CInt -> [Field] -> IO (Either BeamRowReadError x)
_) CInt
curCol CInt
colCount [Field]
_
      | CInt
curCol forall a. Ord a => a -> a -> Bool
>= CInt
colCount = forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> Either a b
Left (Maybe Int -> ColumnParseError -> BeamRowReadError
BeamRowReadError (forall a. a -> Maybe a
Just (forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
curCol)) (Int -> ColumnParseError
ColumnNotEnoughColumns (forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
colCount))))
    step (ParseOneField (a -> CInt -> CInt -> [Field] -> IO (Either BeamRowReadError x)
next' :: next -> _)) CInt
curCol CInt
colCount (Field
field:[Field]
remainingFields) =
      do Maybe ByteString
fieldValue <- Result -> Row -> Column -> IO (Maybe ByteString)
Pg.getvalue' Result
res Row
rowIdx (CInt -> Column
Pg.Col CInt
curCol)
         Ok a
res' <- forall a. Conversion a -> Connection -> IO (Ok a)
Pg.runConversion (forall a. FromField a => FieldParser a
Pg.fromField Field
field Maybe ByteString
fieldValue) Connection
conn
         case Ok a
res' of
           Pg.Errors [SomeException]
errs ->
             let err :: ColumnParseError
err = forall a. a -> Maybe a -> a
fromMaybe (String -> ColumnParseError
ColumnErrorInternal String
"Column parse failed with unknown exception") forall a b. (a -> b) -> a -> b
$
                       forall a. [a] -> Maybe a
listToMaybe forall a b. (a -> b) -> a -> b
$
                       do SomeException e
e <- [SomeException]
errs
                          Just ResultError
pgErr <- forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast e
e)
                          case ResultError
pgErr of
                            Pg.ConversionFailed { errSQLType :: ResultError -> String
Pg.errSQLType = String
sql
                                                , errHaskellType :: ResultError -> String
Pg.errHaskellType = String
hs
                                                , errMessage :: ResultError -> String
Pg.errMessage = String
msg } ->
                              forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> String -> String -> ColumnParseError
ColumnTypeMismatch String
hs String
sql String
msg)
                            Pg.Incompatible { errSQLType :: ResultError -> String
Pg.errSQLType = String
sql
                                            , errHaskellType :: ResultError -> String
Pg.errHaskellType = String
hs
                                            , errMessage :: ResultError -> String
Pg.errMessage = String
msg } ->
                              forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> String -> String -> ColumnParseError
ColumnTypeMismatch String
hs String
sql String
msg)
                            Pg.UnexpectedNull {} ->
                              forall (f :: * -> *) a. Applicative f => a -> f a
pure ColumnParseError
ColumnUnexpectedNull
             in forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> Either a b
Left (Maybe Int -> ColumnParseError -> BeamRowReadError
BeamRowReadError (forall a. a -> Maybe a
Just (forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
curCol)) ColumnParseError
err))
           Pg.Ok a
x -> a -> CInt -> CInt -> [Field] -> IO (Either BeamRowReadError x)
next' a
x (CInt
curCol forall a. Num a => a -> a -> a
+ CInt
1) CInt
colCount [Field]
remainingFields

    step (Alt (FromBackendRowM F (FromBackendRowF Postgres) a
a) (FromBackendRowM F (FromBackendRowF Postgres) a
b) a -> CInt -> CInt -> [Field] -> IO (Either BeamRowReadError x)
next) CInt
curCol CInt
colCount [Field]
cols =
      do Either BeamRowReadError (IO (Either BeamRowReadError x))
aRes <- forall (f :: * -> *) a.
F f a -> forall r. (a -> r) -> (f r -> r) -> r
runF F (FromBackendRowF Postgres) a
a (\a
x CInt
curCol' CInt
colCount' [Field]
cols' -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. b -> Either a b
Right (a -> CInt -> CInt -> [Field] -> IO (Either BeamRowReadError x)
next a
x CInt
curCol' CInt
colCount' [Field]
cols'))) forall x.
FromBackendRowF
  Postgres
  (CInt -> CInt -> [Field] -> IO (Either BeamRowReadError x))
-> CInt -> CInt -> [Field] -> IO (Either BeamRowReadError x)
step CInt
curCol CInt
colCount [Field]
cols
         case Either BeamRowReadError (IO (Either BeamRowReadError x))
aRes of
           Right IO (Either BeamRowReadError x)
next' -> IO (Either BeamRowReadError x)
next'
           Left BeamRowReadError
aErr -> do
             Either BeamRowReadError (IO (Either BeamRowReadError x))
bRes <- forall (f :: * -> *) a.
F f a -> forall r. (a -> r) -> (f r -> r) -> r
runF F (FromBackendRowF Postgres) a
b (\a
x CInt
curCol' CInt
colCount' [Field]
cols' -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. b -> Either a b
Right (a -> CInt -> CInt -> [Field] -> IO (Either BeamRowReadError x)
next a
x CInt
curCol' CInt
colCount' [Field]
cols'))) forall x.
FromBackendRowF
  Postgres
  (CInt -> CInt -> [Field] -> IO (Either BeamRowReadError x))
-> CInt -> CInt -> [Field] -> IO (Either BeamRowReadError x)
step CInt
curCol CInt
colCount [Field]
cols
             case Either BeamRowReadError (IO (Either BeamRowReadError x))
bRes of
               Right IO (Either BeamRowReadError x)
next' -> IO (Either BeamRowReadError x)
next'
               Left {} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> Either a b
Left BeamRowReadError
aErr)

    step (FailParseWith BeamRowReadError
err) CInt
_ CInt
_ [Field]
_ =
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> Either a b
Left BeamRowReadError
err)

    finish :: b -> p -> p -> p -> f (Either a b)
finish b
x p
_ p
_ p
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. b -> Either a b
Right b
x)

withPgDebug :: (String -> IO ()) -> Pg.Connection -> Pg a -> IO (Either BeamRowReadError a)
withPgDebug :: forall a.
(String -> IO ())
-> Connection -> Pg a -> IO (Either BeamRowReadError a)
withPgDebug String -> IO ()
dbg Connection
conn (Pg F PgF a
action) =
  let finish :: b -> f (Either a b)
finish b
x = forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. b -> Either a b
Right b
x)
      step :: PgF (IO (Either BeamRowReadError a))
-> IO (Either BeamRowReadError a)
step (PgLiftIO IO a
io a -> IO (Either BeamRowReadError a)
next) = IO a
io forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> IO (Either BeamRowReadError a)
next
      step (PgLiftWithHandle (String -> IO ()) -> Connection -> IO a
withConn a -> IO (Either BeamRowReadError a)
next) = (String -> IO ()) -> Connection -> IO a
withConn String -> IO ()
dbg Connection
conn forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> IO (Either BeamRowReadError a)
next
      step (PgFetchNext Maybe x -> IO (Either BeamRowReadError a)
next) = Maybe x -> IO (Either BeamRowReadError a)
next forall a. Maybe a
Nothing
      step (PgRunReturning FetchMode
CursorBatching
                           (PgCommandSyntax PgCommandType
PgCommandTypeQuery PgSyntax
syntax)
                           (Pg (Maybe x) -> Pg a
mkProcess :: Pg (Maybe x) -> Pg a')
                           a -> IO (Either BeamRowReadError a)
next) =
        do ByteString
query <- Connection -> PgSyntax -> IO ByteString
pgRenderSyntax Connection
conn PgSyntax
syntax
           let Pg F PgF a
process = Pg (Maybe x) -> Pg a
mkProcess (forall a. F PgF a -> Pg a
Pg (forall (f :: * -> *) (m :: * -> *) a.
(Functor f, MonadFree f m) =>
f a -> m a
liftF (forall a next.
FromBackendRow Postgres a =>
(Maybe a -> next) -> PgF next
PgFetchNext forall a. a -> a
id)))
           String -> IO ()
dbg (Text -> String
T.unpack (ByteString -> Text
decodeUtf8 ByteString
query))
           PgStream a
action' <- forall (f :: * -> *) a.
F f a -> forall r. (a -> r) -> (f r -> r) -> r
runF F PgF a
process forall a. a -> Maybe Row -> IO (PgStream a)
finishProcess forall a.
PgF (Maybe Row -> IO (PgStream a)) -> Maybe Row -> IO (PgStream a)
stepProcess forall a. Maybe a
Nothing
           case PgStream a
action' of
             PgStreamDone (Right a
x) -> Connection -> Query -> IO Int64
Pg.execute_ Connection
conn (ByteString -> Query
Pg.Query ByteString
query) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> IO (Either BeamRowReadError a)
next a
x
             PgStreamDone (Left BeamRowReadError
err) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> Either a b
Left BeamRowReadError
err)
             PgStreamContinue Maybe Row -> IO (PgStream a)
nextStream ->
               let finishUp :: PgStream a -> IO (Either BeamRowReadError a)
finishUp (PgStreamDone (Right a
x)) = a -> IO (Either BeamRowReadError a)
next a
x
                   finishUp (PgStreamDone (Left BeamRowReadError
err)) = forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> Either a b
Left BeamRowReadError
err)
                   finishUp (PgStreamContinue Maybe Row -> IO (PgStream a)
next') = Maybe Row -> IO (PgStream a)
next' forall a. Maybe a
Nothing forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= PgStream a -> IO (Either BeamRowReadError a)
finishUp

                   columnCount :: Column
columnCount = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall be a. FromBackendRow be a => Proxy be -> Proxy a -> Int
valuesNeeded (forall {k} (t :: k). Proxy t
Proxy @Postgres) (forall {k} (t :: k). Proxy t
Proxy @x)
               in forall r a.
RowParser r -> Connection -> Query -> a -> (a -> r -> IO a) -> IO a
Pg.foldWith_ (forall a. ReaderT Row (StateT Column Conversion) a -> RowParser a
Pg.RP (forall s (m :: * -> *). MonadState s m => s -> m ()
put Column
columnCount forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall r (m :: * -> *). MonadReader r m => m r
ask)) Connection
conn (ByteString -> Query
Pg.Query ByteString
query) (forall a. (Maybe Row -> IO (PgStream a)) -> PgStream a
PgStreamContinue Maybe Row -> IO (PgStream a)
nextStream) forall a. PgStream a -> Row -> IO (PgStream a)
runConsumer forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= PgStream a -> IO (Either BeamRowReadError a)
finishUp
      step (PgRunReturning FetchMode
AtOnce
                           (PgCommandSyntax PgCommandType
PgCommandTypeQuery PgSyntax
syntax)
                           (Pg (Maybe x) -> Pg a
mkProcess :: Pg (Maybe x) -> Pg a')
                           a -> IO (Either BeamRowReadError a)
next) =
        forall x a' {a}.
FromBackendRow Postgres x =>
ByteString
-> PgSyntax
-> (Pg (Maybe x) -> Pg a')
-> (a' -> IO (Either BeamRowReadError a))
-> IO (Either BeamRowReadError a)
renderExecReturningList ByteString
"No tuples returned to Postgres query" PgSyntax
syntax Pg (Maybe x) -> Pg a
mkProcess a -> IO (Either BeamRowReadError a)
next
      step (PgRunReturning FetchMode
_ (PgCommandSyntax PgCommandType
PgCommandTypeDataUpdateReturning PgSyntax
syntax) Pg (Maybe x) -> Pg a
mkProcess a -> IO (Either BeamRowReadError a)
next) =
        forall x a' {a}.
FromBackendRow Postgres x =>
ByteString
-> PgSyntax
-> (Pg (Maybe x) -> Pg a')
-> (a' -> IO (Either BeamRowReadError a))
-> IO (Either BeamRowReadError a)
renderExecReturningList ByteString
"No tuples returned to Postgres update/insert returning" PgSyntax
syntax Pg (Maybe x) -> Pg a
mkProcess a -> IO (Either BeamRowReadError a)
next
      step (PgRunReturning FetchMode
_ (PgCommandSyntax PgCommandType
_ PgSyntax
syntax) Pg (Maybe x) -> Pg a
mkProcess a -> IO (Either BeamRowReadError a)
next) =
        do ByteString
query <- Connection -> PgSyntax -> IO ByteString
pgRenderSyntax Connection
conn PgSyntax
syntax
           String -> IO ()
dbg (Text -> String
T.unpack (ByteString -> Text
decodeUtf8 ByteString
query))
           Int64
_ <- Connection -> Query -> IO Int64
Pg.execute_ Connection
conn (ByteString -> Query
Pg.Query ByteString
query)

           let Pg F PgF a
process = Pg (Maybe x) -> Pg a
mkProcess (forall a. F PgF a -> Pg a
Pg (forall (f :: * -> *) (m :: * -> *) a.
(Functor f, MonadFree f m) =>
f a -> m a
liftF (forall a next.
FromBackendRow Postgres a =>
(Maybe a -> next) -> PgF next
PgFetchNext forall a. a -> a
id)))
           forall (f :: * -> *) a.
F f a -> forall r. (a -> r) -> (f r -> r) -> r
runF F PgF a
process a -> IO (Either BeamRowReadError a)
next forall a.
PgF (IO (Either BeamRowReadError a))
-> IO (Either BeamRowReadError a)
stepReturningNone

      renderExecReturningList :: (FromBackendRow Postgres x) => _ -> PgSyntax -> (Pg (Maybe x) -> Pg a') -> _ -> _
      renderExecReturningList :: ByteString
-> PgSyntax
-> (Pg (Maybe x) -> Pg a')
-> (a' -> IO (Either BeamRowReadError a))
-> IO (Either BeamRowReadError a)
renderExecReturningList ByteString
errMsg PgSyntax
syntax Pg (Maybe x) -> Pg a'
mkProcess a' -> IO (Either BeamRowReadError a)
next =
        do ByteString
query <- Connection -> PgSyntax -> IO ByteString
pgRenderSyntax Connection
conn PgSyntax
syntax
           String -> IO ()
dbg (Text -> String
T.unpack (ByteString -> Text
decodeUtf8 ByteString
query))

           Result
res <- Connection -> ByteString -> IO Result
Pg.exec Connection
conn ByteString
query
           ExecStatus
sts <- Result -> IO ExecStatus
Pg.resultStatus Result
res
           case ExecStatus
sts of
             ExecStatus
Pg.TuplesOk -> do
               let Pg F PgF a'
process = Pg (Maybe x) -> Pg a'
mkProcess (forall a. F PgF a -> Pg a
Pg (forall (f :: * -> *) (m :: * -> *) a.
(Functor f, MonadFree f m) =>
f a -> m a
liftF (forall a next.
FromBackendRow Postgres a =>
(Maybe a -> next) -> PgF next
PgFetchNext forall a. a -> a
id)))
               forall (f :: * -> *) a.
F f a -> forall r. (a -> r) -> (f r -> r) -> r
runF F PgF a'
process (\a'
x CInt
_ -> Result -> IO ()
Pg.unsafeFreeResult Result
res forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a' -> IO (Either BeamRowReadError a)
next a'
x) (forall a.
Result
-> PgF (CInt -> IO (Either BeamRowReadError a))
-> CInt
-> IO (Either BeamRowReadError a)
stepReturningList Result
res) CInt
0
             ExecStatus
_ -> forall a. ByteString -> Result -> ExecStatus -> IO a
Pg.throwResultError ByteString
errMsg Result
res ExecStatus
sts

      stepReturningNone :: forall a. PgF (IO (Either BeamRowReadError a)) -> IO (Either BeamRowReadError a)
      stepReturningNone :: forall a.
PgF (IO (Either BeamRowReadError a))
-> IO (Either BeamRowReadError a)
stepReturningNone (PgLiftIO IO a
action' a -> IO (Either BeamRowReadError a)
next) = IO a
action' forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> IO (Either BeamRowReadError a)
next
      stepReturningNone (PgLiftWithHandle (String -> IO ()) -> Connection -> IO a
withConn a -> IO (Either BeamRowReadError a)
next) = (String -> IO ()) -> Connection -> IO a
withConn String -> IO ()
dbg Connection
conn forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> IO (Either BeamRowReadError a)
next
      stepReturningNone (PgFetchNext Maybe x -> IO (Either BeamRowReadError a)
next) = Maybe x -> IO (Either BeamRowReadError a)
next forall a. Maybe a
Nothing
      stepReturningNone (PgRunReturning {}) = forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> Either a b
Left (Maybe Int -> ColumnParseError -> BeamRowReadError
BeamRowReadError forall a. Maybe a
Nothing (String -> ColumnParseError
ColumnErrorInternal  String
"Nested queries not allowed")))

      stepReturningList :: forall a. Pg.Result -> PgF (CInt -> IO (Either BeamRowReadError a)) -> CInt -> IO (Either BeamRowReadError a)
      stepReturningList :: forall a.
Result
-> PgF (CInt -> IO (Either BeamRowReadError a))
-> CInt
-> IO (Either BeamRowReadError a)
stepReturningList Result
_   (PgLiftIO IO a
action' a -> CInt -> IO (Either BeamRowReadError a)
next) CInt
rowIdx = IO a
action' forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
x -> a -> CInt -> IO (Either BeamRowReadError a)
next a
x CInt
rowIdx
      stepReturningList Result
res (PgFetchNext Maybe x -> CInt -> IO (Either BeamRowReadError a)
next) CInt
rowIdx =
        do [Field]
fields <- Result -> IO [Field]
getFields Result
res
           Pg.Row CInt
rowCount <- Result -> IO Row
Pg.ntuples Result
res
           if CInt
rowIdx forall a. Ord a => a -> a -> Bool
>= CInt
rowCount
             then Maybe x -> CInt -> IO (Either BeamRowReadError a)
next forall a. Maybe a
Nothing CInt
rowIdx
             else forall a.
Connection
-> Row
-> Result
-> [Field]
-> FromBackendRowM Postgres a
-> IO (Either BeamRowReadError a)
runPgRowReader Connection
conn (CInt -> Row
Pg.Row CInt
rowIdx) Result
res [Field]
fields forall be a. FromBackendRow be a => FromBackendRowM be a
fromBackendRow forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                    Left BeamRowReadError
err -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> Either a b
Left BeamRowReadError
err)
                    Right x
r -> Maybe x -> CInt -> IO (Either BeamRowReadError a)
next (forall a. a -> Maybe a
Just x
r) (CInt
rowIdx forall a. Num a => a -> a -> a
+ CInt
1)
      stepReturningList Result
_   (PgRunReturning {}) CInt
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> Either a b
Left (Maybe Int -> ColumnParseError -> BeamRowReadError
BeamRowReadError forall a. Maybe a
Nothing (String -> ColumnParseError
ColumnErrorInternal String
"Nested queries not allowed")))
      stepReturningList Result
_   (PgLiftWithHandle {}) CInt
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> Either a b
Left (Maybe Int -> ColumnParseError -> BeamRowReadError
BeamRowReadError forall a. Maybe a
Nothing (String -> ColumnParseError
ColumnErrorInternal String
"Nested queries not allowed")))

      finishProcess :: forall a. a -> Maybe PgI.Row -> IO (PgStream a)
      finishProcess :: forall a. a -> Maybe Row -> IO (PgStream a)
finishProcess a
x Maybe Row
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Either BeamRowReadError a -> PgStream a
PgStreamDone (forall a b. b -> Either a b
Right a
x))

      stepProcess :: forall a. PgF (Maybe PgI.Row -> IO (PgStream a)) -> Maybe PgI.Row -> IO (PgStream a)
      stepProcess :: forall a.
PgF (Maybe Row -> IO (PgStream a)) -> Maybe Row -> IO (PgStream a)
stepProcess (PgLiftIO IO a
action' a -> Maybe Row -> IO (PgStream a)
next) Maybe Row
row = IO a
action' forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a b c. (a -> b -> c) -> b -> a -> c
flip a -> Maybe Row -> IO (PgStream a)
next Maybe Row
row
      stepProcess (PgFetchNext Maybe x -> Maybe Row -> IO (PgStream a)
next) Maybe Row
Nothing =
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (Maybe Row -> IO (PgStream a)) -> PgStream a
PgStreamContinue forall a b. (a -> b) -> a -> b
$ \Maybe Row
res ->
        case Maybe Row
res of
          Maybe Row
Nothing -> Maybe x -> Maybe Row -> IO (PgStream a)
next forall a. Maybe a
Nothing forall a. Maybe a
Nothing
          Just (PgI.Row Row
rowIdx Result
res') ->
            Result -> IO [Field]
getFields Result
res' forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \[Field]
fields ->
            forall a.
Connection
-> Row
-> Result
-> [Field]
-> FromBackendRowM Postgres a
-> IO (Either BeamRowReadError a)
runPgRowReader Connection
conn Row
rowIdx Result
res' [Field]
fields forall be a. FromBackendRow be a => FromBackendRowM be a
fromBackendRow forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              Left BeamRowReadError
err -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Either BeamRowReadError a -> PgStream a
PgStreamDone (forall a b. a -> Either a b
Left BeamRowReadError
err))
              Right x
r -> Maybe x -> Maybe Row -> IO (PgStream a)
next (forall a. a -> Maybe a
Just x
r) forall a. Maybe a
Nothing
      stepProcess (PgFetchNext Maybe x -> Maybe Row -> IO (PgStream a)
next) (Just (PgI.Row Row
rowIdx Result
res)) =
        Result -> IO [Field]
getFields Result
res forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \[Field]
fields ->
        forall a.
Connection
-> Row
-> Result
-> [Field]
-> FromBackendRowM Postgres a
-> IO (Either BeamRowReadError a)
runPgRowReader Connection
conn Row
rowIdx Result
res [Field]
fields forall be a. FromBackendRow be a => FromBackendRowM be a
fromBackendRow forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Left BeamRowReadError
err -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Either BeamRowReadError a -> PgStream a
PgStreamDone (forall a b. a -> Either a b
Left BeamRowReadError
err))
          Right x
r -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. (Maybe Row -> IO (PgStream a)) -> PgStream a
PgStreamContinue (Maybe x -> Maybe Row -> IO (PgStream a)
next (forall a. a -> Maybe a
Just x
r)))
      stepProcess (PgRunReturning {}) Maybe Row
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Either BeamRowReadError a -> PgStream a
PgStreamDone (forall a b. a -> Either a b
Left (Maybe Int -> ColumnParseError -> BeamRowReadError
BeamRowReadError forall a. Maybe a
Nothing (String -> ColumnParseError
ColumnErrorInternal String
"Nested queries not allowed"))))
      stepProcess (PgLiftWithHandle (String -> IO ()) -> Connection -> IO a
_ a -> Maybe Row -> IO (PgStream a)
_) Maybe Row
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Either BeamRowReadError a -> PgStream a
PgStreamDone (forall a b. a -> Either a b
Left (Maybe Int -> ColumnParseError -> BeamRowReadError
BeamRowReadError forall a. Maybe a
Nothing (String -> ColumnParseError
ColumnErrorInternal String
"Nested queries not allowed"))))

      runConsumer :: forall a. PgStream a -> PgI.Row -> IO (PgStream a)
      runConsumer :: forall a. PgStream a -> Row -> IO (PgStream a)
runConsumer s :: PgStream a
s@(PgStreamDone {}) Row
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure PgStream a
s
      runConsumer (PgStreamContinue Maybe Row -> IO (PgStream a)
next) Row
row = Maybe Row -> IO (PgStream a)
next (forall a. a -> Maybe a
Just Row
row)
  in forall (f :: * -> *) a.
F f a -> forall r. (a -> r) -> (f r -> r) -> r
runF F PgF a
action forall {f :: * -> *} {b} {a}. Applicative f => b -> f (Either a b)
finish PgF (IO (Either BeamRowReadError a))
-> IO (Either BeamRowReadError a)
step

-- * Beam Monad class

data PgF next where
    PgLiftIO :: IO a -> (a -> next) -> PgF next
    PgRunReturning ::
        FromBackendRow Postgres x =>
        FetchMode -> PgCommandSyntax -> (Pg (Maybe x) -> Pg a) -> (a -> next) -> PgF next
    PgFetchNext ::
        FromBackendRow Postgres x =>
        (Maybe x -> next) -> PgF next
    PgLiftWithHandle :: ((String -> IO ()) -> Pg.Connection -> IO a) -> (a -> next) -> PgF next
instance Functor PgF where
  fmap :: forall a b. (a -> b) -> PgF a -> PgF b
fmap a -> b
f = \case
    PgLiftIO IO a
io a -> a
n -> forall a next. IO a -> (a -> next) -> PgF next
PgLiftIO IO a
io forall a b. (a -> b) -> a -> b
$ a -> b
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a
n
    PgRunReturning FetchMode
mode PgCommandSyntax
cmd Pg (Maybe x) -> Pg a
consume a -> a
n -> forall a a next.
FromBackendRow Postgres a =>
FetchMode
-> PgCommandSyntax
-> (Pg (Maybe a) -> Pg a)
-> (a -> next)
-> PgF next
PgRunReturning FetchMode
mode PgCommandSyntax
cmd Pg (Maybe x) -> Pg a
consume forall a b. (a -> b) -> a -> b
$ a -> b
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a
n
    PgFetchNext Maybe x -> a
n -> forall a next.
FromBackendRow Postgres a =>
(Maybe a -> next) -> PgF next
PgFetchNext forall a b. (a -> b) -> a -> b
$ a -> b
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe x -> a
n
    PgLiftWithHandle (String -> IO ()) -> Connection -> IO a
withConn a -> a
n -> forall a next.
((String -> IO ()) -> Connection -> IO a)
-> (a -> next) -> PgF next
PgLiftWithHandle (String -> IO ()) -> Connection -> IO a
withConn forall a b. (a -> b) -> a -> b
$ a -> b
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a
n

-- | How to fetch results.
data FetchMode
    = CursorBatching -- ^ Fetch in batches of ~256 rows via cursor for SELECT.
    | AtOnce         -- ^ Fetch all rows at once.

-- | 'MonadBeam' in which we can run Postgres commands. See the documentation
-- for 'MonadBeam' on examples of how to use.
--
-- @beam-postgres@ also provides functions that let you run queries without
-- 'MonadBeam'. These functions may be more efficient and offer a conduit
-- API. See "Database.Beam.Postgres.Conduit" for more information.
newtype Pg a = Pg { forall a. Pg a -> F PgF a
runPg :: F PgF a }
    deriving (Applicative Pg
forall a. a -> Pg a
forall a b. Pg a -> Pg b -> Pg b
forall a b. Pg a -> (a -> Pg b) -> Pg 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 :: forall a. a -> Pg a
$creturn :: forall a. a -> Pg a
>> :: forall a b. Pg a -> Pg b -> Pg b
$c>> :: forall a b. Pg a -> Pg b -> Pg b
>>= :: forall a b. Pg a -> (a -> Pg b) -> Pg b
$c>>= :: forall a b. Pg a -> (a -> Pg b) -> Pg b
Monad, Functor Pg
forall a. a -> Pg a
forall a b. Pg a -> Pg b -> Pg a
forall a b. Pg a -> Pg b -> Pg b
forall a b. Pg (a -> b) -> Pg a -> Pg b
forall a b c. (a -> b -> c) -> Pg a -> Pg b -> Pg 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 a b. Pg a -> Pg b -> Pg a
$c<* :: forall a b. Pg a -> Pg b -> Pg a
*> :: forall a b. Pg a -> Pg b -> Pg b
$c*> :: forall a b. Pg a -> Pg b -> Pg b
liftA2 :: forall a b c. (a -> b -> c) -> Pg a -> Pg b -> Pg c
$cliftA2 :: forall a b c. (a -> b -> c) -> Pg a -> Pg b -> Pg c
<*> :: forall a b. Pg (a -> b) -> Pg a -> Pg b
$c<*> :: forall a b. Pg (a -> b) -> Pg a -> Pg b
pure :: forall a. a -> Pg a
$cpure :: forall a. a -> Pg a
Applicative, forall a b. a -> Pg b -> Pg a
forall a b. (a -> b) -> Pg a -> Pg b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Pg b -> Pg a
$c<$ :: forall a b. a -> Pg b -> Pg a
fmap :: forall a b. (a -> b) -> Pg a -> Pg b
$cfmap :: forall a b. (a -> b) -> Pg a -> Pg b
Functor, MonadFree PgF)

instance Fail.MonadFail Pg where
    fail :: forall a. String -> Pg a
fail String
e =  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail forall a b. (a -> b) -> a -> b
$ String
"Internal Error with: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show String
e)

instance MonadIO Pg where
    liftIO :: forall a. IO a -> Pg a
liftIO IO a
x = forall (f :: * -> *) (m :: * -> *) a.
(Functor f, MonadFree f m) =>
f a -> m a
liftF (forall a next. IO a -> (a -> next) -> PgF next
PgLiftIO IO a
x forall a. a -> a
id)

instance MonadBase IO Pg where
    liftBase :: forall a. IO a -> Pg a
liftBase = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO

instance MonadBaseControl IO Pg where
    type StM Pg a = a

    liftBaseWith :: forall a. (RunInBase Pg IO -> IO a) -> Pg a
liftBaseWith RunInBase Pg IO -> IO a
action =
      forall (f :: * -> *) (m :: * -> *) a.
(Functor f, MonadFree f m) =>
f a -> m a
liftF (forall a next.
((String -> IO ()) -> Connection -> IO a)
-> (a -> next) -> PgF next
PgLiftWithHandle (\String -> IO ()
dbg Connection
conn -> RunInBase Pg IO -> IO a
action (forall a. (String -> IO ()) -> Connection -> Pg a -> IO a
runBeamPostgresDebug String -> IO ()
dbg Connection
conn)) forall a. a -> a
id)

    restoreM :: forall a. StM Pg a -> Pg a
restoreM = forall (f :: * -> *) a. Applicative f => a -> f a
pure

liftIOWithHandle :: (Pg.Connection -> IO a) -> Pg a
liftIOWithHandle :: forall a. (Connection -> IO a) -> Pg a
liftIOWithHandle Connection -> IO a
f = forall (f :: * -> *) (m :: * -> *) a.
(Functor f, MonadFree f m) =>
f a -> m a
liftF (forall a next.
((String -> IO ()) -> Connection -> IO a)
-> (a -> next) -> PgF next
PgLiftWithHandle (\String -> IO ()
_ -> Connection -> IO a
f) forall a. a -> a
id)

runBeamPostgresDebug :: (String -> IO ()) -> Pg.Connection -> Pg a -> IO a
runBeamPostgresDebug :: forall a. (String -> IO ()) -> Connection -> Pg a -> IO a
runBeamPostgresDebug String -> IO ()
dbg Connection
conn Pg a
action =
    forall a.
(String -> IO ())
-> Connection -> Pg a -> IO (Either BeamRowReadError a)
withPgDebug String -> IO ()
dbg Connection
conn Pg a
action forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall e a. Exception e => e -> IO a
throwIO forall (f :: * -> *) a. Applicative f => a -> f a
pure

runBeamPostgres :: Pg.Connection -> Pg a -> IO a
runBeamPostgres :: forall a. Connection -> Pg a -> IO a
runBeamPostgres = forall a. (String -> IO ()) -> Connection -> Pg a -> IO a
runBeamPostgresDebug (\String
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

instance MonadBeam Postgres Pg where
    runReturningMany :: forall x a.
FromBackendRow Postgres x =>
BeamSqlBackendSyntax Postgres -> (Pg (Maybe x) -> Pg a) -> Pg a
runReturningMany BeamSqlBackendSyntax Postgres
cmd Pg (Maybe x) -> Pg a
consume =
        forall (f :: * -> *) (m :: * -> *) a.
(Functor f, MonadFree f m) =>
f a -> m a
liftF (forall a a next.
FromBackendRow Postgres a =>
FetchMode
-> PgCommandSyntax
-> (Pg (Maybe a) -> Pg a)
-> (a -> next)
-> PgF next
PgRunReturning FetchMode
CursorBatching BeamSqlBackendSyntax Postgres
cmd Pg (Maybe x) -> Pg a
consume forall a. a -> a
id)

    runReturningOne :: forall x.
FromBackendRow Postgres x =>
BeamSqlBackendSyntax Postgres -> Pg (Maybe x)
runReturningOne BeamSqlBackendSyntax Postgres
cmd =
        forall (f :: * -> *) (m :: * -> *) a.
(Functor f, MonadFree f m) =>
f a -> m a
liftF (forall a a next.
FromBackendRow Postgres a =>
FetchMode
-> PgCommandSyntax
-> (Pg (Maybe a) -> Pg a)
-> (a -> next)
-> PgF next
PgRunReturning FetchMode
AtOnce BeamSqlBackendSyntax Postgres
cmd forall {m :: * -> *} {a}. Monad m => m (Maybe a) -> m (Maybe a)
consume forall a. a -> a
id)
      where
        consume :: m (Maybe a) -> m (Maybe a)
consume m (Maybe a)
next = do
          Maybe a
a <- m (Maybe a)
next
          case Maybe a
a of
            Maybe a
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
            Just a
x -> do
              Maybe a
a' <- m (Maybe a)
next
              case Maybe a
a' of
                Maybe a
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just a
x)
                Just a
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing

    runReturningFirst :: forall x.
FromBackendRow Postgres x =>
BeamSqlBackendSyntax Postgres -> Pg (Maybe x)
runReturningFirst BeamSqlBackendSyntax Postgres
cmd =
        forall (f :: * -> *) (m :: * -> *) a.
(Functor f, MonadFree f m) =>
f a -> m a
liftF (forall a a next.
FromBackendRow Postgres a =>
FetchMode
-> PgCommandSyntax
-> (Pg (Maybe a) -> Pg a)
-> (a -> next)
-> PgF next
PgRunReturning FetchMode
AtOnce BeamSqlBackendSyntax Postgres
cmd forall a. a -> a
id forall a. a -> a
id)

    runReturningList :: forall x.
FromBackendRow Postgres x =>
BeamSqlBackendSyntax Postgres -> Pg [x]
runReturningList BeamSqlBackendSyntax Postgres
cmd =
        forall (f :: * -> *) (m :: * -> *) a.
(Functor f, MonadFree f m) =>
f a -> m a
liftF (forall a a next.
FromBackendRow Postgres a =>
FetchMode
-> PgCommandSyntax
-> (Pg (Maybe a) -> Pg a)
-> (a -> next)
-> PgF next
PgRunReturning FetchMode
AtOnce BeamSqlBackendSyntax Postgres
cmd forall {m :: * -> *} {a}. Monad m => m (Maybe a) -> m [a]
consume forall a. a -> a
id)
      where
        consume :: m (Maybe a) -> m [a]
consume m (Maybe a)
next =
          let collectM :: ([a] -> [a]) -> m [a]
collectM [a] -> [a]
acc = do
                Maybe a
a <- m (Maybe a)
next
                case Maybe a
a of
                  Maybe a
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ([a] -> [a]
acc [])
                  Just a
x -> ([a] -> [a]) -> m [a]
collectM ([a] -> [a]
acc forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a
xforall a. a -> [a] -> [a]
:))
          in ([a] -> [a]) -> m [a]
collectM forall a. a -> a
id

instance MonadBeamInsertReturning Postgres Pg where
    runInsertReturningList :: forall (table :: (* -> *) -> *).
(Beamable table, Projectible Postgres (table (QExpr Postgres ())),
 FromBackendRow Postgres (table Identity)) =>
SqlInsert Postgres table -> Pg [table Identity]
runInsertReturningList SqlInsert Postgres table
i = do
        let insertReturningCmd' :: PgReturningType
  SqlInsert (QExprToIdentity (table (QExpr Postgres ())))
insertReturningCmd' = SqlInsert Postgres table
i forall (cmd :: * -> ((* -> *) -> *) -> *) (tbl :: (* -> *) -> *) a.
(PgReturning cmd, Beamable tbl, Projectible Postgres a) =>
cmd Postgres tbl
-> (tbl (QExpr Postgres PostgresInaccessible) -> a)
-> PgReturningType cmd (QExprToIdentity a)
`returning`
              forall (table :: (* -> *) -> *) (f :: * -> *) (g :: * -> *).
Beamable table =>
(forall a. Columnar' f a -> Columnar' g a) -> table f -> table g
changeBeamRep (\(Columnar' (QExpr Text -> BeamSqlBackendExpressionSyntax Postgres
s) :: Columnar' (QExpr Postgres PostgresInaccessible) ty) ->
                forall (f :: * -> *) a. Columnar f a -> Columnar' f a
Columnar' (forall context be s t.
(Text -> BeamSqlBackendExpressionSyntax be)
-> QGenExpr context be s t
QExpr Text -> BeamSqlBackendExpressionSyntax Postgres
s) :: Columnar' (QExpr Postgres ()) ty)

        -- Make savepoint
        case PgReturningType
  SqlInsert (QExprToIdentity (table (QExpr Postgres ())))
insertReturningCmd' of
          PgReturningType
  SqlInsert (QExprToIdentity (table (QExpr Postgres ())))
PgInsertReturning (QExprToIdentity (table (QExpr Postgres ())))
PgInsertReturningEmpty ->
            forall (f :: * -> *) a. Applicative f => a -> f a
pure []
          PgInsertReturning PgSyntax
insertReturningCmd ->
            forall be (m :: * -> *) x.
(MonadBeam be m, FromBackendRow be x) =>
BeamSqlBackendSyntax be -> m [x]
runReturningList (PgCommandType -> PgSyntax -> PgCommandSyntax
PgCommandSyntax PgCommandType
PgCommandTypeDataUpdateReturning PgSyntax
insertReturningCmd)

instance MonadBeamUpdateReturning Postgres Pg where
    runUpdateReturningList :: forall (table :: (* -> *) -> *).
(Beamable table, Projectible Postgres (table (QExpr Postgres ())),
 FromBackendRow Postgres (table Identity)) =>
SqlUpdate Postgres table -> Pg [table Identity]
runUpdateReturningList SqlUpdate Postgres table
u = do
        let updateReturningCmd' :: PgReturningType
  SqlUpdate (QExprToIdentity (table (QExpr Postgres ())))
updateReturningCmd' = SqlUpdate Postgres table
u forall (cmd :: * -> ((* -> *) -> *) -> *) (tbl :: (* -> *) -> *) a.
(PgReturning cmd, Beamable tbl, Projectible Postgres a) =>
cmd Postgres tbl
-> (tbl (QExpr Postgres PostgresInaccessible) -> a)
-> PgReturningType cmd (QExprToIdentity a)
`returning`
              forall (table :: (* -> *) -> *) (f :: * -> *) (g :: * -> *).
Beamable table =>
(forall a. Columnar' f a -> Columnar' g a) -> table f -> table g
changeBeamRep (\(Columnar' (QExpr Text -> BeamSqlBackendExpressionSyntax Postgres
s) :: Columnar' (QExpr Postgres PostgresInaccessible) ty) ->
                forall (f :: * -> *) a. Columnar f a -> Columnar' f a
Columnar' (forall context be s t.
(Text -> BeamSqlBackendExpressionSyntax be)
-> QGenExpr context be s t
QExpr Text -> BeamSqlBackendExpressionSyntax Postgres
s) :: Columnar' (QExpr Postgres ()) ty)

        case PgReturningType
  SqlUpdate (QExprToIdentity (table (QExpr Postgres ())))
updateReturningCmd' of
          PgReturningType
  SqlUpdate (QExprToIdentity (table (QExpr Postgres ())))
PgUpdateReturning (QExprToIdentity (table (QExpr Postgres ())))
PgUpdateReturningEmpty ->
            forall (f :: * -> *) a. Applicative f => a -> f a
pure []
          PgUpdateReturning PgSyntax
updateReturningCmd ->
            forall be (m :: * -> *) x.
(MonadBeam be m, FromBackendRow be x) =>
BeamSqlBackendSyntax be -> m [x]
runReturningList (PgCommandType -> PgSyntax -> PgCommandSyntax
PgCommandSyntax PgCommandType
PgCommandTypeDataUpdateReturning PgSyntax
updateReturningCmd)

instance MonadBeamDeleteReturning Postgres Pg where
    runDeleteReturningList :: forall (table :: (* -> *) -> *).
(Beamable table, Projectible Postgres (table (QExpr Postgres ())),
 FromBackendRow Postgres (table Identity)) =>
SqlDelete Postgres table -> Pg [table Identity]
runDeleteReturningList SqlDelete Postgres table
d = do
        let PgDeleteReturning PgSyntax
deleteReturningCmd = SqlDelete Postgres table
d forall (cmd :: * -> ((* -> *) -> *) -> *) (tbl :: (* -> *) -> *) a.
(PgReturning cmd, Beamable tbl, Projectible Postgres a) =>
cmd Postgres tbl
-> (tbl (QExpr Postgres PostgresInaccessible) -> a)
-> PgReturningType cmd (QExprToIdentity a)
`returning`
              forall (table :: (* -> *) -> *) (f :: * -> *) (g :: * -> *).
Beamable table =>
(forall a. Columnar' f a -> Columnar' g a) -> table f -> table g
changeBeamRep (\(Columnar' (QExpr Text -> BeamSqlBackendExpressionSyntax Postgres
s) :: Columnar' (QExpr Postgres PostgresInaccessible) ty) ->
                forall (f :: * -> *) a. Columnar f a -> Columnar' f a
Columnar' (forall context be s t.
(Text -> BeamSqlBackendExpressionSyntax be)
-> QGenExpr context be s t
QExpr Text -> BeamSqlBackendExpressionSyntax Postgres
s) :: Columnar' (QExpr Postgres ()) ty)

        forall be (m :: * -> *) x.
(MonadBeam be m, FromBackendRow be x) =>
BeamSqlBackendSyntax be -> m [x]
runReturningList (PgCommandType -> PgSyntax -> PgCommandSyntax
PgCommandSyntax PgCommandType
PgCommandTypeDataUpdateReturning PgSyntax
deleteReturningCmd)