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

-- | Error thrown to the user
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