{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE RankNTypes #-}

-- | This module is dedicated to dealing with query results.
module PostgreSQL.Result
  ( Result
  , runResultPq

    -- * Combinators
  , ignored
  , single
  , first
  , many
  , affectedRows

    -- * Validation
  , 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

-- | Query result
--
-- @since 0.0.0
data Result a where
  Result :: (b -> a) -> ResultF b -> Result a

-- | @since 0.0.0
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 #-}

-- | Process libpq's 'PQ.Result'.
--
-- @since 0.0.0
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)


-- | Ignore the result set.
--
-- @since 0.0.0
ignored :: Result ()
ignored :: Result ()
ignored = (() -> ()) -> ResultF () -> Result ()
forall b a. (b -> a) -> ResultF b -> Result a
Result () -> ()
forall a. a -> a
id ResultF ()
IgnoreResult

-- | Process exactly 1 row.
--
-- @since 0.0.0
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)

-- | Process only the first row. There may be more rows in the result set, but they won't be
-- touched.
--
-- @since 0.0.0
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)

-- | Process 0 or more rows.
--
-- @since 0.0.0
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)


-- | Get the number of affected rows.
--
-- @since 0.0.0
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

---

-- | Check the result, if any, and the connection for errors.
--
-- @since 0.0.0
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 #-}