{-# OPTIONS_GHC -Wno-orphans #-}

-- | Swagger implementation of 'Header' trait.
module WebGear.Swagger.Trait.Header () where

import Control.Lens ((%~), (&), (.~), (<>~), (?~))
import Control.Monad.State.Strict (MonadState)
import qualified Data.HashMap.Strict.InsOrd as Map
import Data.Proxy (Proxy (Proxy))
import Data.String (fromString)
import Data.Swagger (
  Header,
  HeaderName,
  Param,
  ParamAnySchema (..),
  ParamLocation (..),
  ParamOtherSchema (..),
  Referenced (..),
  Response,
  Swagger,
  ToParamSchema (..),
  allOperations,
  description,
  headers,
  name,
  parameters,
  required,
  responses,
  schema,
 )
import Data.Swagger.Internal.Utils (swaggerMappend)
import Data.Text (Text)
import GHC.TypeLits (KnownSymbol, symbolVal)
import WebGear.Core.Handler (Description (..))
import WebGear.Core.Modifiers (Existence (..))
import WebGear.Core.Trait (Get (..), Set (..))
import qualified WebGear.Core.Trait.Header as WG
import WebGear.Swagger.Handler (Documentation, SwaggerHandler (..), consumeDescription)

instance
  ( KnownSymbol name
  , ToParamSchema val
  ) =>
  Get (SwaggerHandler m) (WG.RequestHeader Required ps name val)
  where
  {-# INLINE getTrait #-}
  getTrait :: forall (ts :: [*]).
Prerequisite (RequestHeader 'Required ps name val) ts =>
RequestHeader 'Required ps name val
-> SwaggerHandler
     m
     (With Request ts)
     (Either
        (Absence (RequestHeader 'Required ps name val))
        (Attribute (RequestHeader 'Required ps name val) Request))
getTrait RequestHeader 'Required ps name val
WG.RequestHeader = (Swagger -> State Documentation Swagger)
-> SwaggerHandler
     m
     (With Request ts)
     (Either
        (Absence (RequestHeader 'Required ps name val))
        (Attribute (RequestHeader 'Required ps name val) Request))
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
         (Absence (RequestHeader 'Required ps name val))
         (Attribute (RequestHeader 'Required ps name val) Request)))
-> (Swagger -> State Documentation Swagger)
-> SwaggerHandler
     m
     (With Request ts)
     (Either
        (Absence (RequestHeader 'Required ps name val))
        (Attribute (RequestHeader 'Required ps name val) Request))
forall a b. (a -> b) -> a -> b
$ Proxy name
-> Proxy val -> Bool -> Swagger -> State Documentation Swagger
forall (name :: Symbol) val (m :: * -> *).
(KnownSymbol name, ToParamSchema val,
 MonadState Documentation m) =>
Proxy name -> Proxy val -> Bool -> Swagger -> m Swagger
addRequestHeader (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @name) (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @val) Bool
True

instance
  ( KnownSymbol name
  , ToParamSchema val
  ) =>
  Get (SwaggerHandler m) (WG.RequestHeader Optional ps name val)
  where
  {-# INLINE getTrait #-}
  getTrait :: forall (ts :: [*]).
Prerequisite (RequestHeader 'Optional ps name val) ts =>
RequestHeader 'Optional ps name val
-> SwaggerHandler
     m
     (With Request ts)
     (Either
        (Absence (RequestHeader 'Optional ps name val))
        (Attribute (RequestHeader 'Optional ps name val) Request))
getTrait RequestHeader 'Optional ps name val
WG.RequestHeader = (Swagger -> State Documentation Swagger)
-> SwaggerHandler
     m
     (With Request ts)
     (Either
        (Absence (RequestHeader 'Optional ps name val))
        (Attribute (RequestHeader 'Optional ps name val) Request))
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
         (Absence (RequestHeader 'Optional ps name val))
         (Attribute (RequestHeader 'Optional ps name val) Request)))
-> (Swagger -> State Documentation Swagger)
-> SwaggerHandler
     m
     (With Request ts)
     (Either
        (Absence (RequestHeader 'Optional ps name val))
        (Attribute (RequestHeader 'Optional ps name val) Request))
forall a b. (a -> b) -> a -> b
$ Proxy name
-> Proxy val -> Bool -> Swagger -> State Documentation Swagger
forall (name :: Symbol) val (m :: * -> *).
(KnownSymbol name, ToParamSchema val,
 MonadState Documentation m) =>
Proxy name -> Proxy val -> Bool -> Swagger -> m Swagger
addRequestHeader (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @name) (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @val) Bool
False

instance (KnownSymbol name) => Set (SwaggerHandler m) (WG.ResponseHeader Required name val) where
  {-# INLINE setTrait #-}
  setTrait :: forall (ts :: [*]).
ResponseHeader 'Required name val
-> (With Response ts
    -> Response
    -> Attribute (ResponseHeader 'Required name val) Response
    -> With Response (ResponseHeader 'Required name val : ts))
-> SwaggerHandler
     m
     (With Response ts,
      Attribute (ResponseHeader 'Required name val) Response)
     (With Response (ResponseHeader 'Required name val : ts))
setTrait ResponseHeader 'Required name val
WG.ResponseHeader With Response ts
-> Response
-> Attribute (ResponseHeader 'Required name val) Response
-> With Response (ResponseHeader 'Required name val : ts)
_ = (Swagger -> State Documentation Swagger)
-> SwaggerHandler
     m
     (With Response ts,
      Attribute (ResponseHeader 'Required name val) Response)
     (With Response (ResponseHeader 'Required name 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,
       Attribute (ResponseHeader 'Required name val) Response)
      (With Response (ResponseHeader 'Required name val : ts)))
-> (Swagger -> State Documentation Swagger)
-> SwaggerHandler
     m
     (With Response ts,
      Attribute (ResponseHeader 'Required name val) Response)
     (With Response (ResponseHeader 'Required name val : ts))
forall a b. (a -> b) -> a -> b
$ Proxy name -> Proxy val -> Swagger -> State Documentation Swagger
forall {k} (name :: Symbol) (val :: k) (m :: * -> *).
(KnownSymbol name, MonadState Documentation m) =>
Proxy name -> Proxy val -> Swagger -> m Swagger
addResponseHeader (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @name) (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @val)

instance (KnownSymbol name) => Set (SwaggerHandler m) (WG.ResponseHeader Optional name val) where
  {-# INLINE setTrait #-}
  setTrait :: forall (ts :: [*]).
ResponseHeader 'Optional name val
-> (With Response ts
    -> Response
    -> Attribute (ResponseHeader 'Optional name val) Response
    -> With Response (ResponseHeader 'Optional name val : ts))
-> SwaggerHandler
     m
     (With Response ts,
      Attribute (ResponseHeader 'Optional name val) Response)
     (With Response (ResponseHeader 'Optional name val : ts))
setTrait ResponseHeader 'Optional name val
WG.ResponseHeader With Response ts
-> Response
-> Attribute (ResponseHeader 'Optional name val) Response
-> With Response (ResponseHeader 'Optional name val : ts)
_ = (Swagger -> State Documentation Swagger)
-> SwaggerHandler
     m
     (With Response ts,
      Attribute (ResponseHeader 'Optional name val) Response)
     (With Response (ResponseHeader 'Optional name 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,
       Attribute (ResponseHeader 'Optional name val) Response)
      (With Response (ResponseHeader 'Optional name val : ts)))
-> (Swagger -> State Documentation Swagger)
-> SwaggerHandler
     m
     (With Response ts,
      Attribute (ResponseHeader 'Optional name val) Response)
     (With Response (ResponseHeader 'Optional name val : ts))
forall a b. (a -> b) -> a -> b
$ Proxy name -> Proxy val -> Swagger -> State Documentation Swagger
forall {k} (name :: Symbol) (val :: k) (m :: * -> *).
(KnownSymbol name, MonadState Documentation m) =>
Proxy name -> Proxy val -> Swagger -> m Swagger
addResponseHeader (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @name) (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @val)

addRequestHeader ::
  forall name val m.
  (KnownSymbol name, ToParamSchema val, MonadState Documentation m) =>
  Proxy name ->
  Proxy val ->
  Bool ->
  Swagger ->
  m Swagger
addRequestHeader :: forall (name :: Symbol) val (m :: * -> *).
(KnownSymbol name, ToParamSchema val,
 MonadState Documentation m) =>
Proxy name -> Proxy val -> Bool -> Swagger -> m Swagger
addRequestHeader Proxy name
_ Proxy val
_ Bool
isRequired Swagger
doc = do
  Maybe Description
desc <- m (Maybe Description)
forall (m :: * -> *).
MonadState Documentation m =>
m (Maybe Description)
consumeDescription
  let param :: Param
param =
        (Param
forall a. Monoid a => a
mempty :: Param)
          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
.~ forall a. IsString a => String -> a
fromString @Text (Proxy name -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy name -> String) -> Proxy name -> String
forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @name)
          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
isRequired
          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
.~ ParamOtherSchema -> ParamAnySchema
ParamOther
              ( ParamOtherSchema
                  { _paramOtherSchemaIn :: ParamLocation
_paramOtherSchemaIn = ParamLocation
ParamHeader
                  , _paramOtherSchemaAllowEmptyValue :: Maybe Bool
_paramOtherSchemaAllowEmptyValue = Bool -> Maybe Bool
forall a. a -> Maybe a
Just (Bool -> Bool
not Bool
isRequired)
                  , _paramOtherSchemaParamSchema :: ParamSchema 'SwaggerKindParamOtherSchema
_paramOtherSchemaParamSchema = Proxy val -> ParamSchema 'SwaggerKindParamOtherSchema
forall a (t :: SwaggerKind (*)).
ToParamSchema a =>
Proxy a -> ParamSchema t
forall (t :: SwaggerKind (*)). Proxy val -> ParamSchema t
toParamSchema (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @val)
                  }
              )
          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 -> 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)
-> (([Referenced Param] -> Identity [Referenced Param])
    -> Operation -> Identity Operation)
-> ([Referenced Param] -> Identity [Referenced Param])
-> Swagger
-> Identity Swagger
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([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])
 -> Swagger -> Identity Swagger)
-> [Referenced Param] -> Swagger -> Swagger
forall a s t. Semigroup a => ASetter s t a a -> a -> s -> t
<>~ [Param -> Referenced Param
forall a. a -> Referenced a
Inline Param
param]

addResponseHeader ::
  forall name val m.
  (KnownSymbol name, MonadState Documentation m) =>
  Proxy name ->
  Proxy val ->
  Swagger ->
  m Swagger
addResponseHeader :: forall {k} (name :: Symbol) (val :: k) (m :: * -> *).
(KnownSymbol name, MonadState Documentation m) =>
Proxy name -> Proxy val -> Swagger -> m Swagger
addResponseHeader Proxy name
_ Proxy val
_ Swagger
doc = do
  Maybe Description
desc <- m (Maybe Description)
forall (m :: * -> *).
MonadState Documentation m =>
m (Maybe Description)
consumeDescription
  let headerName :: Text
headerName = forall a. IsString a => String -> a
fromString @HeaderName (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Proxy name -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy name -> String) -> Proxy name -> String
forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @name
      header :: Header
header = forall a. Monoid a => a
mempty @Header Header -> (Header -> Header) -> Header
forall a b. a -> (a -> b) -> b
& (Maybe Text -> Identity (Maybe Text)) -> Header -> Identity Header
forall s a. HasDescription s a => Lens' s a
Lens' Header (Maybe Text)
description ((Maybe Text -> Identity (Maybe Text))
 -> Header -> Identity Header)
-> Maybe Text -> Header -> Header
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
      resp :: Response
resp = forall a. Monoid a => a
mempty @Response Response -> (Response -> Response) -> Response
forall a b. a -> (a -> b) -> b
& (InsOrdHashMap Text Header -> Identity (InsOrdHashMap Text Header))
-> Response -> Identity Response
forall s a. HasHeaders s a => Lens' s a
Lens' Response (InsOrdHashMap Text Header)
headers ((InsOrdHashMap Text Header
  -> Identity (InsOrdHashMap Text Header))
 -> Response -> Identity Response)
-> InsOrdHashMap Text Header -> Response -> Response
forall a s t. Semigroup a => ASetter s t a a -> a -> s -> t
<>~ [(Text
headerName, Header
header)]
  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
$
    if Text
headerName Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"Content-Type"
      then Swagger
doc
      else 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)
-> ((InsOrdHashMap HttpStatusCode (Referenced Response)
     -> Identity (InsOrdHashMap HttpStatusCode (Referenced Response)))
    -> Operation -> Identity Operation)
-> (InsOrdHashMap HttpStatusCode (Referenced Response)
    -> Identity (InsOrdHashMap HttpStatusCode (Referenced Response)))
-> Swagger
-> Identity Swagger
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)))
 -> Swagger -> Identity Swagger)
-> (InsOrdHashMap HttpStatusCode (Referenced Response)
    -> InsOrdHashMap HttpStatusCode (Referenced Response))
-> Swagger
-> Swagger
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 -> Referenced Response
forall m. SwaggerMonoid m => m -> m -> m
`swaggerMappend` Response -> Referenced Response
forall a. a -> Referenced a
Inline Response
resp)