{-# 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 #-}
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