{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

-- | Provides orphan instances for Jordan servant combinators that allow the generation of documentation.
module Jordan.Servant.OpenApi where

import Control.Lens
import Data.OpenApi.Declare
import Data.OpenApi.Internal
import Data.OpenApi.Lens
import Data.OpenApi.Operation
import Data.OpenApi.ParamSchema
import Data.OpenApi.Schema
import Data.Proxy (Proxy (..))
import qualified Data.Text as T
import Data.Typeable
import GHC.TypeLits
import Jordan
import Jordan.OpenAPI
import Jordan.Servant
import Jordan.Types.JSONError
import Network.HTTP.Media
import Servant.API
import Servant.API.ContentTypes
import Servant.API.Modifiers
import Servant.OpenApi.Internal

instance (ToJSON a, Typeable a) => ToSchema (ViaJordan a) where
  declareNamedSchema :: Proxy (ViaJordan a) -> Declare (Definitions Schema) NamedSchema
declareNamedSchema (Proxy (ViaJordan a)
Proxy :: Proxy (ViaJordan a)) = Proxy a -> Declare (Definitions Schema) NamedSchema
forall a.
ToJSON a =>
Proxy a -> Declare (Definitions Schema) NamedSchema
getToNamed (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a)

instance forall a sub baseKey mods. (HasOpenApi sub, FromJSON a, KnownSymbol baseKey, SBoolI (FoldRequired mods)) => HasOpenApi (JordanQuery' baseKey mods a :> sub) where
  toOpenApi :: Proxy (JordanQuery' baseKey mods a :> sub) -> OpenApi
toOpenApi Proxy (JordanQuery' baseKey mods a :> sub)
_ =
    Proxy sub -> OpenApi
forall k (api :: k). HasOpenApi api => Proxy api -> OpenApi
toOpenApi (Proxy sub
forall k (t :: k). Proxy t
Proxy :: Proxy sub)
      OpenApi -> (OpenApi -> OpenApi) -> OpenApi
forall a b. a -> (a -> b) -> b
& Param -> OpenApi -> OpenApi
addParam Param
parameter
      OpenApi -> (OpenApi -> OpenApi) -> OpenApi
forall a b. a -> (a -> b) -> b
& (Response -> Response -> Response)
-> HttpStatusCode
-> Declare (Definitions Schema) Response
-> OpenApi
-> OpenApi
setResponseWith Response -> Response -> Response
forall a. Semigroup a => a -> a -> a
(<>) HttpStatusCode
400 Declare (Definitions Schema) Response
queryErrorResponse
      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
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
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)
    where
      (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 a -> Declare (Definitions Schema) (Referenced Schema)
forall a.
FromJSON a =>
Proxy a -> Declare (Definitions Schema) (Referenced Schema)
getFromRef (Proxy a
forall k (t :: k). Proxy t
Proxy @a)) Definitions Schema
forall a. Monoid a => a
mempty
      parameter :: Param
      parameter :: Param
parameter =
        Param
forall a. Monoid a => a
mempty
          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
name ((Text -> Identity Text) -> Param -> Identity Param)
-> Text -> Param -> Param
forall s t a b. ASetter s t a b -> b -> s -> t
.~ String -> Text
T.pack (Proxy baseKey -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy baseKey -> String) -> Proxy baseKey -> String
forall a b. (a -> b) -> a -> b
$ Proxy baseKey
forall k (t :: k). Proxy t
Proxy @baseKey)
          Param -> (Param -> Param) -> Param
forall a b. a -> (a -> b) -> b
& (ParamLocation -> Identity ParamLocation)
-> Param -> Identity Param
forall s a. HasIn s a => Lens' s a
in_ ((ParamLocation -> Identity ParamLocation)
 -> Param -> Identity Param)
-> ParamLocation -> Param -> Param
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ParamLocation
ParamQuery
          Param -> (Param -> Param) -> Param
forall a b. a -> (a -> b) -> b
& (Maybe Style -> Identity (Maybe Style)) -> Param -> Identity Param
forall s a. HasStyle s a => Lens' s a
style ((Maybe Style -> Identity (Maybe Style))
 -> Param -> Identity Param)
-> Style -> Param -> Param
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Style
StyleDeepObject
          Param -> (Param -> Param) -> Param
forall a b. a -> (a -> b) -> b
& (Maybe Bool -> Identity (Maybe Bool)) -> Param -> Identity Param
forall s a. HasExplode s a => Lens' s a
explode ((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
& (Maybe Bool -> Identity (Maybe Bool)) -> Param -> Identity Param
forall s a. HasAllowReserved s a => Lens' s a
allowReserved ((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
False
          Param -> (Param -> Param) -> Param
forall a b. a -> (a -> b) -> b
& (Maybe (Referenced Schema) -> Identity (Maybe (Referenced Schema)))
-> Param -> Identity Param
forall s a. HasSchema s a => Lens' s a
schema ((Maybe (Referenced Schema)
  -> Identity (Maybe (Referenced Schema)))
 -> Param -> Identity Param)
-> Referenced Schema -> Param -> Param
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ 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
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
      queryErrorResponse :: Declare (Definitions Schema) Response
queryErrorResponse =
        Response -> Declare (Definitions Schema) Response
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Response -> Declare (Definitions Schema) Response)
-> Response -> Declare (Definitions Schema) Response
forall a b. (a -> b) -> a -> b
$
          Response
forall a. Monoid a => a
mempty 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
content ((InsOrdHashMap MediaType MediaTypeObject
  -> Identity (InsOrdHashMap MediaType MediaTypeObject))
 -> Response -> Identity Response)
-> ((Maybe (Referenced Schema)
     -> Identity (Maybe (Referenced Schema)))
    -> InsOrdHashMap MediaType MediaTypeObject
    -> Identity (InsOrdHashMap MediaType MediaTypeObject))
-> (Maybe (Referenced Schema)
    -> Identity (Maybe (Referenced Schema)))
-> Response
-> Identity Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (InsOrdHashMap MediaType MediaTypeObject)
-> Lens'
     (InsOrdHashMap MediaType MediaTypeObject)
     (Maybe (IxValue (InsOrdHashMap MediaType MediaTypeObject)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at (ByteString
"application" ByteString -> ByteString -> MediaType
// ByteString
"json+haskell-jordan-query-error") ((Maybe (IxValue (InsOrdHashMap MediaType MediaTypeObject))
  -> Identity
       (Maybe (IxValue (InsOrdHashMap MediaType MediaTypeObject))))
 -> InsOrdHashMap MediaType MediaTypeObject
 -> Identity (InsOrdHashMap MediaType MediaTypeObject))
-> ((Maybe (Referenced Schema)
     -> Identity (Maybe (Referenced Schema)))
    -> Maybe (IxValue (InsOrdHashMap MediaType MediaTypeObject))
    -> Identity
         (Maybe (IxValue (InsOrdHashMap MediaType MediaTypeObject))))
-> (Maybe (Referenced Schema)
    -> Identity (Maybe (Referenced Schema)))
-> InsOrdHashMap MediaType MediaTypeObject
-> Identity (InsOrdHashMap MediaType MediaTypeObject)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IxValue (InsOrdHashMap MediaType MediaTypeObject)
-> Iso'
     (Maybe (IxValue (InsOrdHashMap MediaType MediaTypeObject)))
     (IxValue (InsOrdHashMap MediaType MediaTypeObject))
forall a. Eq a => a -> Iso' (Maybe a) a
non IxValue (InsOrdHashMap MediaType MediaTypeObject)
forall a. Monoid a => a
mempty ((IxValue (InsOrdHashMap MediaType MediaTypeObject)
  -> Identity (IxValue (InsOrdHashMap MediaType MediaTypeObject)))
 -> Maybe (IxValue (InsOrdHashMap MediaType MediaTypeObject))
 -> Identity
      (Maybe (IxValue (InsOrdHashMap MediaType MediaTypeObject))))
-> ((Maybe (Referenced Schema)
     -> Identity (Maybe (Referenced Schema)))
    -> IxValue (InsOrdHashMap MediaType MediaTypeObject)
    -> Identity (IxValue (InsOrdHashMap MediaType MediaTypeObject)))
-> (Maybe (Referenced Schema)
    -> Identity (Maybe (Referenced Schema)))
-> Maybe (IxValue (InsOrdHashMap MediaType MediaTypeObject))
-> Identity
     (Maybe (IxValue (InsOrdHashMap MediaType MediaTypeObject)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe (Referenced Schema) -> Identity (Maybe (Referenced Schema)))
-> IxValue (InsOrdHashMap MediaType MediaTypeObject)
-> Identity (IxValue (InsOrdHashMap MediaType MediaTypeObject))
forall s a. HasSchema s a => Lens' s a
schema ((Maybe (Referenced Schema)
  -> Identity (Maybe (Referenced Schema)))
 -> Response -> Identity Response)
-> Referenced Schema -> Response -> Response
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Schema -> Referenced Schema
forall a. a -> Referenced a
Inline Schema
s
      s :: Schema
      s :: Schema
s = Proxy String -> Schema
forall a. ToParamSchema a => Proxy a -> Schema
toParamSchema (Proxy String
forall k (t :: k). Proxy t
Proxy :: Proxy String)
      isRequired :: Bool
isRequired = case SBoolI (FoldRequired mods) => SBool (FoldRequired mods)
forall (b :: Bool). SBoolI b => SBool b
sbool @(FoldRequired mods) of
        SBool (FoldRequired mods)
STrue -> Bool
True
        SBool (FoldRequired mods)
SFalse -> Bool
False

errorResponse :: Declare (Definitions Schema) Response
errorResponse :: Declare (Definitions Schema) Response
errorResponse = do
  Referenced Schema
ref <- Proxy JSONError -> Declare (Definitions Schema) (Referenced Schema)
forall a.
ToJSON a =>
Proxy a -> Declare (Definitions Schema) (Referenced Schema)
getToRef (Proxy JSONError
forall k (t :: k). Proxy t
Proxy :: Proxy JSONError)
  Response -> Declare (Definitions Schema) Response
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Response -> Declare (Definitions Schema) Response)
-> Response -> Declare (Definitions Schema) Response
forall a b. (a -> b) -> a -> b
$ Response
forall a. Monoid a => a
mempty 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
content ((InsOrdHashMap MediaType MediaTypeObject
  -> Identity (InsOrdHashMap MediaType MediaTypeObject))
 -> Response -> Identity Response)
-> ((Maybe (Referenced Schema)
     -> Identity (Maybe (Referenced Schema)))
    -> InsOrdHashMap MediaType MediaTypeObject
    -> Identity (InsOrdHashMap MediaType MediaTypeObject))
-> (Maybe (Referenced Schema)
    -> Identity (Maybe (Referenced Schema)))
-> Response
-> Identity Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (InsOrdHashMap MediaType MediaTypeObject)
-> Lens'
     (InsOrdHashMap MediaType MediaTypeObject)
     (Maybe (IxValue (InsOrdHashMap MediaType MediaTypeObject)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at (ByteString
"application" ByteString -> ByteString -> MediaType
// ByteString
"json+haskell-servant-body-error") ((Maybe MediaTypeObject -> Identity (Maybe MediaTypeObject))
 -> InsOrdHashMap MediaType MediaTypeObject
 -> Identity (InsOrdHashMap MediaType MediaTypeObject))
-> ((Maybe (Referenced Schema)
     -> Identity (Maybe (Referenced Schema)))
    -> Maybe MediaTypeObject -> Identity (Maybe MediaTypeObject))
-> (Maybe (Referenced Schema)
    -> Identity (Maybe (Referenced Schema)))
-> InsOrdHashMap MediaType MediaTypeObject
-> Identity (InsOrdHashMap MediaType MediaTypeObject)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MediaTypeObject -> Iso' (Maybe MediaTypeObject) MediaTypeObject
forall a. Eq a => a -> Iso' (Maybe a) a
non MediaTypeObject
forall a. Monoid a => a
mempty ((MediaTypeObject -> Identity MediaTypeObject)
 -> Maybe MediaTypeObject -> Identity (Maybe MediaTypeObject))
-> ((Maybe (Referenced Schema)
     -> Identity (Maybe (Referenced Schema)))
    -> MediaTypeObject -> Identity MediaTypeObject)
-> (Maybe (Referenced Schema)
    -> Identity (Maybe (Referenced Schema)))
-> Maybe MediaTypeObject
-> Identity (Maybe MediaTypeObject)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe (Referenced Schema) -> Identity (Maybe (Referenced Schema)))
-> MediaTypeObject -> Identity MediaTypeObject
forall s a. HasSchema s a => Lens' s a
schema ((Maybe (Referenced Schema)
  -> Identity (Maybe (Referenced Schema)))
 -> Response -> Identity Response)
-> Referenced Schema -> Response -> Response
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Referenced Schema
ref

instance forall a sub. (HasOpenApi sub, FromJSON a) => HasOpenApi (ReportingRequestBody a :> sub) where
  toOpenApi :: Proxy (ReportingRequestBody a :> sub) -> OpenApi
toOpenApi Proxy (ReportingRequestBody a :> sub)
_ =
    Proxy sub -> OpenApi
forall k (api :: k). HasOpenApi api => Proxy api -> OpenApi
toOpenApi (Proxy sub
forall k (t :: k). Proxy t
Proxy :: Proxy sub)
      OpenApi -> (OpenApi -> OpenApi) -> OpenApi
forall a b. a -> (a -> b) -> b
& RequestBody -> OpenApi -> OpenApi
addRequestBody RequestBody
reqBody
      OpenApi -> (OpenApi -> OpenApi) -> OpenApi
forall a b. a -> (a -> b) -> b
& OpenApi -> OpenApi
addErrorResponse
      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
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
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)
    where
      (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 a -> Declare (Definitions Schema) (Referenced Schema)
forall a.
FromJSON a =>
Proxy a -> Declare (Definitions Schema) (Referenced Schema)
getFromRef (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a)) Definitions Schema
forall a. Monoid a => a
mempty
      RequestBody
reqBody :: RequestBody =
        RequestBody
forall a. Monoid a => a
mempty
          { _requestBodyContent :: InsOrdHashMap MediaType MediaTypeObject
_requestBodyContent = [(ByteString
"application" ByteString -> ByteString -> MediaType
// ByteString
"json", MediaTypeObject
mediaType)]
          }
      MediaTypeObject
mediaType :: MediaTypeObject =
        MediaTypeObject
forall a. Monoid a => a
mempty
          { _mediaTypeObjectSchema :: Maybe (Referenced Schema)
_mediaTypeObjectSchema = Referenced Schema -> Maybe (Referenced Schema)
forall a. a -> Maybe a
Just Referenced Schema
ref
          }
      addErrorResponse :: OpenApi -> OpenApi
addErrorResponse = (Response -> Response -> Response)
-> HttpStatusCode
-> Declare (Definitions Schema) Response
-> OpenApi
-> OpenApi
setResponseWith Response -> Response -> Response
forall a. Semigroup a => a -> a -> a
(<>) HttpStatusCode
400 Declare (Definitions Schema) Response
errorResponse