{-# OPTIONS_GHC -Wno-orphans #-}

-- | Swagger implementation of 'Body' trait.
module WebGear.Swagger.Trait.Body where

import Control.Lens ((&), (.~), (?~))
import Data.Proxy (Proxy (..))
import Data.Swagger hiding (Response)
import Data.Swagger.Declare (runDeclare)
import Data.Text (Text)
import WebGear.Core.MIMETypes (MIMEType (..))
import WebGear.Core.Request (Request)
import WebGear.Core.Response (Response (..), ResponseBody)
import WebGear.Core.Trait (Get (..), Set (..), With)
import WebGear.Core.Trait.Body (Body (..), UnknownContentBody (..))
import WebGear.Swagger.Handler (
  DocNode (DocRequestBody, DocResponseBody),
  SwaggerHandler (..),
  singletonNode,
 )

instance (ToSchema val, MIMEType mt) => Get (SwaggerHandler m) (Body mt val) Request where
  {-# INLINE getTrait #-}
  getTrait :: Body mt val -> SwaggerHandler m (Request `With` ts) (Either Text val)
  getTrait :: forall (ts :: [*]).
Body mt val -> SwaggerHandler m (With Request ts) (Either Text val)
getTrait (Body mt
mt) =
    let mimeList :: MimeList
mimeList = [MediaType] -> MimeList
MimeList [mt -> MediaType
forall mt. MIMEType mt => mt -> MediaType
mimeType mt
mt]
        (Definitions Schema
defs, Referenced Schema
ref) = Declare (Definitions Schema) (Referenced Schema)
-> Definitions Schema -> (Definitions Schema, Referenced Schema)
forall d a. Declare d a -> d -> (d, a)
runDeclare (Proxy val -> Declare (Definitions Schema) (Referenced Schema)
forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) (Referenced Schema)
declareSchemaRef (Proxy val -> Declare (Definitions Schema) (Referenced Schema))
-> Proxy val -> Declare (Definitions Schema) (Referenced Schema)
forall a b. (a -> b) -> a -> b
$ forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @val) Definitions Schema
forall a. Monoid a => a
mempty
        body :: Param
body =
          forall a. Monoid a => a
mempty @Param
            Param -> (Param -> Param) -> Param
forall a b. a -> (a -> b) -> b
& (ParamAnySchema -> Identity ParamAnySchema)
-> Param -> Identity Param
forall s a. HasSchema s a => Lens' s a
Lens' Param ParamAnySchema
schema ((ParamAnySchema -> Identity ParamAnySchema)
 -> Param -> Identity Param)
-> ParamAnySchema -> Param -> Param
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Referenced Schema -> ParamAnySchema
ParamBody Referenced Schema
ref
            Param -> (Param -> Param) -> Param
forall a b. a -> (a -> b) -> b
& (Maybe Bool -> Identity (Maybe Bool)) -> Param -> Identity Param
forall s a. HasRequired s a => Lens' s a
Lens' Param (Maybe Bool)
required ((Maybe Bool -> Identity (Maybe Bool)) -> Param -> Identity Param)
-> Bool -> Param -> Param
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Bool
True
            Param -> (Param -> Param) -> Param
forall a b. a -> (a -> b) -> b
& (Text -> Identity Text) -> Param -> Identity Param
forall s a. HasName s a => Lens' s a
Lens' Param Text
name ((Text -> Identity Text) -> Param -> Identity Param)
-> Text -> Param -> Param
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Text
"body"
     in Tree DocNode
-> SwaggerHandler m (With Request ts) (Either Text val)
forall {k} {k1} {k2} (m :: k) (a :: k1) (b :: k2).
Tree DocNode -> SwaggerHandler m a b
SwaggerHandler (Tree DocNode
 -> SwaggerHandler m (With Request ts) (Either Text val))
-> Tree DocNode
-> SwaggerHandler m (With Request ts) (Either Text val)
forall a b. (a -> b) -> a -> b
$ DocNode -> Tree DocNode
forall a. a -> Tree a
singletonNode (Definitions Schema -> MimeList -> Param -> DocNode
DocRequestBody Definitions Schema
defs MimeList
mimeList Param
body)

instance (ToSchema val, MIMEType mt) => Set (SwaggerHandler m) (Body mt val) Response where
  {-# INLINE setTrait #-}
  setTrait ::
    Body mt val ->
    (Response `With` ts -> Response -> val -> Response `With` (Body mt val : ts)) ->
    SwaggerHandler m (Response `With` ts, val) (Response `With` (Body mt val : ts))
  setTrait :: forall (ts :: [*]).
Body mt val
-> (With Response ts
    -> Response -> val -> With Response (Body mt val : ts))
-> SwaggerHandler
     m (With Response ts, val) (With Response (Body mt val : ts))
setTrait (Body mt
mt) With Response ts
-> Response -> val -> With Response (Body mt val : ts)
_ =
    let mimeList :: MimeList
mimeList = [MediaType] -> MimeList
MimeList [mt -> MediaType
forall mt. MIMEType mt => mt -> MediaType
mimeType mt
mt]
        (Definitions Schema
defs, Referenced Schema
ref) = Declare (Definitions Schema) (Referenced Schema)
-> Definitions Schema -> (Definitions Schema, Referenced Schema)
forall d a. Declare d a -> d -> (d, a)
runDeclare (Proxy val -> Declare (Definitions Schema) (Referenced Schema)
forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) (Referenced Schema)
declareSchemaRef (Proxy val -> Declare (Definitions Schema) (Referenced Schema))
-> Proxy val -> Declare (Definitions Schema) (Referenced Schema)
forall a b. (a -> b) -> a -> b
$ forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @val) Definitions Schema
forall a. Monoid a => a
mempty
     in Tree DocNode
-> SwaggerHandler
     m (With Response ts, val) (With Response (Body mt val : ts))
forall {k} {k1} {k2} (m :: k) (a :: k1) (b :: k2).
Tree DocNode -> SwaggerHandler m a b
SwaggerHandler (Tree DocNode
 -> SwaggerHandler
      m (With Response ts, val) (With Response (Body mt val : ts)))
-> Tree DocNode
-> SwaggerHandler
     m (With Response ts, val) (With Response (Body mt val : ts))
forall a b. (a -> b) -> a -> b
$ DocNode -> Tree DocNode
forall a. a -> Tree a
singletonNode (Definitions Schema
-> MimeList -> Maybe (Referenced Schema) -> DocNode
DocResponseBody Definitions Schema
defs MimeList
mimeList (Referenced Schema -> Maybe (Referenced Schema)
forall a. a -> Maybe a
Just Referenced Schema
ref))

instance Set (SwaggerHandler m) UnknownContentBody Response where
  {-# INLINE setTrait #-}
  setTrait ::
    UnknownContentBody ->
    (Response `With` ts -> Response -> ResponseBody -> Response `With` (UnknownContentBody : ts)) ->
    SwaggerHandler m (Response `With` ts, ResponseBody) (Response `With` (UnknownContentBody : ts))
  setTrait :: forall (ts :: [*]).
UnknownContentBody
-> (With Response ts
    -> Response
    -> ResponseBody
    -> With Response (UnknownContentBody : ts))
-> SwaggerHandler
     m
     (With Response ts, ResponseBody)
     (With Response (UnknownContentBody : ts))
setTrait UnknownContentBody
UnknownContentBody With Response ts
-> Response
-> ResponseBody
-> With Response (UnknownContentBody : ts)
_ = Tree DocNode
-> SwaggerHandler
     m
     (With Response ts, ResponseBody)
     (With Response (UnknownContentBody : ts))
forall {k} {k1} {k2} (m :: k) (a :: k1) (b :: k2).
Tree DocNode -> SwaggerHandler m a b
SwaggerHandler (Tree DocNode
 -> SwaggerHandler
      m
      (With Response ts, ResponseBody)
      (With Response (UnknownContentBody : ts)))
-> Tree DocNode
-> SwaggerHandler
     m
     (With Response ts, ResponseBody)
     (With Response (UnknownContentBody : ts))
forall a b. (a -> b) -> a -> b
$ DocNode -> Tree DocNode
forall a. a -> Tree a
singletonNode (Definitions Schema
-> MimeList -> Maybe (Referenced Schema) -> DocNode
DocResponseBody Definitions Schema
forall a. Monoid a => a
mempty MimeList
forall a. Monoid a => a
mempty Maybe (Referenced Schema)
forall a. Maybe a
Nothing)