module Wire.Error where
import Data.Aeson
import Data.Aeson.KeyMap qualified as KeyMap
import Data.ByteString qualified as BS
import Data.Text qualified as Text
import Data.Text.Encoding qualified as Text
import Imports
import Network.HTTP.Types
import Network.Wai.Utilities.Error qualified as Wai
data HttpError where
StdError :: !Wai.Error -> HttpError
RichError :: (ToJSON a) => !Wai.Error -> !a -> [Header] -> HttpError
instance Show HttpError where
show :: HttpError -> String
show (StdError Error
werr) = String
"StdError (" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Error -> String
forall a. Show a => a -> String
show Error
werr String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
")"
show e :: HttpError
e@(RichError Error
_ a
_ [Header]
headers) = String
"RichError (json = " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
Text.unpack (ByteString -> Text
Text.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BS.toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ HttpError -> ByteString
forall a. ToJSON a => a -> ByteString
encode HttpError
e) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
", headers = " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Header] -> String
forall a. Show a => a -> String
show [Header]
headers String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
")"
instance Exception HttpError
errorLabel :: HttpError -> LText
errorLabel :: HttpError -> LText
errorLabel (StdError Error
e) = Error -> LText
Wai.label Error
e
errorLabel (RichError Error
e a
_ [Header]
_) = Error -> LText
Wai.label Error
e
instance ToJSON HttpError where
toJSON :: HttpError -> Value
toJSON (StdError Error
e) = Error -> Value
forall a. ToJSON a => a -> Value
toJSON Error
e
toJSON (RichError Error
e a
x [Header]
_) = case (Error -> Value
forall a. ToJSON a => a -> Value
toJSON Error
e, a -> Value
forall a. ToJSON a => a -> Value
toJSON a
x) of
(Object Object
o1, Object Object
o2) -> Object -> Value
Object (Object -> Object -> Object
forall v. KeyMap v -> KeyMap v -> KeyMap v
KeyMap.union Object
o1 Object
o2)
(Value
j, Value
_) -> Value
j