{-# LANGUAGE
FlexibleContexts
, FlexibleInstances
, GADTs
, LambdaCase
, OverloadedStrings
, ScopedTypeVariables
, TypeApplications
, UndecidableInstances
#-}
module Squeal.PostgreSQL.Session.Result
( Result (..)
, MonadResult (..)
, liftResult
, nextRow
) where
import Control.Exception (throw)
import Control.Monad (when, (<=<))
import Control.Monad.Catch
import Control.Monad.IO.Class
import Data.ByteString (ByteString)
import Data.Text (Text)
import Data.Traversable (for)
import Text.Read (readMaybe)
import qualified Data.ByteString as ByteString
import qualified Data.ByteString.Char8 as Char8
import qualified Data.Text.Encoding as Text
import qualified Database.PostgreSQL.LibPQ as LibPQ
import qualified Generics.SOP as SOP
import Squeal.PostgreSQL.Session.Decode
import Squeal.PostgreSQL.Session.Exception
data Result y where
Result
:: SOP.SListI row
=> DecodeRow row y
-> LibPQ.Result
-> Result y
instance Functor Result where
fmap :: (a -> b) -> Result a -> Result b
fmap a -> b
f (Result DecodeRow row a
decode Result
result) = DecodeRow row b -> Result -> Result b
forall (row :: [(Symbol, NullType)]) y.
SListI row =>
DecodeRow row y -> Result -> Result y
Result ((a -> b) -> DecodeRow row a -> DecodeRow row b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f DecodeRow row a
decode) Result
result
class Monad m => MonadResult m where
getRow :: LibPQ.Row -> Result y -> m y
getRows :: Result y -> m [y]
firstRow :: Result y -> m (Maybe y)
ntuples :: Result y -> m LibPQ.Row
nfields :: Result y -> m LibPQ.Column
cmdStatus :: Result y -> m Text
cmdTuples :: Result y -> m (Maybe LibPQ.Row)
resultStatus :: Result y -> m LibPQ.ExecStatus
okResult :: Result y -> m ()
resultErrorMessage :: Result y -> m (Maybe ByteString)
resultErrorCode :: Result y -> m (Maybe ByteString)
instance (Monad io, MonadIO io) => MonadResult io where
getRow :: Row -> Result y -> io y
getRow Row
r (Result DecodeRow row y
decode Result
result) = IO y -> io y
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO y -> io y) -> IO y -> io y
forall a b. (a -> b) -> a -> b
$ do
Row
numRows <- Result -> IO Row
LibPQ.ntuples Result
result
Column
numCols <- Result -> IO Column
LibPQ.nfields Result
result
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Row
numRows Row -> Row -> Bool
forall a. Ord a => a -> a -> Bool
< Row
r) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ SquealException -> IO ()
forall a e. Exception e => e -> a
throw (SquealException -> IO ()) -> SquealException -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> Row -> Row -> SquealException
RowsException Text
"getRow" Row
r Row
numRows
[Maybe ByteString]
row' <- (Column -> IO (Maybe ByteString))
-> [Column] -> IO [Maybe ByteString]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Result -> Row -> Column -> IO (Maybe ByteString)
LibPQ.getvalue Result
result Row
r) [Column
0 .. Column
numCols Column -> Column -> Column
forall a. Num a => a -> a -> a
- Column
1]
case [Maybe ByteString] -> Maybe (NP (K (Maybe ByteString)) row)
forall k (xs :: [k]) a. SListI xs => [a] -> Maybe (NP (K a) xs)
SOP.fromList [Maybe ByteString]
row' of
Maybe (NP (K (Maybe ByteString)) row)
Nothing -> SquealException -> IO y
forall a e. Exception e => e -> a
throw (SquealException -> IO y) -> SquealException -> IO y
forall a b. (a -> b) -> a -> b
$ Text -> Column -> SquealException
ColumnsException Text
"getRow" Column
numCols
Just NP (K (Maybe ByteString)) row
row -> case DecodeRow row y -> NP (K (Maybe ByteString)) row -> Either Text y
forall (row :: [(Symbol, NullType)]) y.
DecodeRow row y -> NP (K (Maybe ByteString)) row -> Either Text y
execDecodeRow DecodeRow row y
decode NP (K (Maybe ByteString)) row
row of
Left Text
parseError -> SquealException -> IO y
forall a e. Exception e => e -> a
throw (SquealException -> IO y) -> SquealException -> IO y
forall a b. (a -> b) -> a -> b
$ Text -> Text -> SquealException
DecodingException Text
"getRow" Text
parseError
Right y
y -> y -> IO y
forall (m :: * -> *) a. Monad m => a -> m a
return y
y
getRows :: Result y -> io [y]
getRows (Result DecodeRow row y
decode Result
result) = IO [y] -> io [y]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [y] -> io [y]) -> IO [y] -> io [y]
forall a b. (a -> b) -> a -> b
$ do
Column
numCols <- Result -> IO Column
LibPQ.nfields Result
result
Row
numRows <- Result -> IO Row
LibPQ.ntuples Result
result
[Row] -> (Row -> IO y) -> IO [y]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Row
0 .. Row
numRows Row -> Row -> Row
forall a. Num a => a -> a -> a
- Row
1] ((Row -> IO y) -> IO [y]) -> (Row -> IO y) -> IO [y]
forall a b. (a -> b) -> a -> b
$ \ Row
r -> do
[Maybe ByteString]
row' <- (Column -> IO (Maybe ByteString))
-> [Column] -> IO [Maybe ByteString]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Result -> Row -> Column -> IO (Maybe ByteString)
LibPQ.getvalue Result
result Row
r) [Column
0 .. Column
numCols Column -> Column -> Column
forall a. Num a => a -> a -> a
- Column
1]
case [Maybe ByteString] -> Maybe (NP (K (Maybe ByteString)) row)
forall k (xs :: [k]) a. SListI xs => [a] -> Maybe (NP (K a) xs)
SOP.fromList [Maybe ByteString]
row' of
Maybe (NP (K (Maybe ByteString)) row)
Nothing -> SquealException -> IO y
forall a e. Exception e => e -> a
throw (SquealException -> IO y) -> SquealException -> IO y
forall a b. (a -> b) -> a -> b
$ Text -> Column -> SquealException
ColumnsException Text
"getRows" Column
numCols
Just NP (K (Maybe ByteString)) row
row -> case DecodeRow row y -> NP (K (Maybe ByteString)) row -> Either Text y
forall (row :: [(Symbol, NullType)]) y.
DecodeRow row y -> NP (K (Maybe ByteString)) row -> Either Text y
execDecodeRow DecodeRow row y
decode NP (K (Maybe ByteString)) row
row of
Left Text
parseError -> SquealException -> IO y
forall a e. Exception e => e -> a
throw (SquealException -> IO y) -> SquealException -> IO y
forall a b. (a -> b) -> a -> b
$ Text -> Text -> SquealException
DecodingException Text
"getRows" Text
parseError
Right y
y -> y -> IO y
forall (m :: * -> *) a. Monad m => a -> m a
return y
y
firstRow :: Result y -> io (Maybe y)
firstRow (Result DecodeRow row y
decode Result
result) = IO (Maybe y) -> io (Maybe y)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe y) -> io (Maybe y)) -> IO (Maybe y) -> io (Maybe y)
forall a b. (a -> b) -> a -> b
$ do
Row
numRows <- Result -> IO Row
LibPQ.ntuples Result
result
Column
numCols <- Result -> IO Column
LibPQ.nfields Result
result
if Row
numRows Row -> Row -> Bool
forall a. Ord a => a -> a -> Bool
<= Row
0 then Maybe y -> IO (Maybe y)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe y
forall a. Maybe a
Nothing else do
[Maybe ByteString]
row' <- (Column -> IO (Maybe ByteString))
-> [Column] -> IO [Maybe ByteString]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Result -> Row -> Column -> IO (Maybe ByteString)
LibPQ.getvalue Result
result Row
0) [Column
0 .. Column
numCols Column -> Column -> Column
forall a. Num a => a -> a -> a
- Column
1]
case [Maybe ByteString] -> Maybe (NP (K (Maybe ByteString)) row)
forall k (xs :: [k]) a. SListI xs => [a] -> Maybe (NP (K a) xs)
SOP.fromList [Maybe ByteString]
row' of
Maybe (NP (K (Maybe ByteString)) row)
Nothing -> SquealException -> IO (Maybe y)
forall a e. Exception e => e -> a
throw (SquealException -> IO (Maybe y))
-> SquealException -> IO (Maybe y)
forall a b. (a -> b) -> a -> b
$ Text -> Column -> SquealException
ColumnsException Text
"firstRow" Column
numCols
Just NP (K (Maybe ByteString)) row
row -> case DecodeRow row y -> NP (K (Maybe ByteString)) row -> Either Text y
forall (row :: [(Symbol, NullType)]) y.
DecodeRow row y -> NP (K (Maybe ByteString)) row -> Either Text y
execDecodeRow DecodeRow row y
decode NP (K (Maybe ByteString)) row
row of
Left Text
parseError -> SquealException -> IO (Maybe y)
forall a e. Exception e => e -> a
throw (SquealException -> IO (Maybe y))
-> SquealException -> IO (Maybe y)
forall a b. (a -> b) -> a -> b
$ Text -> Text -> SquealException
DecodingException Text
"firstRow" Text
parseError
Right y
y -> Maybe y -> IO (Maybe y)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe y -> IO (Maybe y)) -> Maybe y -> IO (Maybe y)
forall a b. (a -> b) -> a -> b
$ y -> Maybe y
forall a. a -> Maybe a
Just y
y
ntuples :: Result y -> io Row
ntuples = (Result -> IO Row) -> Result y -> io Row
forall (io :: * -> *) x y.
MonadIO io =>
(Result -> IO x) -> Result y -> io x
liftResult Result -> IO Row
LibPQ.ntuples
nfields :: Result y -> io Column
nfields = (Result -> IO Column) -> Result y -> io Column
forall (io :: * -> *) x y.
MonadIO io =>
(Result -> IO x) -> Result y -> io x
liftResult Result -> IO Column
LibPQ.nfields
resultStatus :: Result y -> io ExecStatus
resultStatus = (Result -> IO ExecStatus) -> Result y -> io ExecStatus
forall (io :: * -> *) x y.
MonadIO io =>
(Result -> IO x) -> Result y -> io x
liftResult Result -> IO ExecStatus
LibPQ.resultStatus
cmdStatus :: Result y -> io Text
cmdStatus = (Result -> IO Text) -> Result y -> io Text
forall (io :: * -> *) x y.
MonadIO io =>
(Result -> IO x) -> Result y -> io x
liftResult (Maybe ByteString -> IO Text
getCmdStatus (Maybe ByteString -> IO Text)
-> (Result -> IO (Maybe ByteString)) -> Result -> IO Text
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Result -> IO (Maybe ByteString)
LibPQ.cmdStatus)
where
getCmdStatus :: Maybe ByteString -> IO Text
getCmdStatus = \case
Maybe ByteString
Nothing -> SquealException -> IO Text
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (SquealException -> IO Text) -> SquealException -> IO Text
forall a b. (a -> b) -> a -> b
$ Text -> SquealException
ConnectionException Text
"LibPQ.cmdStatus"
Just ByteString
bytes -> Text -> IO Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> IO Text) -> Text -> IO Text
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
Text.decodeUtf8 ByteString
bytes
cmdTuples :: Result y -> io (Maybe Row)
cmdTuples = (Result -> IO (Maybe Row)) -> Result y -> io (Maybe Row)
forall (io :: * -> *) x y.
MonadIO io =>
(Result -> IO x) -> Result y -> io x
liftResult (Maybe ByteString -> IO (Maybe Row)
getCmdTuples (Maybe ByteString -> IO (Maybe Row))
-> (Result -> IO (Maybe ByteString)) -> Result -> IO (Maybe Row)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Result -> IO (Maybe ByteString)
LibPQ.cmdTuples)
where
getCmdTuples :: Maybe ByteString -> IO (Maybe Row)
getCmdTuples = \case
Maybe ByteString
Nothing -> SquealException -> IO (Maybe Row)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (SquealException -> IO (Maybe Row))
-> SquealException -> IO (Maybe Row)
forall a b. (a -> b) -> a -> b
$ Text -> SquealException
ConnectionException Text
"LibPQ.cmdTuples"
Just ByteString
bytes -> Maybe Row -> IO (Maybe Row)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Row -> IO (Maybe Row)) -> Maybe Row -> IO (Maybe Row)
forall a b. (a -> b) -> a -> b
$
if ByteString -> Bool
ByteString.null ByteString
bytes
then Maybe Row
forall a. Maybe a
Nothing
else Integer -> Row
forall a. Num a => Integer -> a
fromInteger (Integer -> Row) -> Maybe Integer -> Maybe Row
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Maybe Integer
forall a. Read a => String -> Maybe a
readMaybe (ByteString -> String
Char8.unpack ByteString
bytes)
okResult :: Result y -> io ()
okResult = (Result -> IO ()) -> Result y -> io ()
forall (io :: * -> *) x y.
MonadIO io =>
(Result -> IO x) -> Result y -> io x
liftResult Result -> IO ()
forall (io :: * -> *). MonadIO io => Result -> io ()
okResult_
resultErrorMessage :: Result y -> io (Maybe ByteString)
resultErrorMessage = (Result -> IO (Maybe ByteString))
-> Result y -> io (Maybe ByteString)
forall (io :: * -> *) x y.
MonadIO io =>
(Result -> IO x) -> Result y -> io x
liftResult Result -> IO (Maybe ByteString)
LibPQ.resultErrorMessage
resultErrorCode :: Result y -> io (Maybe ByteString)
resultErrorCode = (Result -> IO (Maybe ByteString))
-> Result y -> io (Maybe ByteString)
forall (io :: * -> *) x y.
MonadIO io =>
(Result -> IO x) -> Result y -> io x
liftResult ((Result -> FieldCode -> IO (Maybe ByteString))
-> FieldCode -> Result -> IO (Maybe ByteString)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Result -> FieldCode -> IO (Maybe ByteString)
LibPQ.resultErrorField FieldCode
LibPQ.DiagSqlstate)
nextRow
:: MonadIO io
=> LibPQ.Row
-> Result y
-> LibPQ.Row
-> io (Maybe (LibPQ.Row, y))
nextRow :: Row -> Result y -> Row -> io (Maybe (Row, y))
nextRow Row
total (Result DecodeRow row y
decode Result
result) Row
r
= IO (Maybe (Row, y)) -> io (Maybe (Row, y))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (Row, y)) -> io (Maybe (Row, y)))
-> IO (Maybe (Row, y)) -> io (Maybe (Row, y))
forall a b. (a -> b) -> a -> b
$ if Row
r Row -> Row -> Bool
forall a. Ord a => a -> a -> Bool
>= Row
total then Maybe (Row, y) -> IO (Maybe (Row, y))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Row, y)
forall a. Maybe a
Nothing else do
Column
numCols <- Result -> IO Column
LibPQ.nfields Result
result
[Maybe ByteString]
row' <- (Column -> IO (Maybe ByteString))
-> [Column] -> IO [Maybe ByteString]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Result -> Row -> Column -> IO (Maybe ByteString)
LibPQ.getvalue Result
result Row
r) [Column
0 .. Column
numCols Column -> Column -> Column
forall a. Num a => a -> a -> a
- Column
1]
case [Maybe ByteString] -> Maybe (NP (K (Maybe ByteString)) row)
forall k (xs :: [k]) a. SListI xs => [a] -> Maybe (NP (K a) xs)
SOP.fromList [Maybe ByteString]
row' of
Maybe (NP (K (Maybe ByteString)) row)
Nothing -> SquealException -> IO (Maybe (Row, y))
forall a e. Exception e => e -> a
throw (SquealException -> IO (Maybe (Row, y)))
-> SquealException -> IO (Maybe (Row, y))
forall a b. (a -> b) -> a -> b
$ Text -> Column -> SquealException
ColumnsException Text
"nextRow" Column
numCols
Just NP (K (Maybe ByteString)) row
row -> case DecodeRow row y -> NP (K (Maybe ByteString)) row -> Either Text y
forall (row :: [(Symbol, NullType)]) y.
DecodeRow row y -> NP (K (Maybe ByteString)) row -> Either Text y
execDecodeRow DecodeRow row y
decode NP (K (Maybe ByteString)) row
row of
Left Text
parseError -> SquealException -> IO (Maybe (Row, y))
forall a e. Exception e => e -> a
throw (SquealException -> IO (Maybe (Row, y)))
-> SquealException -> IO (Maybe (Row, y))
forall a b. (a -> b) -> a -> b
$ Text -> Text -> SquealException
DecodingException Text
"nextRow" Text
parseError
Right y
y -> Maybe (Row, y) -> IO (Maybe (Row, y))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Row, y) -> IO (Maybe (Row, y)))
-> Maybe (Row, y) -> IO (Maybe (Row, y))
forall a b. (a -> b) -> a -> b
$ (Row, y) -> Maybe (Row, y)
forall a. a -> Maybe a
Just (Row
rRow -> Row -> Row
forall a. Num a => a -> a -> a
+Row
1, y
y)
okResult_ :: MonadIO io => LibPQ.Result -> io ()
okResult_ :: Result -> io ()
okResult_ Result
result = IO () -> io ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> io ()) -> IO () -> io ()
forall a b. (a -> b) -> a -> b
$ do
ExecStatus
status <- Result -> IO ExecStatus
LibPQ.resultStatus Result
result
case ExecStatus
status of
ExecStatus
LibPQ.CommandOk -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
ExecStatus
LibPQ.TuplesOk -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
ExecStatus
_ -> do
Maybe ByteString
stateCodeMaybe <- Result -> FieldCode -> IO (Maybe ByteString)
LibPQ.resultErrorField Result
result FieldCode
LibPQ.DiagSqlstate
case Maybe ByteString
stateCodeMaybe of
Maybe ByteString
Nothing -> SquealException -> IO ()
forall a e. Exception e => e -> a
throw (SquealException -> IO ()) -> SquealException -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> SquealException
ConnectionException Text
"LibPQ.resultErrorField"
Just ByteString
stateCode -> do
Maybe ByteString
msgMaybe <- Result -> IO (Maybe ByteString)
LibPQ.resultErrorMessage Result
result
case Maybe ByteString
msgMaybe of
Maybe ByteString
Nothing -> SquealException -> IO ()
forall a e. Exception e => e -> a
throw (SquealException -> IO ()) -> SquealException -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> SquealException
ConnectionException Text
"LibPQ.resultErrorMessage"
Just ByteString
msg -> SquealException -> IO ()
forall a e. Exception e => e -> a
throw (SquealException -> IO ())
-> (SQLState -> SquealException) -> SQLState -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SQLState -> SquealException
SQLException (SQLState -> IO ()) -> SQLState -> IO ()
forall a b. (a -> b) -> a -> b
$ ExecStatus -> ByteString -> ByteString -> SQLState
SQLState ExecStatus
status ByteString
stateCode ByteString
msg
liftResult
:: MonadIO io
=> (LibPQ.Result -> IO x)
-> Result y -> io x
liftResult :: (Result -> IO x) -> Result y -> io x
liftResult Result -> IO x
f (Result DecodeRow row y
_ Result
result) = IO x -> io x
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO x -> io x) -> IO x -> io x
forall a b. (a -> b) -> a -> b
$ Result -> IO x
f Result
result
execDecodeRow
:: DecodeRow row y
-> SOP.NP (SOP.K (Maybe ByteString)) row
-> Either Text y
execDecodeRow :: DecodeRow row y -> NP (K (Maybe ByteString)) row -> Either Text y
execDecodeRow DecodeRow row y
decode = DecodeRow row y -> NP (K (Maybe ByteString)) row -> Either Text y
forall (row :: [(Symbol, NullType)]) y.
DecodeRow row y -> NP (K (Maybe ByteString)) row -> Either Text y
runDecodeRow DecodeRow row y
decode