-- This file is part of the Wire Server implementation.
--
-- Copyright (C) 2023 Wire Swiss GmbH <opensource@wire.com>
--
-- This program is free software: you can redistribute it and/or modify it under
-- the terms of the GNU Affero General Public License as published by the Free
-- Software Foundation, either version 3 of the License, or (at your option) any
-- later version.
--
-- This program is distributed in the hope that it will be useful, but WITHOUT
-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more
-- details.
--
-- You should have received a copy of the GNU Affero General Public License along
-- with this program. If not, see <https://www.gnu.org/licenses/>.

module Network.Wai.Utilities.JSONResponse
  ( JSONResponse (..),
    waiErrorToJSONResponse,
    jsonResponseToWai,
  )
where

import Data.Aeson (FromJSON (..), ToJSON (..))
import Data.Aeson qualified as A
import Data.OpenApi qualified as S
import Data.Schema
import Imports
import Network.HTTP.Types.Status
import Network.Wai
import Network.Wai.Utilities.Error qualified as Wai
import Network.Wai.Utilities.Response

-- | A custom JSON response to be returned to the client as an error.
--
-- Both static and dynamic errors are converted to this type before being
-- turned into HTTP responses. It is a generalisation of 'Wai.Error',
-- encompassing both standard error values (including @label@, @code@ and
-- @message@ fields), and custom error-like responses that include extra data
-- for the clients.
data JSONResponse = JSONResponse
  { JSONResponse -> Status
status :: Status,
    JSONResponse -> Value
value :: A.Value
  }
  deriving (JSONResponse -> JSONResponse -> Bool
(JSONResponse -> JSONResponse -> Bool)
-> (JSONResponse -> JSONResponse -> Bool) -> Eq JSONResponse
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: JSONResponse -> JSONResponse -> Bool
== :: JSONResponse -> JSONResponse -> Bool
$c/= :: JSONResponse -> JSONResponse -> Bool
/= :: JSONResponse -> JSONResponse -> Bool
Eq, Eq JSONResponse
Eq JSONResponse =>
(JSONResponse -> JSONResponse -> Ordering)
-> (JSONResponse -> JSONResponse -> Bool)
-> (JSONResponse -> JSONResponse -> Bool)
-> (JSONResponse -> JSONResponse -> Bool)
-> (JSONResponse -> JSONResponse -> Bool)
-> (JSONResponse -> JSONResponse -> JSONResponse)
-> (JSONResponse -> JSONResponse -> JSONResponse)
-> Ord JSONResponse
JSONResponse -> JSONResponse -> Bool
JSONResponse -> JSONResponse -> Ordering
JSONResponse -> JSONResponse -> JSONResponse
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: JSONResponse -> JSONResponse -> Ordering
compare :: JSONResponse -> JSONResponse -> Ordering
$c< :: JSONResponse -> JSONResponse -> Bool
< :: JSONResponse -> JSONResponse -> Bool
$c<= :: JSONResponse -> JSONResponse -> Bool
<= :: JSONResponse -> JSONResponse -> Bool
$c> :: JSONResponse -> JSONResponse -> Bool
> :: JSONResponse -> JSONResponse -> Bool
$c>= :: JSONResponse -> JSONResponse -> Bool
>= :: JSONResponse -> JSONResponse -> Bool
$cmax :: JSONResponse -> JSONResponse -> JSONResponse
max :: JSONResponse -> JSONResponse -> JSONResponse
$cmin :: JSONResponse -> JSONResponse -> JSONResponse
min :: JSONResponse -> JSONResponse -> JSONResponse
Ord, Int -> JSONResponse -> ShowS
[JSONResponse] -> ShowS
JSONResponse -> String
(Int -> JSONResponse -> ShowS)
-> (JSONResponse -> String)
-> ([JSONResponse] -> ShowS)
-> Show JSONResponse
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> JSONResponse -> ShowS
showsPrec :: Int -> JSONResponse -> ShowS
$cshow :: JSONResponse -> String
show :: JSONResponse -> String
$cshowList :: [JSONResponse] -> ShowS
showList :: [JSONResponse] -> ShowS
Show)
  deriving (Value -> Parser [JSONResponse]
Value -> Parser JSONResponse
(Value -> Parser JSONResponse)
-> (Value -> Parser [JSONResponse]) -> FromJSON JSONResponse
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
$cparseJSON :: Value -> Parser JSONResponse
parseJSON :: Value -> Parser JSONResponse
$cparseJSONList :: Value -> Parser [JSONResponse]
parseJSONList :: Value -> Parser [JSONResponse]
FromJSON, [JSONResponse] -> Value
[JSONResponse] -> Encoding
JSONResponse -> Value
JSONResponse -> Encoding
(JSONResponse -> Value)
-> (JSONResponse -> Encoding)
-> ([JSONResponse] -> Value)
-> ([JSONResponse] -> Encoding)
-> ToJSON JSONResponse
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
$ctoJSON :: JSONResponse -> Value
toJSON :: JSONResponse -> Value
$ctoEncoding :: JSONResponse -> Encoding
toEncoding :: JSONResponse -> Encoding
$ctoJSONList :: [JSONResponse] -> Value
toJSONList :: [JSONResponse] -> Value
$ctoEncodingList :: [JSONResponse] -> Encoding
toEncodingList :: [JSONResponse] -> Encoding
ToJSON, Typeable JSONResponse
Typeable JSONResponse =>
(Proxy JSONResponse -> Declare (Definitions Schema) NamedSchema)
-> ToSchema JSONResponse
Proxy JSONResponse -> Declare (Definitions Schema) NamedSchema
forall a.
Typeable a =>
(Proxy a -> Declare (Definitions Schema) NamedSchema) -> ToSchema a
$cdeclareNamedSchema :: Proxy JSONResponse -> Declare (Definitions Schema) NamedSchema
declareNamedSchema :: Proxy JSONResponse -> Declare (Definitions Schema) NamedSchema
S.ToSchema) via Schema JSONResponse

instance ToSchema JSONResponse where
  schema :: ValueSchema NamedSwaggerDoc JSONResponse
schema =
    Text
-> SchemaP SwaggerDoc Object [Pair] JSONResponse JSONResponse
-> ValueSchema NamedSwaggerDoc JSONResponse
forall doc doc' a b.
HasObject doc doc' =>
Text
-> SchemaP doc Object [Pair] a b -> SchemaP doc' Value Value a b
object Text
"JSONResponse" (SchemaP SwaggerDoc Object [Pair] JSONResponse JSONResponse
 -> ValueSchema NamedSwaggerDoc JSONResponse)
-> SchemaP SwaggerDoc Object [Pair] JSONResponse JSONResponse
-> ValueSchema NamedSwaggerDoc JSONResponse
forall a b. (a -> b) -> a -> b
$
      Status -> Value -> JSONResponse
JSONResponse
        (Status -> Value -> JSONResponse)
-> SchemaP SwaggerDoc Object [Pair] JSONResponse Status
-> SchemaP
     SwaggerDoc Object [Pair] JSONResponse (Value -> JSONResponse)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JSONResponse -> Status
status (JSONResponse -> Status)
-> SchemaP SwaggerDoc Object [Pair] Status Status
-> SchemaP SwaggerDoc Object [Pair] JSONResponse Status
forall (p :: * -> * -> *) a a' b.
Profunctor p =>
(a -> a') -> p a' b -> p a b
.= Text
-> SchemaP NamedSwaggerDoc Value Value Status Status
-> SchemaP SwaggerDoc Object [Pair] Status Status
forall doc' doc a b.
HasField doc' doc =>
Text
-> SchemaP doc' Value Value a b -> SchemaP doc Object [Pair] a b
field Text
"status" (Int -> Status
forall a. Enum a => Int -> a
toEnum (Int -> Status)
-> SchemaP NamedSwaggerDoc Value Value Status Int
-> SchemaP NamedSwaggerDoc Value Value Status Status
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Status -> Int
forall a. Enum a => a -> Int
fromEnum (Status -> Int)
-> SchemaP NamedSwaggerDoc Value Value Int Int
-> SchemaP NamedSwaggerDoc Value Value Status Int
forall (p :: * -> * -> *) a a' b.
Profunctor p =>
(a -> a') -> p a' b -> p a b
.= SchemaP NamedSwaggerDoc Value Value Int Int
forall a. ToSchema a => ValueSchema NamedSwaggerDoc a
schema))
        SchemaP
  SwaggerDoc Object [Pair] JSONResponse (Value -> JSONResponse)
-> SchemaP SwaggerDoc Object [Pair] JSONResponse Value
-> SchemaP SwaggerDoc Object [Pair] JSONResponse JSONResponse
forall a b.
SchemaP SwaggerDoc Object [Pair] JSONResponse (a -> b)
-> SchemaP SwaggerDoc Object [Pair] JSONResponse a
-> SchemaP SwaggerDoc Object [Pair] JSONResponse b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> JSONResponse -> Value
value (JSONResponse -> Value)
-> SchemaP SwaggerDoc Object [Pair] Value Value
-> SchemaP SwaggerDoc Object [Pair] JSONResponse Value
forall (p :: * -> * -> *) a a' b.
Profunctor p =>
(a -> a') -> p a' b -> p a b
.= Text
-> SchemaP SwaggerDoc Value Value Value Value
-> SchemaP SwaggerDoc Object [Pair] Value Value
forall doc' doc a b.
HasField doc' doc =>
Text
-> SchemaP doc' Value Value a b -> SchemaP doc Object [Pair] a b
field Text
"value" SchemaP SwaggerDoc Value Value Value Value
jsonValue

instance Exception JSONResponse

waiErrorToJSONResponse :: Wai.Error -> JSONResponse
waiErrorToJSONResponse :: Error -> JSONResponse
waiErrorToJSONResponse Error
e =
  JSONResponse
    { $sel:status:JSONResponse :: Status
status = Error -> Status
Wai.code Error
e,
      $sel:value:JSONResponse :: Value
value = Error -> Value
forall a. ToJSON a => a -> Value
toJSON Error
e
    }

jsonResponseToWai :: JSONResponse -> Response
jsonResponseToWai :: JSONResponse -> Response
jsonResponseToWai JSONResponse
r = Status -> ResponseHeaders -> ByteString -> Response
responseLBS JSONResponse
r.status [Header
jsonContent] (Value -> ByteString
forall a. ToJSON a => a -> ByteString
A.encode JSONResponse
r.value)