{-# LANGUAGE GeneralizedNewtypeDeriving #-}

-- This file is part of the Wire Server implementation.
--
-- Copyright (C) 2022 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 Wire.API.RawJson where

import Control.Lens
import Data.OpenApi qualified as Swagger
import Imports
import Servant
import Test.QuickCheck
import Test.QuickCheck.Instances ()

-- | Wrap json content as plain 'LByteString'
-- This type is intended to be used to receive json content as 'LText'.
-- Warning: There is no validation of the json content. It may be any string.
newtype RawJson = RawJson {RawJson -> LByteString
rawJsonBytes :: LByteString}
  deriving (RawJson -> RawJson -> Bool
(RawJson -> RawJson -> Bool)
-> (RawJson -> RawJson -> Bool) -> Eq RawJson
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RawJson -> RawJson -> Bool
== :: RawJson -> RawJson -> Bool
$c/= :: RawJson -> RawJson -> Bool
/= :: RawJson -> RawJson -> Bool
Eq, Int -> RawJson -> ShowS
[RawJson] -> ShowS
RawJson -> String
(Int -> RawJson -> ShowS)
-> (RawJson -> String) -> ([RawJson] -> ShowS) -> Show RawJson
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RawJson -> ShowS
showsPrec :: Int -> RawJson -> ShowS
$cshow :: RawJson -> String
show :: RawJson -> String
$cshowList :: [RawJson] -> ShowS
showList :: [RawJson] -> ShowS
Show)
  deriving newtype (Gen RawJson
Gen RawJson -> (RawJson -> [RawJson]) -> Arbitrary RawJson
RawJson -> [RawJson]
forall a. Gen a -> (a -> [a]) -> Arbitrary a
$carbitrary :: Gen RawJson
arbitrary :: Gen RawJson
$cshrink :: RawJson -> [RawJson]
shrink :: RawJson -> [RawJson]
Arbitrary)

instance {-# OVERLAPPING #-} MimeUnrender JSON RawJson where
  mimeUnrender :: Proxy JSON -> LByteString -> Either String RawJson
mimeUnrender Proxy JSON
_ = RawJson -> Either String RawJson
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RawJson -> Either String RawJson)
-> (LByteString -> RawJson) -> LByteString -> Either String RawJson
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LByteString -> RawJson
RawJson

instance MimeRender JSON RawJson where
  mimeRender :: Proxy JSON -> RawJson -> LByteString
mimeRender Proxy JSON
_ = RawJson -> LByteString
rawJsonBytes

instance Swagger.ToSchema RawJson where
  declareNamedSchema :: Proxy RawJson -> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy RawJson
_ =
    NamedSchema -> Declare (Definitions Schema) NamedSchema
forall a. a -> DeclareT (Definitions Schema) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NamedSchema -> Declare (Definitions Schema) NamedSchema)
-> (Schema -> NamedSchema)
-> Schema
-> Declare (Definitions Schema) NamedSchema
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Text -> Schema -> NamedSchema
Swagger.NamedSchema (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"RawJson") (Schema -> Declare (Definitions Schema) NamedSchema)
-> Schema -> Declare (Definitions Schema) NamedSchema
forall a b. (a -> b) -> a -> b
$
      Schema
forall a. Monoid a => a
mempty
        Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe OpenApiType -> Identity (Maybe OpenApiType))
-> Schema -> Identity Schema
forall s a. HasType s a => Lens' s a
Lens' Schema (Maybe OpenApiType)
Swagger.type_ ((Maybe OpenApiType -> Identity (Maybe OpenApiType))
 -> Schema -> Identity Schema)
-> OpenApiType -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ OpenApiType
Swagger.OpenApiObject
        Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe Text -> Identity (Maybe Text)) -> Schema -> Identity Schema
forall s a. HasDescription s a => Lens' s a
Lens' Schema (Maybe Text)
Swagger.description
          ((Maybe Text -> Identity (Maybe Text))
 -> Schema -> Identity Schema)
-> Text -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Text
"Any JSON as plain string. The object structure is not specified in this schema."