{-# OPTIONS_GHC -Wno-orphans #-}

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

import Control.Lens ((%~), (&), (.~), (?~), (^.))
import Control.Monad.State.Strict (MonadState)
import qualified Data.HashMap.Strict.InsOrd as Map
import Data.Proxy (Proxy (..))
import Data.Swagger (
  Definitions,
  MimeList (..),
  Param,
  ParamAnySchema (..),
  Referenced (..),
  Response,
  Schema,
  Swagger,
  ToSchema,
  allOperations,
  consumes,
  declareSchemaRef,
  definitions,
  description,
  name,
  parameters,
  paths,
  produces,
  required,
  responses,
  schema,
 )
import Data.Swagger.Declare (runDeclare)
import Data.Swagger.Internal.Utils (swaggerMappend)
import Data.Text (Text)
import WebGear.Core.Handler (Description (..))
import WebGear.Core.MIMETypes (MIMEType (..))
import WebGear.Core.Request (Request)
import qualified WebGear.Core.Response as WG
import WebGear.Core.Trait (Get (..), Set (..), With)
import WebGear.Core.Trait.Body (Body (..), UnknownContentBody (..))
import WebGear.Swagger.Handler (
  Documentation (..),
  SwaggerHandler (..),
  addRootPath,
  consumeDescription,
 )

instance (ToSchema val, MIMEType mt) => Get (SwaggerHandler m) (Body mt val) 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) =
    (Swagger -> State Documentation Swagger)
-> SwaggerHandler m (With Request ts) (Either Text val)
forall {k} {k1} {k2} (m :: k) (a :: k1) (b :: k2).
(Swagger -> State Documentation Swagger) -> SwaggerHandler m a b
SwaggerHandler ((Swagger -> State Documentation Swagger)
 -> SwaggerHandler m (With Request ts) (Either Text val))
-> (Swagger -> State Documentation Swagger)
-> SwaggerHandler m (With Request ts) (Either Text val)
forall a b. (a -> b) -> a -> b
$ \Swagger
doc -> do
      Maybe Description
desc <- StateT Documentation Identity (Maybe Description)
forall (m :: * -> *).
MonadState Documentation m =>
m (Maybe Description)
consumeDescription
      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"
              Param -> (Param -> Param) -> Param
forall a b. a -> (a -> b) -> b
& (Maybe Text -> Identity (Maybe Text)) -> Param -> Identity Param
forall s a. HasDescription s a => Lens' s a
Lens' Param (Maybe Text)
description ((Maybe Text -> Identity (Maybe Text)) -> Param -> Identity Param)
-> Maybe Text -> Param -> Param
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (Description -> Text) -> Maybe Description -> Maybe Text
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Description -> Text
getDescription Maybe Description
desc
      Swagger -> State Documentation Swagger
forall a. a -> StateT Documentation Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Swagger -> State Documentation Swagger)
-> Swagger -> State Documentation Swagger
forall a b. (a -> b) -> a -> b
$
        Swagger
doc
          Swagger -> (Swagger -> Swagger) -> Swagger
forall a b. a -> (a -> b) -> b
& (Operation -> Identity Operation) -> Swagger -> Identity Swagger
Traversal' Swagger Operation
allOperations
            ((Operation -> Identity Operation) -> Swagger -> Identity Swagger)
-> (Operation -> Operation) -> Swagger -> Swagger
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ ( \Operation
op ->
                  Operation
op
                    Operation -> (Operation -> Operation) -> Operation
forall a b. a -> (a -> b) -> b
& ([Referenced Param] -> Identity [Referenced Param])
-> Operation -> Identity Operation
forall s a. HasParameters s a => Lens' s a
Lens' Operation [Referenced Param]
parameters (([Referenced Param] -> Identity [Referenced Param])
 -> Operation -> Identity Operation)
-> ([Referenced Param] -> [Referenced Param])
-> Operation
-> Operation
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Param -> Referenced Param
forall a. a -> Referenced a
Inline Param
body Referenced Param -> [Referenced Param] -> [Referenced Param]
forall a. a -> [a] -> [a]
:)
                    Operation -> (Operation -> Operation) -> Operation
forall a b. a -> (a -> b) -> b
& (Maybe MimeList -> Identity (Maybe MimeList))
-> Operation -> Identity Operation
forall s a. HasConsumes s a => Lens' s a
Lens' Operation (Maybe MimeList)
consumes ((Maybe MimeList -> Identity (Maybe MimeList))
 -> Operation -> Identity Operation)
-> (Maybe MimeList -> Maybe MimeList) -> Operation -> Operation
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ MimeList -> Maybe MimeList
forall a. a -> Maybe a
Just (MimeList -> Maybe MimeList)
-> (Maybe MimeList -> MimeList) -> Maybe MimeList -> Maybe MimeList
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MimeList -> (MimeList -> MimeList) -> Maybe MimeList -> MimeList
forall b a. b -> (a -> b) -> Maybe a -> b
maybe MimeList
mimeList (MimeList -> MimeList -> MimeList
forall a. Semigroup a => a -> a -> a
<> MimeList
mimeList)
               )
          Swagger -> (Swagger -> Swagger) -> Swagger
forall a b. a -> (a -> b) -> b
& (Definitions Schema -> Identity (Definitions Schema))
-> Swagger -> Identity Swagger
forall s a. HasDefinitions s a => Lens' s a
Lens' Swagger (Definitions Schema)
definitions ((Definitions Schema -> Identity (Definitions Schema))
 -> Swagger -> Identity Swagger)
-> (Definitions Schema -> Definitions Schema) -> Swagger -> Swagger
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Definitions Schema -> Definitions Schema -> Definitions Schema
forall a. Semigroup a => a -> a -> a
<> Definitions Schema
defs)

instance (ToSchema val, MIMEType mt) => Set (SwaggerHandler m) (Body mt val) where
  {-# INLINE setTrait #-}
  setTrait ::
    Body mt val ->
    (WG.Response `With` ts -> WG.Response -> val -> WG.Response `With` (Body mt val : ts)) ->
    SwaggerHandler m (WG.Response `With` ts, val) (WG.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 (Swagger -> State Documentation Swagger)
-> SwaggerHandler
     m (With Response ts, val) (With Response (Body mt val : ts))
forall {k} {k1} {k2} (m :: k) (a :: k1) (b :: k2).
(Swagger -> State Documentation Swagger) -> SwaggerHandler m a b
SwaggerHandler ((Swagger -> State Documentation Swagger)
 -> SwaggerHandler
      m (With Response ts, val) (With Response (Body mt val : ts)))
-> (Swagger -> State Documentation Swagger)
-> SwaggerHandler
     m (With Response ts, val) (With Response (Body mt val : ts))
forall a b. (a -> b) -> a -> b
$ Definitions Schema
-> MimeList
-> Maybe (Referenced Schema)
-> Swagger
-> State Documentation Swagger
forall (m :: * -> *).
MonadState Documentation m =>
Definitions Schema
-> MimeList -> Maybe (Referenced Schema) -> Swagger -> m Swagger
addResponseBody Definitions Schema
defs MimeList
mimeList (Referenced Schema -> Maybe (Referenced Schema)
forall a. a -> Maybe a
Just Referenced Schema
ref)

instance Set (SwaggerHandler m) UnknownContentBody where
  {-# INLINE setTrait #-}
  setTrait ::
    UnknownContentBody ->
    (WG.Response `With` ts -> WG.Response -> WG.ResponseBody -> WG.Response `With` (UnknownContentBody : ts)) ->
    SwaggerHandler m (WG.Response `With` ts, WG.ResponseBody) (WG.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)
_ = (Swagger -> State Documentation Swagger)
-> SwaggerHandler
     m
     (With Response ts, ResponseBody)
     (With Response (UnknownContentBody : ts))
forall {k} {k1} {k2} (m :: k) (a :: k1) (b :: k2).
(Swagger -> State Documentation Swagger) -> SwaggerHandler m a b
SwaggerHandler ((Swagger -> State Documentation Swagger)
 -> SwaggerHandler
      m
      (With Response ts, ResponseBody)
      (With Response (UnknownContentBody : ts)))
-> (Swagger -> State Documentation Swagger)
-> SwaggerHandler
     m
     (With Response ts, ResponseBody)
     (With Response (UnknownContentBody : ts))
forall a b. (a -> b) -> a -> b
$ Definitions Schema
-> MimeList
-> Maybe (Referenced Schema)
-> Swagger
-> State Documentation Swagger
forall (m :: * -> *).
MonadState Documentation m =>
Definitions Schema
-> MimeList -> Maybe (Referenced Schema) -> Swagger -> m Swagger
addResponseBody Definitions Schema
forall a. Monoid a => a
mempty MimeList
forall a. Monoid a => a
mempty Maybe (Referenced Schema)
forall a. Maybe a
Nothing

addResponseBody ::
  (MonadState Documentation m) =>
  Definitions Schema ->
  MimeList ->
  Maybe (Referenced Schema) ->
  Swagger ->
  m Swagger
addResponseBody :: forall (m :: * -> *).
MonadState Documentation m =>
Definitions Schema
-> MimeList -> Maybe (Referenced Schema) -> Swagger -> m Swagger
addResponseBody Definitions Schema
defs MimeList
mimeList Maybe (Referenced Schema)
respSchema Swagger
doc = do
  Maybe Description
desc <- m (Maybe Description)
forall (m :: * -> *).
MonadState Documentation m =>
m (Maybe Description)
consumeDescription

  let addDescription :: Referenced Response -> Referenced Response
      addDescription :: Referenced Response -> Referenced Response
addDescription (Ref Reference
r) = Reference -> Referenced Response
forall a. Reference -> Referenced a
Ref Reference
r
      addDescription (Inline Response
r) =
        case Maybe Description
desc of
          Maybe Description
Nothing -> Response -> Referenced Response
forall a. a -> Referenced a
Inline Response
r
          Just (Description Text
d) -> Response -> Referenced Response
forall a. a -> Referenced a
Inline (Response
r Response -> (Response -> Response) -> Response
forall a b. a -> (a -> b) -> b
& (Text -> Identity Text) -> Response -> Identity Response
forall s a. HasDescription s a => Lens' s a
Lens' Response Text
description ((Text -> Identity Text) -> Response -> Identity Response)
-> Text -> Response -> Response
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Text
d)

  let resp :: Response
resp = forall a. Monoid a => a
mempty @Response Response -> (Response -> Response) -> Response
forall a b. a -> (a -> b) -> b
& (Maybe (Referenced Schema) -> Identity (Maybe (Referenced Schema)))
-> Response -> Identity Response
forall s a. HasSchema s a => Lens' s a
Lens' Response (Maybe (Referenced Schema))
schema ((Maybe (Referenced Schema)
  -> Identity (Maybe (Referenced Schema)))
 -> Response -> Identity Response)
-> Maybe (Referenced Schema) -> Response -> Response
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Maybe (Referenced Schema)
respSchema
      doc' :: Swagger
doc' = if InsOrdHashMap FilePath PathItem -> Bool
forall k v. InsOrdHashMap k v -> Bool
Map.null (Swagger
doc Swagger
-> Getting
     (InsOrdHashMap FilePath PathItem)
     Swagger
     (InsOrdHashMap FilePath PathItem)
-> InsOrdHashMap FilePath PathItem
forall s a. s -> Getting a s a -> a
^. Getting
  (InsOrdHashMap FilePath PathItem)
  Swagger
  (InsOrdHashMap FilePath PathItem)
forall s a. HasPaths s a => Lens' s a
Lens' Swagger (InsOrdHashMap FilePath PathItem)
paths) then Swagger -> Swagger
addRootPath Swagger
doc else Swagger
doc

  Swagger -> m Swagger
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Swagger -> m Swagger) -> Swagger -> m Swagger
forall a b. (a -> b) -> a -> b
$
    Swagger
doc'
      Swagger -> (Swagger -> Swagger) -> Swagger
forall a b. a -> (a -> b) -> b
& (Operation -> Identity Operation) -> Swagger -> Identity Swagger
Traversal' Swagger Operation
allOperations
        ((Operation -> Identity Operation) -> Swagger -> Identity Swagger)
-> (Operation -> Operation) -> Swagger -> Swagger
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ ( \Operation
op ->
              Operation
op
                Operation -> (Operation -> Operation) -> Operation
forall a b. a -> (a -> b) -> b
& (Responses -> Identity Responses)
-> Operation -> Identity Operation
forall s a. HasResponses s a => Lens' s a
Lens' Operation Responses
responses ((Responses -> Identity Responses)
 -> Operation -> Identity Operation)
-> ((InsOrdHashMap HttpStatusCode (Referenced Response)
     -> Identity (InsOrdHashMap HttpStatusCode (Referenced Response)))
    -> Responses -> Identity Responses)
-> (InsOrdHashMap HttpStatusCode (Referenced Response)
    -> Identity (InsOrdHashMap HttpStatusCode (Referenced Response)))
-> Operation
-> Identity Operation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (InsOrdHashMap HttpStatusCode (Referenced Response)
 -> Identity (InsOrdHashMap HttpStatusCode (Referenced Response)))
-> Responses -> Identity Responses
forall s a. HasResponses s a => Lens' s a
Lens'
  Responses (InsOrdHashMap HttpStatusCode (Referenced Response))
responses ((InsOrdHashMap HttpStatusCode (Referenced Response)
  -> Identity (InsOrdHashMap HttpStatusCode (Referenced Response)))
 -> Operation -> Identity Operation)
-> (InsOrdHashMap HttpStatusCode (Referenced Response)
    -> InsOrdHashMap HttpStatusCode (Referenced Response))
-> Operation
-> Operation
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Referenced Response -> Referenced Response)
-> InsOrdHashMap HttpStatusCode (Referenced Response)
-> InsOrdHashMap HttpStatusCode (Referenced Response)
forall v1 v2 k.
(v1 -> v2) -> InsOrdHashMap k v1 -> InsOrdHashMap k v2
Map.map (Referenced Response -> Referenced Response
addDescription (Referenced Response -> Referenced Response)
-> (Referenced Response -> Referenced Response)
-> Referenced Response
-> Referenced Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Referenced Response -> Referenced Response -> Referenced Response
forall m. SwaggerMonoid m => m -> m -> m
`swaggerMappend` Response -> Referenced Response
forall a. a -> Referenced a
Inline Response
resp))
                Operation -> (Operation -> Operation) -> Operation
forall a b. a -> (a -> b) -> b
& (Maybe MimeList -> Identity (Maybe MimeList))
-> Operation -> Identity Operation
forall s a. HasProduces s a => Lens' s a
Lens' Operation (Maybe MimeList)
produces ((Maybe MimeList -> Identity (Maybe MimeList))
 -> Operation -> Identity Operation)
-> (Maybe MimeList -> Maybe MimeList) -> Operation -> Operation
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ MimeList -> Maybe MimeList
forall a. a -> Maybe a
Just (MimeList -> Maybe MimeList)
-> (Maybe MimeList -> MimeList) -> Maybe MimeList -> Maybe MimeList
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MimeList -> (MimeList -> MimeList) -> Maybe MimeList -> MimeList
forall b a. b -> (a -> b) -> Maybe a -> b
maybe MimeList
mimeList (MimeList -> MimeList -> MimeList
forall m. SwaggerMonoid m => m -> m -> m
`swaggerMappend` MimeList
mimeList)
           )
      Swagger -> (Swagger -> Swagger) -> Swagger
forall a b. a -> (a -> b) -> b
& (Definitions Schema -> Identity (Definitions Schema))
-> Swagger -> Identity Swagger
forall s a. HasDefinitions s a => Lens' s a
Lens' Swagger (Definitions Schema)
definitions ((Definitions Schema -> Identity (Definitions Schema))
 -> Swagger -> Identity Swagger)
-> (Definitions Schema -> Definitions Schema) -> Swagger -> Swagger
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Definitions Schema -> Definitions Schema -> Definitions Schema
forall a. Semigroup a => a -> a -> a
<> Definitions Schema
defs)