{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Data.JsonSpec.OpenApi (
toOpenApiSchema,
EncodingSchema(..),
DecodingSchema(..),
) where
import Control.Lens (At(at), (&), over, set)
import Data.Aeson (ToJSON(toJSON))
import Data.JsonSpec (HasJsonDecodingSpec(DecodingSpec),
HasJsonEncodingSpec(EncodingSpec), Specification(JsonArray, JsonBool,
JsonDateTime, JsonEither, JsonInt, JsonNum, JsonObject, JsonString,
JsonTag))
import Data.OpenApi (AdditionalProperties(AdditionalPropertiesAllowed),
HasAdditionalProperties(additionalProperties), HasEnum(enum_),
HasFormat(format), HasItems(items), HasOneOf(oneOf),
HasProperties(properties), HasRequired(required), HasType(type_),
NamedSchema(NamedSchema), OpenApiItems(OpenApiItemsObject),
OpenApiType(OpenApiArray, OpenApiBoolean, OpenApiInteger,
OpenApiNumber, OpenApiObject, OpenApiString), Referenced(Inline),
ToSchema(declareNamedSchema), Schema)
import Data.String (IsString(fromString))
import Data.Text (Text)
import Data.Typeable (Proxy(Proxy), Typeable)
import GHC.TypeLits (KnownSymbol, symbolVal)
import Prelude (Applicative(pure), Bool(False), Maybe(Just, Nothing),
Monoid(mempty), ($))
toOpenApiSchema
:: (Internal spec)
=> Proxy (spec :: Specification)
-> Schema
toOpenApiSchema :: forall (spec :: Specification).
Internal spec =>
Proxy spec -> Schema
toOpenApiSchema = Proxy spec -> Schema
forall (spec :: Specification).
Internal spec =>
Proxy spec -> Schema
internal
class Internal (spec :: Specification) where
internal :: Proxy spec -> Schema
instance (KnownSymbol tag) => Internal ('JsonTag tag) where
internal :: Proxy ('JsonTag tag) -> Schema
internal Proxy ('JsonTag tag)
_ =
Schema
forall a. Monoid a => a
mempty Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& ASetter Schema Schema (Maybe [Value]) (Maybe [Value])
-> Maybe [Value] -> Schema -> Schema
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter Schema Schema (Maybe [Value]) (Maybe [Value])
forall s a. HasEnum s a => Lens' s a
Lens' Schema (Maybe [Value])
enum_ ([Value] -> Maybe [Value]
forall a. a -> Maybe a
Just [Text -> Value
forall a. ToJSON a => a -> Value
toJSON (forall (a :: Symbol) b. (IsString b, KnownSymbol a) => b
sym @tag :: Text)])
instance Internal 'JsonString where
internal :: Proxy 'JsonString -> Schema
internal Proxy 'JsonString
_ =
Schema
forall a. Monoid a => a
mempty Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& ASetter Schema Schema (Maybe OpenApiType) (Maybe OpenApiType)
-> Maybe OpenApiType -> Schema -> Schema
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter Schema Schema (Maybe OpenApiType) (Maybe OpenApiType)
forall s a. HasType s a => Lens' s a
Lens' Schema (Maybe OpenApiType)
type_ (OpenApiType -> Maybe OpenApiType
forall a. a -> Maybe a
Just OpenApiType
OpenApiString)
instance (Internal left, Internal right) => Internal ('JsonEither left right) where
internal :: Proxy ('JsonEither left right) -> Schema
internal Proxy ('JsonEither left right)
_ =
Schema
forall a. Monoid a => a
mempty
Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& ASetter
Schema
Schema
(Maybe [Referenced Schema])
(Maybe [Referenced Schema])
-> Maybe [Referenced Schema] -> Schema -> Schema
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter
Schema
Schema
(Maybe [Referenced Schema])
(Maybe [Referenced Schema])
forall s a. HasOneOf s a => Lens' s a
Lens' Schema (Maybe [Referenced Schema])
oneOf ([Referenced Schema] -> Maybe [Referenced Schema]
forall a. a -> Maybe a
Just
[ Schema -> Referenced Schema
forall a. a -> Referenced a
Inline (Proxy left -> Schema
forall (spec :: Specification).
Internal spec =>
Proxy spec -> Schema
internal (forall {k} (t :: k). Proxy t
forall (t :: Specification). Proxy t
Proxy @left))
, Schema -> Referenced Schema
forall a. a -> Referenced a
Inline (Proxy right -> Schema
forall (spec :: Specification).
Internal spec =>
Proxy spec -> Schema
internal (forall {k} (t :: k). Proxy t
forall (t :: Specification). Proxy t
Proxy @right))
]
)
instance Internal 'JsonNum where
internal :: Proxy 'JsonNum -> Schema
internal Proxy 'JsonNum
_ =
Schema
forall a. Monoid a => a
mempty Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& ASetter Schema Schema (Maybe OpenApiType) (Maybe OpenApiType)
-> Maybe OpenApiType -> Schema -> Schema
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter Schema Schema (Maybe OpenApiType) (Maybe OpenApiType)
forall s a. HasType s a => Lens' s a
Lens' Schema (Maybe OpenApiType)
type_ (OpenApiType -> Maybe OpenApiType
forall a. a -> Maybe a
Just OpenApiType
OpenApiNumber)
instance Internal 'JsonInt where
internal :: Proxy 'JsonInt -> Schema
internal Proxy 'JsonInt
_ =
Schema
forall a. Monoid a => a
mempty Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& ASetter Schema Schema (Maybe OpenApiType) (Maybe OpenApiType)
-> Maybe OpenApiType -> Schema -> Schema
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter Schema Schema (Maybe OpenApiType) (Maybe OpenApiType)
forall s a. HasType s a => Lens' s a
Lens' Schema (Maybe OpenApiType)
type_ (OpenApiType -> Maybe OpenApiType
forall a. a -> Maybe a
Just OpenApiType
OpenApiInteger)
instance Internal ('JsonObject '[]) where
internal :: Proxy ('JsonObject '[]) -> Schema
internal Proxy ('JsonObject '[])
_ =
Schema
forall a. Monoid a => a
mempty
Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& ASetter Schema Schema (Maybe OpenApiType) (Maybe OpenApiType)
-> Maybe OpenApiType -> Schema -> Schema
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter Schema Schema (Maybe OpenApiType) (Maybe OpenApiType)
forall s a. HasType s a => Lens' s a
Lens' Schema (Maybe OpenApiType)
type_ (OpenApiType -> Maybe OpenApiType
forall a. a -> Maybe a
Just OpenApiType
OpenApiObject)
Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& ASetter
Schema
Schema
(Maybe AdditionalProperties)
(Maybe AdditionalProperties)
-> Maybe AdditionalProperties -> Schema -> Schema
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter
Schema
Schema
(Maybe AdditionalProperties)
(Maybe AdditionalProperties)
forall s a. HasAdditionalProperties s a => Lens' s a
Lens' Schema (Maybe AdditionalProperties)
additionalProperties (AdditionalProperties -> Maybe AdditionalProperties
forall a. a -> Maybe a
Just (Bool -> AdditionalProperties
AdditionalPropertiesAllowed Bool
False))
instance (KnownSymbol key, Internal spec, Internal ('JsonObject more)) => Internal ('JsonObject ( '(key, spec) : more )) where
internal :: Proxy ('JsonObject ('(key, spec) : more)) -> Schema
internal Proxy ('JsonObject ('(key, spec) : more))
_ =
let
propertyName :: Text
propertyName :: Text
propertyName = forall (a :: Symbol) b. (IsString b, KnownSymbol a) => b
sym @key
propertySchema :: Schema
propertySchema :: Schema
propertySchema = Proxy spec -> Schema
forall (spec :: Specification).
Internal spec =>
Proxy spec -> Schema
internal (forall {k} (t :: k). Proxy t
forall (t :: Specification). Proxy t
Proxy @spec)
in
Proxy ('JsonObject more) -> Schema
forall (spec :: Specification).
Internal spec =>
Proxy spec -> Schema
internal (forall {k} (t :: k). Proxy t
forall (t :: Specification). Proxy t
Proxy @('JsonObject more))
Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& ASetter
Schema
Schema
(InsOrdHashMap Text (Referenced Schema))
(InsOrdHashMap Text (Referenced Schema))
-> (InsOrdHashMap Text (Referenced Schema)
-> InsOrdHashMap Text (Referenced Schema))
-> Schema
-> Schema
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter
Schema
Schema
(InsOrdHashMap Text (Referenced Schema))
(InsOrdHashMap Text (Referenced Schema))
forall s a. HasProperties s a => Lens' s a
Lens' Schema (InsOrdHashMap Text (Referenced Schema))
properties (ASetter
(InsOrdHashMap Text (Referenced Schema))
(InsOrdHashMap Text (Referenced Schema))
(Maybe (IxValue (InsOrdHashMap Text (Referenced Schema))))
(Maybe (Referenced Schema))
-> Maybe (Referenced Schema)
-> InsOrdHashMap Text (Referenced Schema)
-> InsOrdHashMap Text (Referenced Schema)
forall s t a b. ASetter s t a b -> b -> s -> t
set (Index (InsOrdHashMap Text (Referenced Schema))
-> Lens'
(InsOrdHashMap Text (Referenced Schema))
(Maybe (IxValue (InsOrdHashMap Text (Referenced Schema))))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Text
Index (InsOrdHashMap Text (Referenced Schema))
propertyName) (Referenced Schema -> Maybe (Referenced Schema)
forall a. a -> Maybe a
Just (Schema -> Referenced Schema
forall a. a -> Referenced a
Inline Schema
propertySchema)))
Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& ASetter Schema Schema [Text] [Text]
-> ([Text] -> [Text]) -> Schema -> Schema
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter Schema Schema [Text] [Text]
forall s a. HasRequired s a => Lens' s a
Lens' Schema [Text]
required (Text
propertyNameText -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:)
instance (Internal spec) => Internal ('JsonArray spec) where
internal :: Proxy ('JsonArray spec) -> Schema
internal Proxy ('JsonArray spec)
_ =
let
elementSchema :: Schema
elementSchema :: Schema
elementSchema = Proxy spec -> Schema
forall (spec :: Specification).
Internal spec =>
Proxy spec -> Schema
internal (forall {k} (t :: k). Proxy t
forall (t :: Specification). Proxy t
Proxy @spec)
in
Schema
forall a. Monoid a => a
mempty
Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& ASetter Schema Schema (Maybe OpenApiType) (Maybe OpenApiType)
-> Maybe OpenApiType -> Schema -> Schema
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter Schema Schema (Maybe OpenApiType) (Maybe OpenApiType)
forall s a. HasType s a => Lens' s a
Lens' Schema (Maybe OpenApiType)
type_ (OpenApiType -> Maybe OpenApiType
forall a. a -> Maybe a
Just OpenApiType
OpenApiArray)
Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& ASetter Schema Schema (Maybe OpenApiItems) (Maybe OpenApiItems)
-> Maybe OpenApiItems -> Schema -> Schema
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter Schema Schema (Maybe OpenApiItems) (Maybe OpenApiItems)
forall s a. HasItems s a => Lens' s a
Lens' Schema (Maybe OpenApiItems)
items (OpenApiItems -> Maybe OpenApiItems
forall a. a -> Maybe a
Just (Referenced Schema -> OpenApiItems
OpenApiItemsObject (Schema -> Referenced Schema
forall a. a -> Referenced a
Inline Schema
elementSchema)))
instance Internal 'JsonBool where
internal :: Proxy 'JsonBool -> Schema
internal Proxy 'JsonBool
_ =
Schema
forall a. Monoid a => a
mempty Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& ASetter Schema Schema (Maybe OpenApiType) (Maybe OpenApiType)
-> Maybe OpenApiType -> Schema -> Schema
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter Schema Schema (Maybe OpenApiType) (Maybe OpenApiType)
forall s a. HasType s a => Lens' s a
Lens' Schema (Maybe OpenApiType)
type_ (OpenApiType -> Maybe OpenApiType
forall a. a -> Maybe a
Just OpenApiType
OpenApiBoolean)
instance Internal 'JsonDateTime where
internal :: Proxy 'JsonDateTime -> Schema
internal Proxy 'JsonDateTime
_ =
Schema
forall a. Monoid a => a
mempty
Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& ASetter Schema Schema (Maybe OpenApiType) (Maybe OpenApiType)
-> Maybe OpenApiType -> Schema -> Schema
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter Schema Schema (Maybe OpenApiType) (Maybe OpenApiType)
forall s a. HasType s a => Lens' s a
Lens' Schema (Maybe OpenApiType)
type_ (OpenApiType -> Maybe OpenApiType
forall a. a -> Maybe a
Just OpenApiType
OpenApiString)
Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& ASetter Schema Schema (Maybe Text) (Maybe Text)
-> Maybe Text -> Schema -> Schema
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter Schema Schema (Maybe Text) (Maybe Text)
forall s a. HasFormat s a => Lens' s a
Lens' Schema (Maybe Text)
format (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"date-time")
newtype EncodingSchema a =
EncodingSchema {forall a. EncodingSchema a -> a
unEncodingSchema :: a}
instance (Typeable a, Internal (EncodingSpec a)) => ToSchema (EncodingSchema a) where
declareNamedSchema :: Proxy (EncodingSchema a)
-> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy (EncodingSchema a)
_ =
NamedSchema -> Declare (Definitions Schema) NamedSchema
forall a. a -> DeclareT (Definitions Schema) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Text -> Schema -> NamedSchema
NamedSchema Maybe Text
forall a. Maybe a
Nothing (Proxy (EncodingSpec a) -> Schema
forall (spec :: Specification).
Internal spec =>
Proxy spec -> Schema
toOpenApiSchema (forall {k} (t :: k). Proxy t
forall (t :: Specification). Proxy t
Proxy @(EncodingSpec a))))
newtype DecodingSchema a =
DecodingSchema {forall a. DecodingSchema a -> a
unDecodingSchema :: a}
instance (Typeable a, Internal (DecodingSpec a)) => ToSchema (DecodingSchema a) where
declareNamedSchema :: Proxy (DecodingSchema a)
-> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy (DecodingSchema a)
_ =
NamedSchema -> Declare (Definitions Schema) NamedSchema
forall a. a -> DeclareT (Definitions Schema) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Text -> Schema -> NamedSchema
NamedSchema Maybe Text
forall a. Maybe a
Nothing (Proxy (DecodingSpec a) -> Schema
forall (spec :: Specification).
Internal spec =>
Proxy spec -> Schema
toOpenApiSchema (forall {k} (t :: k). Proxy t
forall (t :: Specification). Proxy t
Proxy @(DecodingSpec a))))
sym
:: forall a b.
( IsString b
, KnownSymbol a
)
=> b
sym :: forall (a :: Symbol) b. (IsString b, KnownSymbol a) => b
sym = String -> b
forall a. IsString a => String -> a
fromString (String -> b) -> String -> b
forall a b. (a -> b) -> a -> b
$ Proxy a -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @a)