{-# OPTIONS_GHC -Wno-orphans #-}

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

import Control.Lens ((%~), (&), (.~), (<>~), (?~), (^.))
import Control.Monad.State.Strict (MonadState)
import qualified Data.HashMap.Strict.InsOrd as Map
import Data.OpenApi (
  Definitions,
  MediaTypeObject,
  OpenApi,
  Referenced (..),
  RequestBody,
  Response,
  Schema,
  ToSchema,
  allOperations,
  components,
  content,
  declareSchemaRef,
  description,
  paths,
  requestBody,
  responses,
  schema,
  schemas,
 )
import Data.OpenApi.Declare (runDeclare)
import Data.OpenApi.Internal.Utils (swaggerMappend)
import Data.Proxy (Proxy (..))
import Data.Text (Text)
import GHC.Exts (fromList)
import Network.HTTP.Media.MediaType (MediaType)
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.OpenApi.Handler (
  Documentation (..),
  OpenApiHandler (..),
  addRootPath,
  consumeDescription,
 )

instance (ToSchema val, MIMEType mt) => Get (OpenApiHandler m) (Body mt val) where
  {-# INLINE getTrait #-}
  getTrait :: Body mt val -> OpenApiHandler m (Request `With` ts) (Either Text val)
  getTrait :: forall (ts :: [*]).
Body mt val -> OpenApiHandler m (With Request ts) (Either Text val)
getTrait (Body mt
mt) =
    (OpenApi -> State Documentation OpenApi)
-> OpenApiHandler m (With Request ts) (Either Text val)
forall {k} {k1} {k2} (m :: k) (a :: k1) (b :: k2).
(OpenApi -> State Documentation OpenApi) -> OpenApiHandler m a b
OpenApiHandler ((OpenApi -> State Documentation OpenApi)
 -> OpenApiHandler m (With Request ts) (Either Text val))
-> (OpenApi -> State Documentation OpenApi)
-> OpenApiHandler m (With Request ts) (Either Text val)
forall a b. (a -> b) -> a -> b
$ \OpenApi
doc -> do
      Maybe Description
desc <- StateT Documentation Identity (Maybe Description)
forall (m :: * -> *).
MonadState Documentation m =>
m (Maybe Description)
consumeDescription
      let mediaType :: MediaType
mediaType = 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 :: RequestBody
body =
            (forall a. Monoid a => a
mempty @RequestBody)
              RequestBody -> (RequestBody -> RequestBody) -> RequestBody
forall a b. a -> (a -> b) -> b
& (InsOrdHashMap MediaType MediaTypeObject
 -> Identity (InsOrdHashMap MediaType MediaTypeObject))
-> RequestBody -> Identity RequestBody
forall s a. HasContent s a => Lens' s a
Lens' RequestBody (InsOrdHashMap MediaType MediaTypeObject)
content ((InsOrdHashMap MediaType MediaTypeObject
  -> Identity (InsOrdHashMap MediaType MediaTypeObject))
 -> RequestBody -> Identity RequestBody)
-> InsOrdHashMap MediaType MediaTypeObject
-> RequestBody
-> RequestBody
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Item (InsOrdHashMap MediaType MediaTypeObject)]
-> InsOrdHashMap MediaType MediaTypeObject
forall l. IsList l => [Item l] -> l
fromList [(MediaType
mediaType, forall a. Monoid a => a
mempty @MediaTypeObject MediaTypeObject
-> (MediaTypeObject -> MediaTypeObject) -> MediaTypeObject
forall a b. a -> (a -> b) -> b
& (Maybe (Referenced Schema) -> Identity (Maybe (Referenced Schema)))
-> MediaTypeObject -> Identity MediaTypeObject
forall s a. HasSchema s a => Lens' s a
Lens' MediaTypeObject (Maybe (Referenced Schema))
schema ((Maybe (Referenced Schema)
  -> Identity (Maybe (Referenced Schema)))
 -> MediaTypeObject -> Identity MediaTypeObject)
-> Referenced Schema -> MediaTypeObject -> MediaTypeObject
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Referenced Schema
ref)]
              RequestBody -> (RequestBody -> RequestBody) -> RequestBody
forall a b. a -> (a -> b) -> b
& (Maybe Text -> Identity (Maybe Text))
-> RequestBody -> Identity RequestBody
forall s a. HasDescription s a => Lens' s a
Lens' RequestBody (Maybe Text)
description ((Maybe Text -> Identity (Maybe Text))
 -> RequestBody -> Identity RequestBody)
-> Maybe Text -> RequestBody -> RequestBody
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
      OpenApi -> State Documentation OpenApi
forall a. a -> StateT Documentation Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (OpenApi -> State Documentation OpenApi)
-> OpenApi -> State Documentation OpenApi
forall a b. (a -> b) -> a -> b
$
        OpenApi
doc
          OpenApi -> (OpenApi -> OpenApi) -> OpenApi
forall a b. a -> (a -> b) -> b
& (Operation -> Identity Operation) -> OpenApi -> Identity OpenApi
Traversal' OpenApi Operation
allOperations ((Operation -> Identity Operation) -> OpenApi -> Identity OpenApi)
-> ((Maybe (Referenced RequestBody)
     -> Identity (Maybe (Referenced RequestBody)))
    -> Operation -> Identity Operation)
-> (Maybe (Referenced RequestBody)
    -> Identity (Maybe (Referenced RequestBody)))
-> OpenApi
-> Identity OpenApi
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe (Referenced RequestBody)
 -> Identity (Maybe (Referenced RequestBody)))
-> Operation -> Identity Operation
forall s a. HasRequestBody s a => Lens' s a
Lens' Operation (Maybe (Referenced RequestBody))
requestBody ((Maybe (Referenced RequestBody)
  -> Identity (Maybe (Referenced RequestBody)))
 -> OpenApi -> Identity OpenApi)
-> Referenced RequestBody -> OpenApi -> OpenApi
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ RequestBody -> Referenced RequestBody
forall a. a -> Referenced a
Inline RequestBody
body
          OpenApi -> (OpenApi -> OpenApi) -> OpenApi
forall a b. a -> (a -> b) -> b
& (Components -> Identity Components) -> OpenApi -> Identity OpenApi
forall s a. HasComponents s a => Lens' s a
Lens' OpenApi Components
components ((Components -> Identity Components)
 -> OpenApi -> Identity OpenApi)
-> ((Definitions Schema -> Identity (Definitions Schema))
    -> Components -> Identity Components)
-> (Definitions Schema -> Identity (Definitions Schema))
-> OpenApi
-> Identity OpenApi
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Definitions Schema -> Identity (Definitions Schema))
-> Components -> Identity Components
forall s a. HasSchemas s a => Lens' s a
Lens' Components (Definitions Schema)
schemas ((Definitions Schema -> Identity (Definitions Schema))
 -> OpenApi -> Identity OpenApi)
-> (Definitions Schema -> Definitions Schema) -> OpenApi -> OpenApi
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 (OpenApiHandler 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)) ->
    OpenApiHandler 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))
-> OpenApiHandler
     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 mediaType :: MediaType
mediaType = 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 :: MediaTypeObject
body = forall a. Monoid a => a
mempty @MediaTypeObject MediaTypeObject
-> (MediaTypeObject -> MediaTypeObject) -> MediaTypeObject
forall a b. a -> (a -> b) -> b
& (Maybe (Referenced Schema) -> Identity (Maybe (Referenced Schema)))
-> MediaTypeObject -> Identity MediaTypeObject
forall s a. HasSchema s a => Lens' s a
Lens' MediaTypeObject (Maybe (Referenced Schema))
schema ((Maybe (Referenced Schema)
  -> Identity (Maybe (Referenced Schema)))
 -> MediaTypeObject -> Identity MediaTypeObject)
-> Referenced Schema -> MediaTypeObject -> MediaTypeObject
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Referenced Schema
ref
     in (OpenApi -> State Documentation OpenApi)
-> OpenApiHandler
     m (With Response ts, val) (With Response (Body mt val : ts))
forall {k} {k1} {k2} (m :: k) (a :: k1) (b :: k2).
(OpenApi -> State Documentation OpenApi) -> OpenApiHandler m a b
OpenApiHandler ((OpenApi -> State Documentation OpenApi)
 -> OpenApiHandler
      m (With Response ts, val) (With Response (Body mt val : ts)))
-> (OpenApi -> State Documentation OpenApi)
-> OpenApiHandler
     m (With Response ts, val) (With Response (Body mt val : ts))
forall a b. (a -> b) -> a -> b
$ Definitions Schema
-> InsOrdHashMap MediaType MediaTypeObject
-> OpenApi
-> State Documentation OpenApi
forall (m :: * -> *).
MonadState Documentation m =>
Definitions Schema
-> InsOrdHashMap MediaType MediaTypeObject -> OpenApi -> m OpenApi
addResponseBody Definitions Schema
defs ([Item (InsOrdHashMap MediaType MediaTypeObject)]
-> InsOrdHashMap MediaType MediaTypeObject
forall l. IsList l => [Item l] -> l
fromList [(MediaType
mediaType, MediaTypeObject
body)])

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

addResponseBody ::
  (MonadState Documentation m) =>
  Definitions Schema ->
  Map.InsOrdHashMap MediaType MediaTypeObject ->
  OpenApi ->
  m OpenApi
addResponseBody :: forall (m :: * -> *).
MonadState Documentation m =>
Definitions Schema
-> InsOrdHashMap MediaType MediaTypeObject -> OpenApi -> m OpenApi
addResponseBody Definitions Schema
defs InsOrdHashMap MediaType MediaTypeObject
mediaTypes OpenApi
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
& (InsOrdHashMap MediaType MediaTypeObject
 -> Identity (InsOrdHashMap MediaType MediaTypeObject))
-> Response -> Identity Response
forall s a. HasContent s a => Lens' s a
Lens' Response (InsOrdHashMap MediaType MediaTypeObject)
content ((InsOrdHashMap MediaType MediaTypeObject
  -> Identity (InsOrdHashMap MediaType MediaTypeObject))
 -> Response -> Identity Response)
-> InsOrdHashMap MediaType MediaTypeObject -> Response -> Response
forall a s t. Semigroup a => ASetter s t a a -> a -> s -> t
<>~ InsOrdHashMap MediaType MediaTypeObject
mediaTypes
      doc' :: OpenApi
doc' = if InsOrdHashMap FilePath PathItem -> Bool
forall k v. InsOrdHashMap k v -> Bool
Map.null (OpenApi
doc OpenApi
-> Getting
     (InsOrdHashMap FilePath PathItem)
     OpenApi
     (InsOrdHashMap FilePath PathItem)
-> InsOrdHashMap FilePath PathItem
forall s a. s -> Getting a s a -> a
^. Getting
  (InsOrdHashMap FilePath PathItem)
  OpenApi
  (InsOrdHashMap FilePath PathItem)
forall s a. HasPaths s a => Lens' s a
Lens' OpenApi (InsOrdHashMap FilePath PathItem)
paths) then OpenApi -> OpenApi
addRootPath OpenApi
doc else OpenApi
doc

  OpenApi -> m OpenApi
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (OpenApi -> m OpenApi) -> OpenApi -> m OpenApi
forall a b. (a -> b) -> a -> b
$
    OpenApi
doc'
      OpenApi -> (OpenApi -> OpenApi) -> OpenApi
forall a b. a -> (a -> b) -> b
& (Operation -> Identity Operation) -> OpenApi -> Identity OpenApi
Traversal' OpenApi Operation
allOperations ((Operation -> Identity Operation) -> OpenApi -> Identity OpenApi)
-> ((InsOrdHashMap HttpStatusCode (Referenced Response)
     -> Identity (InsOrdHashMap HttpStatusCode (Referenced Response)))
    -> Operation -> Identity Operation)
-> (InsOrdHashMap HttpStatusCode (Referenced Response)
    -> Identity (InsOrdHashMap HttpStatusCode (Referenced Response)))
-> OpenApi
-> Identity OpenApi
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (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)))
 -> OpenApi -> Identity OpenApi)
-> (InsOrdHashMap HttpStatusCode (Referenced Response)
    -> InsOrdHashMap HttpStatusCode (Referenced Response))
-> OpenApi
-> OpenApi
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))
      OpenApi -> (OpenApi -> OpenApi) -> OpenApi
forall a b. a -> (a -> b) -> b
& (Components -> Identity Components) -> OpenApi -> Identity OpenApi
forall s a. HasComponents s a => Lens' s a
Lens' OpenApi Components
components ((Components -> Identity Components)
 -> OpenApi -> Identity OpenApi)
-> ((Definitions Schema -> Identity (Definitions Schema))
    -> Components -> Identity Components)
-> (Definitions Schema -> Identity (Definitions Schema))
-> OpenApi
-> Identity OpenApi
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Definitions Schema -> Identity (Definitions Schema))
-> Components -> Identity Components
forall s a. HasSchemas s a => Lens' s a
Lens' Components (Definitions Schema)
schemas ((Definitions Schema -> Identity (Definitions Schema))
 -> OpenApi -> Identity OpenApi)
-> (Definitions Schema -> Definitions Schema) -> OpenApi -> OpenApi
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)