{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE NamedFieldPuns            #-}
{-# LANGUAGE OverloadedStrings         #-}

module Database.PostgreSQL.Pure.Internal.Exception
  ( Exception (..)
  , ErrorResponse (..)
  , ResponseParsingFailed (..)
  , InternalException (..)
  , convert
  , cantReachHere
  ) where

import           Database.PostgreSQL.Pure.Internal.Data (ErrorFields (ErrorFields), Pretty (pretty), TransactionState)

import           Control.Exception.Safe                 (displayException, fromException, throw, toException, try)
import qualified Control.Exception.Safe                 as E
import           Control.Monad                          ((<=<))
import qualified Data.ByteString                        as BS
import qualified Data.ByteString.Short                  as BSS
import qualified Data.ByteString.UTF8                   as BSU
import           Data.Typeable                          (Typeable, cast)
import           GHC.Stack                              (HasCallStack)

-- | Root exception.
--
-- @
-- 'Exception'
--   ├ 'ErrorResponse'
--   └ 'ResponseParsingFailed'
-- @
data Exception = forall e. E.Exception e => Exception e deriving (Typeable)

instance Show Exception where
  show :: Exception -> String
show (Exception e
e) = e -> String
forall a. Show a => a -> String
show e
e

instance E.Exception Exception where
  displayException :: Exception -> String
displayException (Exception e
e) = e -> String
forall e. Exception e => e -> String
displayException e
e

-- | This means that the server responds an error.
data ErrorResponse =
  ErrorResponse { ErrorResponse -> ByteString
severity :: BS.ByteString, ErrorResponse -> ByteString
code :: BS.ByteString, ErrorResponse -> ByteString
message :: BS.ByteString, ErrorResponse -> Maybe TransactionState
transactionState :: Maybe TransactionState }
  deriving (Int -> ErrorResponse -> ShowS
[ErrorResponse] -> ShowS
ErrorResponse -> String
(Int -> ErrorResponse -> ShowS)
-> (ErrorResponse -> String)
-> ([ErrorResponse] -> ShowS)
-> Show ErrorResponse
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ErrorResponse] -> ShowS
$cshowList :: [ErrorResponse] -> ShowS
show :: ErrorResponse -> String
$cshow :: ErrorResponse -> String
showsPrec :: Int -> ErrorResponse -> ShowS
$cshowsPrec :: Int -> ErrorResponse -> ShowS
Show, ReadPrec [ErrorResponse]
ReadPrec ErrorResponse
Int -> ReadS ErrorResponse
ReadS [ErrorResponse]
(Int -> ReadS ErrorResponse)
-> ReadS [ErrorResponse]
-> ReadPrec ErrorResponse
-> ReadPrec [ErrorResponse]
-> Read ErrorResponse
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [ErrorResponse]
$creadListPrec :: ReadPrec [ErrorResponse]
readPrec :: ReadPrec ErrorResponse
$creadPrec :: ReadPrec ErrorResponse
readList :: ReadS [ErrorResponse]
$creadList :: ReadS [ErrorResponse]
readsPrec :: Int -> ReadS ErrorResponse
$creadsPrec :: Int -> ReadS ErrorResponse
Read, ErrorResponse -> ErrorResponse -> Bool
(ErrorResponse -> ErrorResponse -> Bool)
-> (ErrorResponse -> ErrorResponse -> Bool) -> Eq ErrorResponse
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ErrorResponse -> ErrorResponse -> Bool
$c/= :: ErrorResponse -> ErrorResponse -> Bool
== :: ErrorResponse -> ErrorResponse -> Bool
$c== :: ErrorResponse -> ErrorResponse -> Bool
Eq, Typeable)

instance E.Exception ErrorResponse where
  toException :: ErrorResponse -> SomeException
toException = Exception -> SomeException
forall e. Exception e => e -> SomeException
toException (Exception -> SomeException)
-> (ErrorResponse -> Exception) -> ErrorResponse -> SomeException
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorResponse -> Exception
forall e. Exception e => e -> Exception
Exception
  fromException :: SomeException -> Maybe ErrorResponse
fromException = (\(Exception e
e) -> e -> Maybe ErrorResponse
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast e
e) (Exception -> Maybe ErrorResponse)
-> (SomeException -> Maybe Exception)
-> SomeException
-> Maybe ErrorResponse
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< SomeException -> Maybe Exception
forall e. Exception e => SomeException -> Maybe e
fromException
  displayException :: ErrorResponse -> String
displayException = ErrorResponse -> String
forall a. Pretty a => a -> String
pretty

instance Pretty ErrorResponse where
  pretty :: ErrorResponse -> String
pretty ErrorResponse { ByteString
severity :: ByteString
severity :: ErrorResponse -> ByteString
severity, ByteString
code :: ByteString
code :: ErrorResponse -> ByteString
code, ByteString
message :: ByteString
message :: ErrorResponse -> ByteString
message, Maybe TransactionState
transactionState :: Maybe TransactionState
transactionState :: ErrorResponse -> Maybe TransactionState
transactionState } =
    String
"error response:\n"
    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\tseverity: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
BSU.toString ByteString
severity -- only supports UTF-8
    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n\tcode: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
BSU.toString ByteString
code
    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n\tmessage: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
BSU.toString ByteString
message
    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> case Maybe TransactionState
transactionState of
         Just TransactionState
ts -> String
"\n\ttransaction state: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> TransactionState -> String
forall a. Pretty a => a -> String
pretty TransactionState
ts
         Maybe TransactionState
Nothing -> String
forall a. Monoid a => a
mempty

-- | This means that the server responds an unknown message.
newtype ResponseParsingFailed =
  ResponseParsingFailed { ResponseParsingFailed -> String
causedBy :: String }
  deriving (Int -> ResponseParsingFailed -> ShowS
[ResponseParsingFailed] -> ShowS
ResponseParsingFailed -> String
(Int -> ResponseParsingFailed -> ShowS)
-> (ResponseParsingFailed -> String)
-> ([ResponseParsingFailed] -> ShowS)
-> Show ResponseParsingFailed
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ResponseParsingFailed] -> ShowS
$cshowList :: [ResponseParsingFailed] -> ShowS
show :: ResponseParsingFailed -> String
$cshow :: ResponseParsingFailed -> String
showsPrec :: Int -> ResponseParsingFailed -> ShowS
$cshowsPrec :: Int -> ResponseParsingFailed -> ShowS
Show, Typeable)

instance E.Exception ResponseParsingFailed where
  toException :: ResponseParsingFailed -> SomeException
toException = Exception -> SomeException
forall e. Exception e => e -> SomeException
toException (Exception -> SomeException)
-> (ResponseParsingFailed -> Exception)
-> ResponseParsingFailed
-> SomeException
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResponseParsingFailed -> Exception
forall e. Exception e => e -> Exception
Exception
  fromException :: SomeException -> Maybe ResponseParsingFailed
fromException = (\(Exception e
e) -> e -> Maybe ResponseParsingFailed
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast e
e) (Exception -> Maybe ResponseParsingFailed)
-> (SomeException -> Maybe Exception)
-> SomeException
-> Maybe ResponseParsingFailed
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< SomeException -> Maybe Exception
forall e. Exception e => SomeException -> Maybe e
fromException
  displayException :: ResponseParsingFailed -> String
displayException = ResponseParsingFailed -> String
forall a. Pretty a => a -> String
pretty

instance Pretty ResponseParsingFailed where
  pretty :: ResponseParsingFailed -> String
pretty (ResponseParsingFailed String
c) = String
"response parsing failed:\n\tcaused by " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
c

data InternalException
  = InternalResponseParsingFailed String BS.ByteString
  | InternalErrorResponse ErrorFields (Maybe TransactionState) BS.ByteString
  | InternalExtraData BS.ByteString
  deriving (Int -> InternalException -> ShowS
[InternalException] -> ShowS
InternalException -> String
(Int -> InternalException -> ShowS)
-> (InternalException -> String)
-> ([InternalException] -> ShowS)
-> Show InternalException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [InternalException] -> ShowS
$cshowList :: [InternalException] -> ShowS
show :: InternalException -> String
$cshow :: InternalException -> String
showsPrec :: Int -> InternalException -> ShowS
$cshowsPrec :: Int -> InternalException -> ShowS
Show, ReadPrec [InternalException]
ReadPrec InternalException
Int -> ReadS InternalException
ReadS [InternalException]
(Int -> ReadS InternalException)
-> ReadS [InternalException]
-> ReadPrec InternalException
-> ReadPrec [InternalException]
-> Read InternalException
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [InternalException]
$creadListPrec :: ReadPrec [InternalException]
readPrec :: ReadPrec InternalException
$creadPrec :: ReadPrec InternalException
readList :: ReadS [InternalException]
$creadList :: ReadS [InternalException]
readsPrec :: Int -> ReadS InternalException
$creadsPrec :: Int -> ReadS InternalException
Read, InternalException -> InternalException -> Bool
(InternalException -> InternalException -> Bool)
-> (InternalException -> InternalException -> Bool)
-> Eq InternalException
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: InternalException -> InternalException -> Bool
$c/= :: InternalException -> InternalException -> Bool
== :: InternalException -> InternalException -> Bool
$c== :: InternalException -> InternalException -> Bool
Eq, Typeable)

instance E.Exception InternalException

internalExceptionToExposedException :: InternalException -> Exception
internalExceptionToExposedException :: InternalException -> Exception
internalExceptionToExposedException e :: InternalException
e@InternalResponseParsingFailed {} = ResponseParsingFailed -> Exception
forall e. Exception e => e -> Exception
Exception (ResponseParsingFailed -> Exception)
-> ResponseParsingFailed -> Exception
forall a b. (a -> b) -> a -> b
$ String -> ResponseParsingFailed
ResponseParsingFailed (String -> ResponseParsingFailed)
-> String -> ResponseParsingFailed
forall a b. (a -> b) -> a -> b
$ InternalException -> String
forall e. Exception e => e -> String
displayException InternalException
e
internalExceptionToExposedException (InternalErrorResponse (ErrorFields [(Char, ShortByteString)]
fields) Maybe TransactionState
transactionState ByteString
_) =
  ErrorResponse -> Exception
forall e. Exception e => e -> Exception
Exception ErrorResponse :: ByteString
-> ByteString
-> ByteString
-> Maybe TransactionState
-> ErrorResponse
ErrorResponse { ByteString
severity :: ByteString
severity :: ByteString
severity, ByteString
code :: ByteString
code :: ByteString
code, ByteString
message :: ByteString
message :: ByteString
message, Maybe TransactionState
transactionState :: Maybe TransactionState
transactionState :: Maybe TransactionState
transactionState }
  where
    (ByteString
severity, ByteString
code, ByteString
message) = (ShortByteString -> ByteString)
-> (ShortByteString, ShortByteString, ShortByteString)
-> (ByteString, ByteString, ByteString)
forall t c. (t -> c) -> (t, t, t) -> (c, c, c)
map3 ShortByteString -> ByteString
BSS.fromShort ((ShortByteString, ShortByteString, ShortByteString)
 -> (ByteString, ByteString, ByteString))
-> (ShortByteString, ShortByteString, ShortByteString)
-> (ByteString, ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ ((Char, ShortByteString)
 -> (ShortByteString, ShortByteString, ShortByteString)
 -> (ShortByteString, ShortByteString, ShortByteString))
-> (ShortByteString, ShortByteString, ShortByteString)
-> [(Char, ShortByteString)]
-> (ShortByteString, ShortByteString, ShortByteString)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Char, ShortByteString)
-> (ShortByteString, ShortByteString, ShortByteString)
-> (ShortByteString, ShortByteString, ShortByteString)
forall c. (Char, c) -> (c, c, c) -> (c, c, c)
go (ShortByteString
"", ShortByteString
"", ShortByteString
"") [(Char, ShortByteString)]
fields
    go :: (Char, c) -> (c, c, c) -> (c, c, c)
go (Char
'S', c
largeS) (c
_, c
largeC, c
largeM) = (c
largeS, c
largeC, c
largeM)
    go (Char
'C', c
largeC) (c
largeS, c
_, c
largeM) = (c
largeS, c
largeC, c
largeM)
    go (Char
'M', c
largeM) (c
largeS, c
largeC, c
_) = (c
largeS, c
largeC, c
largeM)
    go (Char, c)
_ (c, c, c)
a                               = (c, c, c)
a
    map3 :: (t -> c) -> (t, t, t) -> (c, c, c)
map3 t -> c
f (t
v1, t
v2, t
v3) = (t -> c
f t
v1, t -> c
f t
v2, t -> c
f t
v3)
internalExceptionToExposedException e :: InternalException
e@InternalExtraData {} = ResponseParsingFailed -> Exception
forall e. Exception e => e -> Exception
Exception (ResponseParsingFailed -> Exception)
-> ResponseParsingFailed -> Exception
forall a b. (a -> b) -> a -> b
$ String -> ResponseParsingFailed
ResponseParsingFailed (String -> ResponseParsingFailed)
-> String -> ResponseParsingFailed
forall a b. (a -> b) -> a -> b
$ InternalException -> String
forall e. Exception e => e -> String
displayException InternalException
e

convert :: IO a -> IO a
convert :: IO a -> IO a
convert IO a
a = do
  Either InternalException a
r <- IO a -> IO (Either InternalException a)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try IO a
a
  case Either InternalException a
r of
    Right a
r -> a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
r
    Left InternalException
e  -> Exception -> IO a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throw (Exception -> IO a) -> Exception -> IO a
forall a b. (a -> b) -> a -> b
$ InternalException -> Exception
internalExceptionToExposedException InternalException
e

cantReachHere :: HasCallStack => a
cantReachHere :: a
cantReachHere = String -> a
forall a. HasCallStack => String -> a
error String
"can't reach here"