{-# LANGUAGE TypeApplications #-}
module Database.PostgreSQL.PQTypes.Internal.QueryResult (
    QueryResult(..)
  , ntuples
  , nfields
  ) where

import Control.Monad
import Data.Foldable
import Foreign.C.Types
import Foreign.ForeignPtr
import Foreign.Marshal.Alloc
import Foreign.Ptr
import System.IO.Unsafe
import qualified Control.Exception as E

import Database.PostgreSQL.PQTypes.Format
import Database.PostgreSQL.PQTypes.FromRow
import Database.PostgreSQL.PQTypes.Internal.C.Interface
import Database.PostgreSQL.PQTypes.Internal.C.Types
import Database.PostgreSQL.PQTypes.Internal.Error
import Database.PostgreSQL.PQTypes.Internal.Exception
import Database.PostgreSQL.PQTypes.SQL.Class

-- | Representation of a query result. Provides 'Functor'
-- and 'Foldable' instances for data transformation and
-- extraction appropriately.
data QueryResult t = forall row. FromRow row => QueryResult
  { QueryResult t -> SomeSQL
qrSQL     :: !SomeSQL
  , QueryResult t -> ForeignPtr PGresult
qrResult  :: !(ForeignPtr PGresult)
  , ()
qrFromRow :: !(row -> t)
  }

instance Functor QueryResult where
  a -> b
f fmap :: (a -> b) -> QueryResult a -> QueryResult b
`fmap` QueryResult SomeSQL
ctx ForeignPtr PGresult
fres row -> a
g = SomeSQL -> ForeignPtr PGresult -> (row -> b) -> QueryResult b
forall t row.
FromRow row =>
SomeSQL -> ForeignPtr PGresult -> (row -> t) -> QueryResult t
QueryResult SomeSQL
ctx ForeignPtr PGresult
fres (a -> b
f (a -> b) -> (row -> a) -> row -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. row -> a
g)

instance Foldable QueryResult where
  foldr :: (a -> b -> b) -> b -> QueryResult a -> b
foldr  = Bool
-> (Ptr PGresult -> IO CInt)
-> (Ptr PGresult -> IO CInt)
-> (CInt -> CInt)
-> (a -> b -> b)
-> b
-> QueryResult a
-> b
forall t acc.
Bool
-> (Ptr PGresult -> IO CInt)
-> (Ptr PGresult -> IO CInt)
-> (CInt -> CInt)
-> (t -> acc -> acc)
-> acc
-> QueryResult t
-> acc
foldImpl Bool
False ((CInt -> CInt) -> IO CInt -> IO CInt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CInt -> CInt
forall a. Enum a => a -> a
pred (IO CInt -> IO CInt)
-> (Ptr PGresult -> IO CInt) -> Ptr PGresult -> IO CInt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr PGresult -> IO CInt
c_PQntuples) (IO CInt -> Ptr PGresult -> IO CInt
forall a b. a -> b -> a
const (IO CInt -> Ptr PGresult -> IO CInt)
-> (CInt -> IO CInt) -> CInt -> Ptr PGresult -> IO CInt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CInt -> IO CInt
forall (m :: * -> *) a. Monad m => a -> m a
return (CInt -> Ptr PGresult -> IO CInt)
-> CInt -> Ptr PGresult -> IO CInt
forall a b. (a -> b) -> a -> b
$ -CInt
1) CInt -> CInt
forall a. Enum a => a -> a
pred
  foldr' :: (a -> b -> b) -> b -> QueryResult a -> b
foldr' = Bool
-> (Ptr PGresult -> IO CInt)
-> (Ptr PGresult -> IO CInt)
-> (CInt -> CInt)
-> (a -> b -> b)
-> b
-> QueryResult a
-> b
forall t acc.
Bool
-> (Ptr PGresult -> IO CInt)
-> (Ptr PGresult -> IO CInt)
-> (CInt -> CInt)
-> (t -> acc -> acc)
-> acc
-> QueryResult t
-> acc
foldImpl Bool
True  ((CInt -> CInt) -> IO CInt -> IO CInt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CInt -> CInt
forall a. Enum a => a -> a
pred (IO CInt -> IO CInt)
-> (Ptr PGresult -> IO CInt) -> Ptr PGresult -> IO CInt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr PGresult -> IO CInt
c_PQntuples) (IO CInt -> Ptr PGresult -> IO CInt
forall a b. a -> b -> a
const (IO CInt -> Ptr PGresult -> IO CInt)
-> (CInt -> IO CInt) -> CInt -> Ptr PGresult -> IO CInt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CInt -> IO CInt
forall (m :: * -> *) a. Monad m => a -> m a
return (CInt -> Ptr PGresult -> IO CInt)
-> CInt -> Ptr PGresult -> IO CInt
forall a b. (a -> b) -> a -> b
$ -CInt
1) CInt -> CInt
forall a. Enum a => a -> a
pred

  foldl :: (b -> a -> b) -> b -> QueryResult a -> b
foldl  = Bool
-> (Ptr PGresult -> IO CInt)
-> (Ptr PGresult -> IO CInt)
-> (CInt -> CInt)
-> (a -> b -> b)
-> b
-> QueryResult a
-> b
forall t acc.
Bool
-> (Ptr PGresult -> IO CInt)
-> (Ptr PGresult -> IO CInt)
-> (CInt -> CInt)
-> (t -> acc -> acc)
-> acc
-> QueryResult t
-> acc
foldImpl Bool
False (IO CInt -> Ptr PGresult -> IO CInt
forall a b. a -> b -> a
const (IO CInt -> Ptr PGresult -> IO CInt)
-> IO CInt -> Ptr PGresult -> IO CInt
forall a b. (a -> b) -> a -> b
$ CInt -> IO CInt
forall (m :: * -> *) a. Monad m => a -> m a
return CInt
0) Ptr PGresult -> IO CInt
c_PQntuples CInt -> CInt
forall a. Enum a => a -> a
succ ((a -> b -> b) -> b -> QueryResult a -> b)
-> ((b -> a -> b) -> a -> b -> b)
-> (b -> a -> b)
-> b
-> QueryResult a
-> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b -> a -> b) -> a -> b -> b
forall a b c. (a -> b -> c) -> b -> a -> c
flip
  foldl' :: (b -> a -> b) -> b -> QueryResult a -> b
foldl' = Bool
-> (Ptr PGresult -> IO CInt)
-> (Ptr PGresult -> IO CInt)
-> (CInt -> CInt)
-> (a -> b -> b)
-> b
-> QueryResult a
-> b
forall t acc.
Bool
-> (Ptr PGresult -> IO CInt)
-> (Ptr PGresult -> IO CInt)
-> (CInt -> CInt)
-> (t -> acc -> acc)
-> acc
-> QueryResult t
-> acc
foldImpl Bool
True  (IO CInt -> Ptr PGresult -> IO CInt
forall a b. a -> b -> a
const (IO CInt -> Ptr PGresult -> IO CInt)
-> IO CInt -> Ptr PGresult -> IO CInt
forall a b. (a -> b) -> a -> b
$ CInt -> IO CInt
forall (m :: * -> *) a. Monad m => a -> m a
return CInt
0) Ptr PGresult -> IO CInt
c_PQntuples CInt -> CInt
forall a. Enum a => a -> a
succ ((a -> b -> b) -> b -> QueryResult a -> b)
-> ((b -> a -> b) -> a -> b -> b)
-> (b -> a -> b)
-> b
-> QueryResult a
-> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b -> a -> b) -> a -> b -> b
forall a b c. (a -> b -> c) -> b -> a -> c
flip

foldImpl :: Bool
         -> (Ptr PGresult -> IO CInt)
         -> (Ptr PGresult -> IO CInt)
         -> (CInt -> CInt)
         -> (t -> acc -> acc)
         -> acc
         -> QueryResult t
         -> acc
foldImpl :: Bool
-> (Ptr PGresult -> IO CInt)
-> (Ptr PGresult -> IO CInt)
-> (CInt -> CInt)
-> (t -> acc -> acc)
-> acc
-> QueryResult t
-> acc
foldImpl Bool
strict Ptr PGresult -> IO CInt
initCtr Ptr PGresult -> IO CInt
termCtr CInt -> CInt
advCtr t -> acc -> acc
f acc
iacc (QueryResult (SomeSQL sql
ctx) ForeignPtr PGresult
fres row -> t
g) =
  IO acc -> acc
forall a. IO a -> a
unsafePerformIO (IO acc -> acc) -> IO acc -> acc
forall a b. (a -> b) -> a -> b
$ ForeignPtr PGresult -> (Ptr PGresult -> IO acc) -> IO acc
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr PGresult
fres ((Ptr PGresult -> IO acc) -> IO acc)
-> (Ptr PGresult -> IO acc) -> IO acc
forall a b. (a -> b) -> a -> b
$ \Ptr PGresult
res -> do
    -- This bit is referentially transparent iff appropriate
    -- FrowRow and FromSQL instances are (the ones provided
    -- by the library fulfil this requirement).
    Int
rowlen <- CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CInt -> Int) -> IO CInt -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr PGresult -> IO CInt
c_PQnfields Ptr PGresult
res
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
rowlen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Proxy row -> Int
forall t. PQFormat t => Proxy t -> Int
pqVariablesP Proxy row
rowp) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ DBException -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO DBException :: forall e sql. (Exception e, Show sql) => sql -> e -> DBException
DBException {
      dbeQueryContext :: sql
dbeQueryContext = sql
ctx
    , dbeError :: RowLengthMismatch
dbeError = RowLengthMismatch :: Int -> Int -> RowLengthMismatch
RowLengthMismatch {
        lengthExpected :: Int
lengthExpected  = Proxy row -> Int
forall t. PQFormat t => Proxy t -> Int
pqVariablesP Proxy row
rowp
      , lengthDelivered :: Int
lengthDelivered = Int
rowlen
      }
    }
    (Ptr PGerror -> IO acc) -> IO acc
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr PGerror -> IO acc) -> IO acc)
-> (Ptr PGerror -> IO acc) -> IO acc
forall a b. (a -> b) -> a -> b
$ \Ptr PGerror
err -> do
      CInt
i <- Ptr PGresult -> IO CInt
initCtr Ptr PGresult
res
      CInt
n <- Ptr PGresult -> IO CInt
termCtr Ptr PGresult
res
      Ptr PGresult -> Ptr PGerror -> CInt -> CInt -> acc -> IO acc
worker Ptr PGresult
res Ptr PGerror
err CInt
i CInt
n acc
iacc
  where
    -- ⊥ of existential type hidden in QueryResult
    row :: row
row      = let t
_ = row -> t
g row
row in row
row
    rowp :: Proxy row
rowp     = row -> Proxy row
forall (f :: * -> *) a. Applicative f => a -> f a
pure row
row

    apply :: (acc -> IO acc) -> acc -> IO acc
apply = if Bool
strict then (acc -> IO acc) -> acc -> IO acc
forall a b. (a -> b) -> a -> b
($!) else (acc -> IO acc) -> acc -> IO acc
forall a b. (a -> b) -> a -> b
($)

    worker :: Ptr PGresult -> Ptr PGerror -> CInt -> CInt -> acc -> IO acc
worker Ptr PGresult
res Ptr PGerror
err !CInt
i CInt
n acc
acc
      | CInt
i CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
n    = acc -> IO acc
forall (m :: * -> *) a. Monad m => a -> m a
return acc
acc
      | Bool
otherwise = do
        -- mask asynchronous exceptions so they won't be wrapped in DBException
        t
obj <- IO t -> IO t
forall a. IO a -> IO a
E.mask_ (row -> t
g (row -> t) -> IO row -> IO t
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr PGresult -> Ptr PGerror -> CInt -> CInt -> IO row
forall row.
FromRow row =>
Ptr PGresult -> Ptr PGerror -> CInt -> CInt -> IO row
fromRow Ptr PGresult
res Ptr PGerror
err CInt
0 CInt
i IO row -> (SomeException -> IO row) -> IO row
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` sql -> SomeException -> IO row
forall sql a. IsSQL sql => sql -> SomeException -> IO a
rethrowWithContext sql
ctx)
        Ptr PGresult -> Ptr PGerror -> CInt -> CInt -> acc -> IO acc
worker Ptr PGresult
res Ptr PGerror
err (CInt -> CInt
advCtr CInt
i) CInt
n (acc -> IO acc) -> acc -> IO acc
`apply` t -> acc -> acc
f t
obj acc
acc

-- Note: c_PQntuples/c_PQnfields are pure on a C level and QueryResult
-- constructor is not exported to the end user (so it's not possible
-- to enforce premature finalization via finalizeForeignPtr), which
-- makes usage of unsafeDupablePerformIO fine here.

-- | Extract number of returned tuples (rows) from query result.
ntuples :: QueryResult t -> Int
ntuples :: QueryResult t -> Int
ntuples QueryResult t
qr = IO Int -> Int
forall a. IO a -> a
unsafeDupablePerformIO (IO Int -> Int) -> IO Int -> Int
forall a b. (a -> b) -> a -> b
$ do
  CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CInt -> Int) -> IO CInt -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ForeignPtr PGresult -> (Ptr PGresult -> IO CInt) -> IO CInt
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr (QueryResult t -> ForeignPtr PGresult
forall t. QueryResult t -> ForeignPtr PGresult
qrResult QueryResult t
qr) Ptr PGresult -> IO CInt
c_PQntuples

-- | Extract number of returned fields (columns) from query result.
nfields :: QueryResult t -> Int
nfields :: QueryResult t -> Int
nfields QueryResult t
qr = IO Int -> Int
forall a. IO a -> a
unsafeDupablePerformIO (IO Int -> Int) -> IO Int -> Int
forall a b. (a -> b) -> a -> b
$ do
  CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CInt -> Int) -> IO CInt -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ForeignPtr PGresult -> (Ptr PGresult -> IO CInt) -> IO CInt
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr (QueryResult t -> ForeignPtr PGresult
forall t. QueryResult t -> ForeignPtr PGresult
qrResult QueryResult t
qr) Ptr PGresult -> IO CInt
c_PQnfields