{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE RankNTypes #-}
module PostgreSQL.Result
( Result
, runResultPq
, ignored
, single
, first
, many
, affectedRows
, checkForError
)
where
import Control.Monad (when)
import qualified Control.Monad.Except as Except
import Control.Monad.IO.Class (MonadIO, liftIO)
import qualified Data.Bifunctor as Bifunctor
import qualified Data.ByteString as ByteString
import Data.Foldable (for_)
import Data.Maybe (fromMaybe)
import qualified Data.Text as Text
import Data.Text.Encoding (decodeUtf8')
import qualified Data.Vector as Vector
import qualified Database.PostgreSQL.LibPQ as PQ
import qualified PostgreSQL.Result.Row as Row
import qualified PostgreSQL.Types as Types
import Text.Read (readEither)
data ResultF a where
IgnoreResult :: ResultF ()
SingleRow :: Row.Row a -> ResultF a
FirstRow :: Row.Row a -> ResultF a
ManyRows :: Row.Row a -> ResultF (Vector.Vector a)
AffectedRows :: ResultF Integer
data Result a where
Result :: (b -> a) -> ResultF b -> Result a
instance Functor Result where
fmap :: (a -> b) -> Result a -> Result b
fmap a -> b
f (Result b -> a
g ResultF b
inner) = (b -> b) -> ResultF b -> Result b
forall b a. (b -> a) -> ResultF b -> Result a
Result (a -> b
f (a -> b) -> (b -> a) -> b -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> a
g) ResultF b
inner
{-# INLINE fmap #-}
runResultPq :: MonadIO m => PQ.Result -> Result a -> m (Either Types.Errors a)
runResultPq :: Result -> Result a -> m (Either Errors a)
runResultPq Result
result (Result b -> a
f ResultF b
basis) = ExceptT Errors m a -> m (Either Errors a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
Except.runExceptT (ExceptT Errors m a -> m (Either Errors a))
-> ExceptT Errors m a -> m (Either Errors a)
forall a b. (a -> b) -> a -> b
$ (b -> a) -> ExceptT Errors m b -> ExceptT Errors m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b -> a
f (ExceptT Errors m b -> ExceptT Errors m a)
-> ExceptT Errors m b -> ExceptT Errors m a
forall a b. (a -> b) -> a -> b
$
case ResultF b
basis of
ResultF b
IgnoreResult ->
() -> ExceptT Errors m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
SingleRow Row b
row -> do
Row
rows <- IO Row -> ExceptT Errors m Row
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Result -> IO Row
PQ.ntuples Result
result)
Bool -> ExceptT Errors m () -> ExceptT Errors m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Row
rows Row -> Row -> Bool
forall a. Eq a => a -> a -> Bool
/= Row
1) (ExceptT Errors m () -> ExceptT Errors m ())
-> ExceptT Errors m () -> ExceptT Errors m ()
forall a b. (a -> b) -> a -> b
$
Errors -> ExceptT Errors m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
Except.throwError [ResultError -> Error
Types.ErrorDuringValidation (ResultError -> Error) -> ResultError -> Error
forall a b. (a -> b) -> a -> b
$ RowNum -> ResultError
Types.MultipleRows (RowNum -> ResultError) -> RowNum -> ResultError
forall a b. (a -> b) -> a -> b
$ Row -> RowNum
Types.RowNum Row
rows]
RowNum -> ExceptT (NonEmpty ProcessorError) m b
runRow <- ExceptT
(NonEmpty ProcessorError)
m
(RowNum -> ExceptT (NonEmpty ProcessorError) m b)
-> ExceptT
Errors m (RowNum -> ExceptT (NonEmpty ProcessorError) m b)
forall a.
ExceptT (NonEmpty ProcessorError) m a -> ExceptT Errors m a
importErrors (Result
-> Row b
-> ExceptT
(NonEmpty ProcessorError)
m
(RowNum -> ExceptT (NonEmpty ProcessorError) m b)
forall (m :: * -> *) a.
(MonadError (NonEmpty ProcessorError) m, MonadIO m) =>
Result -> Row a -> m (RowNum -> m a)
Row.runRowPq Result
result Row b
row)
ExceptT (NonEmpty ProcessorError) m b -> ExceptT Errors m b
forall a.
ExceptT (NonEmpty ProcessorError) m a -> ExceptT Errors m a
importErrors (RowNum -> ExceptT (NonEmpty ProcessorError) m b
runRow RowNum
0)
FirstRow Row b
row -> do
Row
rows <- IO Row -> ExceptT Errors m Row
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Result -> IO Row
PQ.ntuples Result
result)
Bool -> ExceptT Errors m () -> ExceptT Errors m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Row
rows Row -> Row -> Bool
forall a. Ord a => a -> a -> Bool
< Row
1) (ExceptT Errors m () -> ExceptT Errors m ())
-> ExceptT Errors m () -> ExceptT Errors m ()
forall a b. (a -> b) -> a -> b
$ Errors -> ExceptT Errors m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
Except.throwError [ResultError -> Error
Types.ErrorDuringValidation ResultError
Types.NoRows]
RowNum -> ExceptT (NonEmpty ProcessorError) m b
runRow <- ExceptT
(NonEmpty ProcessorError)
m
(RowNum -> ExceptT (NonEmpty ProcessorError) m b)
-> ExceptT
Errors m (RowNum -> ExceptT (NonEmpty ProcessorError) m b)
forall a.
ExceptT (NonEmpty ProcessorError) m a -> ExceptT Errors m a
importErrors (Result
-> Row b
-> ExceptT
(NonEmpty ProcessorError)
m
(RowNum -> ExceptT (NonEmpty ProcessorError) m b)
forall (m :: * -> *) a.
(MonadError (NonEmpty ProcessorError) m, MonadIO m) =>
Result -> Row a -> m (RowNum -> m a)
Row.runRowPq Result
result Row b
row)
ExceptT (NonEmpty ProcessorError) m b -> ExceptT Errors m b
forall a.
ExceptT (NonEmpty ProcessorError) m a -> ExceptT Errors m a
importErrors (RowNum -> ExceptT (NonEmpty ProcessorError) m b
runRow RowNum
0)
ManyRows Row a
row -> do
RowNum -> ExceptT (NonEmpty ProcessorError) m a
runRow <- ExceptT
(NonEmpty ProcessorError)
m
(RowNum -> ExceptT (NonEmpty ProcessorError) m a)
-> ExceptT
Errors m (RowNum -> ExceptT (NonEmpty ProcessorError) m a)
forall a.
ExceptT (NonEmpty ProcessorError) m a -> ExceptT Errors m a
importErrors (Result
-> Row a
-> ExceptT
(NonEmpty ProcessorError)
m
(RowNum -> ExceptT (NonEmpty ProcessorError) m a)
forall (m :: * -> *) a.
(MonadError (NonEmpty ProcessorError) m, MonadIO m) =>
Result -> Row a -> m (RowNum -> m a)
Row.runRowPq Result
result Row a
row)
PQ.Row CInt
rows <- IO Row -> ExceptT Errors m Row
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Result -> IO Row
PQ.ntuples Result
result)
Int -> (Int -> ExceptT Errors m a) -> ExceptT Errors m (Vector a)
forall (m :: * -> *) a.
Monad m =>
Int -> (Int -> m a) -> m (Vector a)
Vector.generateM (CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
rows) (ExceptT (NonEmpty ProcessorError) m a -> ExceptT Errors m a
forall a.
ExceptT (NonEmpty ProcessorError) m a -> ExceptT Errors m a
importErrors (ExceptT (NonEmpty ProcessorError) m a -> ExceptT Errors m a)
-> (Int -> ExceptT (NonEmpty ProcessorError) m a)
-> Int
-> ExceptT Errors m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RowNum -> ExceptT (NonEmpty ProcessorError) m a
runRow (RowNum -> ExceptT (NonEmpty ProcessorError) m a)
-> (Int -> RowNum) -> Int -> ExceptT (NonEmpty ProcessorError) m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> RowNum
forall a b. (Integral a, Num b) => a -> b
fromIntegral)
ResultF b
AffectedRows -> do
Maybe ByteString
tuples <- IO (Maybe ByteString) -> ExceptT Errors m (Maybe ByteString)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Result -> IO (Maybe ByteString)
PQ.cmdTuples Result
result)
case Maybe ByteString
tuples of
Maybe ByteString
Nothing -> b -> ExceptT Errors m b
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
0
Just ByteString
tuples ->
Either Errors b -> ExceptT Errors m b
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
Except.liftEither
(Either Errors b -> ExceptT Errors m b)
-> Either Errors b -> ExceptT Errors m b
forall a b. (a -> b) -> a -> b
$ (String -> Errors) -> Either String b -> Either Errors b
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
Bifunctor.first
(Error -> Errors
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Error -> Errors) -> (String -> Error) -> String -> Errors
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResultError -> Error
Types.ErrorDuringValidation (ResultError -> Error)
-> (String -> ResultError) -> String -> Error
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ResultError
Types.FailedToParseAffectedRows (Text -> ResultError) -> (String -> Text) -> String -> ResultError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack)
(Either String b -> Either Errors b)
-> Either String b -> Either Errors b
forall a b. (a -> b) -> a -> b
$ do
Text
tuples <- (UnicodeException -> String)
-> Either UnicodeException Text -> Either String Text
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
Bifunctor.first UnicodeException -> String
forall a. Show a => a -> String
show (ByteString -> Either UnicodeException Text
decodeUtf8' ByteString
tuples)
String -> Either String b
forall a. Read a => String -> Either String a
readEither (Text -> String
Text.unpack Text
tuples)
where
importErrors :: ExceptT (NonEmpty ProcessorError) m a -> ExceptT Errors m a
importErrors = (NonEmpty ProcessorError -> Errors)
-> ExceptT (NonEmpty ProcessorError) m a -> ExceptT Errors m a
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
Except.withExceptT ((ProcessorError -> Error) -> NonEmpty ProcessorError -> Errors
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ProcessorError -> Error
Types.ErrorDuringProcessing)
ignored :: Result ()
ignored :: Result ()
ignored = (() -> ()) -> ResultF () -> Result ()
forall b a. (b -> a) -> ResultF b -> Result a
Result () -> ()
forall a. a -> a
id ResultF ()
IgnoreResult
single :: Row.Row a -> Result a
single :: Row a -> Result a
single Row a
row = (a -> a) -> ResultF a -> Result a
forall b a. (b -> a) -> ResultF b -> Result a
Result a -> a
forall a. a -> a
id (Row a -> ResultF a
forall a. Row a -> ResultF a
SingleRow Row a
row)
first :: Row.Row a -> Result a
first :: Row a -> Result a
first Row a
row = (a -> a) -> ResultF a -> Result a
forall b a. (b -> a) -> ResultF b -> Result a
Result a -> a
forall a. a -> a
id (Row a -> ResultF a
forall a. Row a -> ResultF a
FirstRow Row a
row)
many :: Row.Row a -> Result (Vector.Vector a)
many :: Row a -> Result (Vector a)
many Row a
row = (Vector a -> Vector a) -> ResultF (Vector a) -> Result (Vector a)
forall b a. (b -> a) -> ResultF b -> Result a
Result Vector a -> Vector a
forall a. a -> a
id (Row a -> ResultF (Vector a)
forall a. Row a -> ResultF (Vector a)
ManyRows Row a
row)
affectedRows :: Result Integer
affectedRows :: Result Integer
affectedRows = (Integer -> Integer) -> ResultF Integer -> Result Integer
forall b a. (b -> a) -> ResultF b -> Result a
Result Integer -> Integer
forall a. a -> a
id ResultF Integer
AffectedRows
checkForError
:: (MonadIO m, Except.MonadError Types.ResultErrors m)
=> Types.Connection
-> Maybe PQ.Result
-> m PQ.Result
checkForError :: Connection -> Maybe Result -> m Result
checkForError Connection
conn Maybe Result
mbResult = do
Result
result <-
case Maybe Result
mbResult of
Maybe Result
Nothing -> do
Maybe ByteString
connError <- IO (Maybe ByteString) -> m (Maybe ByteString)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe ByteString) -> m (Maybe ByteString))
-> IO (Maybe ByteString) -> m (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ Connection -> IO (Maybe ByteString)
PQ.errorMessage Connection
conn
ResultErrors -> m Result
forall e (m :: * -> *) a. MonadError e m => e -> m a
Except.throwError [ByteString -> ResultError
Types.BadResultStatus (ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
forall a. Monoid a => a
mempty Maybe ByteString
connError)]
Just Result
result -> Result -> m Result
forall (f :: * -> *) a. Applicative f => a -> f a
pure Result
result
Maybe ByteString
resultError <- IO (Maybe ByteString) -> m (Maybe ByteString)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe ByteString) -> m (Maybe ByteString))
-> IO (Maybe ByteString) -> m (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ Result -> IO (Maybe ByteString)
PQ.resultErrorMessage Result
result
Maybe ByteString -> (ByteString -> m ()) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe ByteString
resultError ((ByteString -> m ()) -> m ()) -> (ByteString -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \ByteString
error ->
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> Int
ByteString.length ByteString
error Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
ResultErrors -> m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
Except.throwError [ByteString -> ResultError
Types.BadResultStatus ByteString
error]
Result -> m Result
forall (f :: * -> *) a. Applicative f => a -> f a
pure Result
result
{-# INLINE checkForError #-}