json-spec-openapi 0.1.0.3 → 0.2.0.0
raw patch · 3 files changed
+475/−181 lines, 3 filesdep +insert-ordered-containersPVP ok
version bump matches the API change (PVP)
Dependencies added: insert-ordered-containers
API changes (from Hackage documentation)
- Data.JsonSpec.OpenApi: instance (Data.JsonSpec.OpenApi.Internal left, Data.JsonSpec.OpenApi.Internal right) => Data.JsonSpec.OpenApi.Internal ('Data.JsonSpec.Spec.JsonEither left right)
- Data.JsonSpec.OpenApi: instance (Data.Typeable.Internal.Typeable a, Data.JsonSpec.OpenApi.Internal (Data.JsonSpec.Decode.DecodingSpec a)) => Data.OpenApi.Internal.Schema.ToSchema (Data.JsonSpec.OpenApi.DecodingSchema a)
- Data.JsonSpec.OpenApi: instance (Data.Typeable.Internal.Typeable a, Data.JsonSpec.OpenApi.Internal (Data.JsonSpec.Encode.EncodingSpec a)) => Data.OpenApi.Internal.Schema.ToSchema (Data.JsonSpec.OpenApi.EncodingSchema a)
- Data.JsonSpec.OpenApi: instance (GHC.TypeLits.KnownSymbol key, Data.JsonSpec.OpenApi.Internal spec, Data.JsonSpec.OpenApi.Internal ('Data.JsonSpec.Spec.JsonObject more)) => Data.JsonSpec.OpenApi.Internal ('Data.JsonSpec.Spec.JsonObject ('(key, spec) : more))
- Data.JsonSpec.OpenApi: instance Data.JsonSpec.OpenApi.Internal 'Data.JsonSpec.Spec.JsonBool
- Data.JsonSpec.OpenApi: instance Data.JsonSpec.OpenApi.Internal 'Data.JsonSpec.Spec.JsonDateTime
- Data.JsonSpec.OpenApi: instance Data.JsonSpec.OpenApi.Internal 'Data.JsonSpec.Spec.JsonInt
- Data.JsonSpec.OpenApi: instance Data.JsonSpec.OpenApi.Internal 'Data.JsonSpec.Spec.JsonNum
- Data.JsonSpec.OpenApi: instance Data.JsonSpec.OpenApi.Internal 'Data.JsonSpec.Spec.JsonString
- Data.JsonSpec.OpenApi: instance Data.JsonSpec.OpenApi.Internal ('Data.JsonSpec.Spec.JsonObject '[])
- Data.JsonSpec.OpenApi: instance Data.JsonSpec.OpenApi.Internal spec => Data.JsonSpec.OpenApi.Internal ('Data.JsonSpec.Spec.JsonArray spec)
- Data.JsonSpec.OpenApi: instance GHC.TypeLits.KnownSymbol tag => Data.JsonSpec.OpenApi.Internal ('Data.JsonSpec.Spec.JsonTag tag)
+ Data.JsonSpec.OpenApi: class Schemaable (spec :: Specification)
+ Data.JsonSpec.OpenApi: instance (Data.JsonSpec.OpenApi.Defs defs, Data.JsonSpec.OpenApi.Schemaable spec) => Data.JsonSpec.OpenApi.Schemaable ('Data.JsonSpec.Spec.JsonLet defs spec)
+ Data.JsonSpec.OpenApi: instance (Data.JsonSpec.OpenApi.Defs defs, GHC.TypeLits.KnownSymbol name) => Data.JsonSpec.OpenApi.Refable ('Data.JsonSpec.Spec.JsonLet defs ('Data.JsonSpec.Spec.JsonRef name))
+ Data.JsonSpec.OpenApi: instance (Data.JsonSpec.OpenApi.Defs more, Data.JsonSpec.OpenApi.Schemaable spec, GHC.TypeLits.KnownSymbol name) => Data.JsonSpec.OpenApi.Defs ('(name, spec) : more)
+ Data.JsonSpec.OpenApi: instance (Data.JsonSpec.OpenApi.Schemaable ('Data.JsonSpec.Spec.JsonObject more), Data.JsonSpec.OpenApi.Refable spec, GHC.TypeLits.KnownSymbol key) => Data.JsonSpec.OpenApi.Schemaable ('Data.JsonSpec.Spec.JsonObject ('(key, spec) : more))
+ Data.JsonSpec.OpenApi: instance (Data.JsonSpec.OpenApi.Schemaable (Data.JsonSpec.Decode.DecodingSpec a), Data.Typeable.Internal.Typeable a) => Data.OpenApi.Internal.Schema.ToSchema (Data.JsonSpec.OpenApi.DecodingSchema a)
+ Data.JsonSpec.OpenApi: instance (Data.JsonSpec.OpenApi.Schemaable (Data.JsonSpec.Encode.EncodingSpec a), Data.Typeable.Internal.Typeable a) => Data.OpenApi.Internal.Schema.ToSchema (Data.JsonSpec.OpenApi.EncodingSchema a)
+ Data.JsonSpec.OpenApi: instance (Data.JsonSpec.OpenApi.Schemaable left, Data.JsonSpec.OpenApi.Schemaable right) => Data.JsonSpec.OpenApi.Schemaable ('Data.JsonSpec.Spec.JsonEither left right)
+ Data.JsonSpec.OpenApi: instance (GHC.TypeLits.KnownSymbol name, Data.JsonSpec.OpenApi.Schemaable def, Data.JsonSpec.OpenApi.Schemaable ('Data.JsonSpec.Spec.JsonLet more ('Data.JsonSpec.Spec.JsonRef target))) => Data.JsonSpec.OpenApi.Schemaable ('Data.JsonSpec.Spec.JsonLet ('(name, def) : more) ('Data.JsonSpec.Spec.JsonRef target))
+ Data.JsonSpec.OpenApi: instance (GHC.TypeLits.KnownSymbol target, Data.JsonSpec.OpenApi.Schemaable def, Data.JsonSpec.OpenApi.Schemaable ('Data.JsonSpec.Spec.JsonLet more def)) => Data.JsonSpec.OpenApi.Schemaable ('Data.JsonSpec.Spec.JsonLet ('(target, def) : more) ('Data.JsonSpec.Spec.JsonRef target))
+ Data.JsonSpec.OpenApi: instance Data.JsonSpec.OpenApi.Defs '[]
+ Data.JsonSpec.OpenApi: instance Data.JsonSpec.OpenApi.Schemaable 'Data.JsonSpec.Spec.JsonBool
+ Data.JsonSpec.OpenApi: instance Data.JsonSpec.OpenApi.Schemaable 'Data.JsonSpec.Spec.JsonDateTime
+ Data.JsonSpec.OpenApi: instance Data.JsonSpec.OpenApi.Schemaable 'Data.JsonSpec.Spec.JsonInt
+ Data.JsonSpec.OpenApi: instance Data.JsonSpec.OpenApi.Schemaable 'Data.JsonSpec.Spec.JsonNum
+ Data.JsonSpec.OpenApi: instance Data.JsonSpec.OpenApi.Schemaable 'Data.JsonSpec.Spec.JsonString
+ Data.JsonSpec.OpenApi: instance Data.JsonSpec.OpenApi.Schemaable ('Data.JsonSpec.Spec.JsonObject '[])
+ Data.JsonSpec.OpenApi: instance Data.JsonSpec.OpenApi.Schemaable a => Data.JsonSpec.OpenApi.Refable a
+ Data.JsonSpec.OpenApi: instance Data.JsonSpec.OpenApi.Schemaable spec => Data.JsonSpec.OpenApi.Schemaable ('Data.JsonSpec.Spec.JsonArray spec)
+ Data.JsonSpec.OpenApi: instance GHC.TypeError.Unsatisfiable (((((((Data.JsonSpec.OpenApi.T "`JsonRef \"" 'GHC.TypeError.:<>: Data.JsonSpec.OpenApi.T target) 'GHC.TypeError.:<>: Data.JsonSpec.OpenApi.T "\"` is not defined.\n") 'GHC.TypeError.:$$: Data.JsonSpec.OpenApi.T "You are trying to use a JsonRef as the \"top level\" ") 'GHC.TypeError.:$$: Data.JsonSpec.OpenApi.T "schema. We try to satisfy this request by looking up ") 'GHC.TypeError.:$$: Data.JsonSpec.OpenApi.T "the reference and inlining it. However in this case you ") 'GHC.TypeError.:$$: Data.JsonSpec.OpenApi.T "are trying to reference a schema which is not defined, ") 'GHC.TypeError.:$$: Data.JsonSpec.OpenApi.T "so this won't work.\n") => Data.JsonSpec.OpenApi.Schemaable ('Data.JsonSpec.Spec.JsonLet '[] ('Data.JsonSpec.Spec.JsonRef target))
+ Data.JsonSpec.OpenApi: instance GHC.TypeLits.KnownSymbol name => Data.JsonSpec.OpenApi.Refable ('Data.JsonSpec.Spec.JsonRef name)
+ Data.JsonSpec.OpenApi: instance GHC.TypeLits.KnownSymbol tag => Data.JsonSpec.OpenApi.Schemaable ('Data.JsonSpec.Spec.JsonTag tag)
- Data.JsonSpec.OpenApi: toOpenApiSchema :: forall (spec :: Specification). Internal spec => Proxy spec -> Schema
+ Data.JsonSpec.OpenApi: toOpenApiSchema :: forall (spec :: Specification). Schemaable spec => Proxy spec -> (Definitions Schema, Schema)
Files
- json-spec-openapi.cabal +8/−7
- src/Data/JsonSpec/OpenApi.hs +291/−87
- test/test.hs +176/−87
json-spec-openapi.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: json-spec-openapi-version: 0.1.0.3+version: 0.2.0.0 synopsis: json-spec-openapi description: This package provides a way to produce@@ -62,12 +62,13 @@ common dependencies build-depends:- , aeson >= 2.2.1.0 && < 2.3- , base >= 4.19.0.0 && < 4.20- , json-spec >= 0.2.1.3 && < 0.3- , lens >= 5.2.3 && < 5.3- , openapi3 >= 3.2.4 && < 3.3- , text >= 2.1 && < 2.2+ , aeson >= 2.2.1.0 && < 2.3+ , base >= 4.19.0.0 && < 4.20+ , insert-ordered-containers >= 0.2.5 && < 0.3+ , json-spec >= 0.2.1.3 && < 0.3+ , lens >= 5.2.3 && < 5.3+ , openapi3 >= 3.2.4 && < 3.3+ , text >= 2.1 && < 2.2 common warnings ghc-options:
src/Data/JsonSpec/OpenApi.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-}@@ -92,6 +93,7 @@ -} module Data.JsonSpec.OpenApi ( toOpenApiSchema,+ Schemaable, EncodingSchema(..), DecodingSchema(..), ) where@@ -99,115 +101,293 @@ import Control.Lens (At(at), (&), over, set) import Data.Aeson (ToJSON(toJSON))+import Data.Functor.Identity (Identity(runIdentity)) import Data.JsonSpec (HasJsonDecodingSpec(DecodingSpec), HasJsonEncodingSpec(EncodingSpec), Specification(JsonArray, JsonBool,- JsonDateTime, JsonEither, JsonInt, JsonNum, JsonObject, JsonString,- JsonTag))+ JsonDateTime, JsonEither, JsonInt, JsonLet, JsonNum, JsonObject,+ JsonRef, 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)+ OpenApiType(OpenApiArray, OpenApiBoolean, OpenApiInteger, OpenApiNumber,+ OpenApiObject, OpenApiString), Reference(Reference), Referenced(Inline,+ Ref), ToSchema(declareNamedSchema), Definitions, Schema)+import Data.OpenApi.Declare (DeclareT(runDeclareT), MonadDeclare(declare)) 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), ($))+import GHC.TypeError (ErrorMessage((:$$:), (:<>:)), Unsatisfiable,+ unsatisfiable)+import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)+import Prelude (Applicative(pure), Bool(False), Functor(fmap), Maybe(Just,+ Nothing), Monoid(mempty), ($), (.))+import qualified Data.HashMap.Strict.InsOrd as HMI+import qualified GHC.TypeError as TE {-|- Convert a 'Specification' into an OpenAPI 'Schema'. The type class- 'Internal' is an internal and opaque implementation detail and not- something you should have to worry about. It /should/ already have an- instance for every possible 'Specification' that can be constructed. If- it does not, then that is a bug. Please report it! :-)+ Convert a 'Specification' into an OpenApi 'Schema'. The type class+ 'Schemaable' is an internal and opaque implementation detail and not+ something you should have to worry about.++ It should already have an instance for every 'Specification' that can+ be turned into a 'Schema'. If it does not, then that is a bug. Please+ report it! :-)++ The limitations of this function are:++ * It behaves in a possibly unexpected way when given a top level schema+ of the form:++ > JsonLet '[+ > '("foo", ...)+ > ] (+ > JsonRef "foo"+ > )++ 'toOpenApiSchema' returns a 'Schema', not a @'Referenced' 'Schema'@.+ Therefore, if the \"top level\" of the 'Specification' is a 'JsonRef',+ then we will try to dereference and inline the referenced schema. In+ other words,++ > toOpenApiSchema (Proxy @(+ > JsonLet+ > '[ '("foo", JsonString) ]+ > (JsonRef "foo")+ > ))++ will behave as if you had called++ > toOpenApiSchema (Proxy @(+ > JsonLet+ > '[ '("foo", JsonString) ]+ > JsonString+ > ))++ However, if the reference is undefined, then you will get a custom+ type error explaining what the problem is.++ * With the exception of the above point, we do not check to make sure+ that every referenced used in the returned 'Schema' actually contains+ a definition. So for instance this will \"work\":++ > let+ > (defs, schema) =+ > toOpenApiSchema+ > (Proxy @(+ > JsonObject '[+ > ("bar", JsonRef "not-defined")+ > ]+ > ))+ > in+ > ...++ This will compile, and will not throw any runtime errors directly,+ but depending on how you /use/ @defs@ and @schema@ (like, for+ instance, generating an OpenApi specification) you will probably+ encounter a runtime error complaining that "not-defined" hasn't+ been defined. -} toOpenApiSchema- :: (Internal spec)+ :: (Schemaable spec) => Proxy (spec :: Specification)- -> Schema-toOpenApiSchema = internal+ -> (Definitions Schema, Schema)+toOpenApiSchema spec =+ runIdentity (runDeclareT (schemaable spec) mempty) -class Internal (spec :: Specification) where- {-|- Given a `Specification`, produce an OpenApi schema equivalent to- the specification. Usually you will want to use this in conjunction with- `HasJsonEncodingSpec` or `HasJsonDecodingSpec`.+{-|+ Specifications that can be turned into OpenApi Schemas or a reference+ to a schema.+-}+class Refable (spec :: Specification) where+ refable+ :: (MonadDeclare (Definitions Schema) m)+ => Proxy spec+ -> m (Referenced Schema)+instance (KnownSymbol name) => Refable (JsonRef name) where+ refable Proxy =+ pure (ref (sym @name))+instance+ ( Defs defs+ , KnownSymbol name+ )+ =>+ Refable (JsonLet defs (JsonRef name))+ where+ refable Proxy = do+ mkDefs (Proxy @defs)+ refable (Proxy @(JsonRef name))+instance {-# overlaps #-} (Schemaable a) => Refable a where+ refable = fmap Inline . schemaable - Example: - > data MyType = ...- > instance HasJsonEncodingSpec MyType where- > type EncodingSpec MyType = ...- >- > schema :: Schema- > schema = toOpenApiSchema (Proxy :: Proxy (EncodingSpec MyType))-- -}- internal :: Proxy spec -> Schema-instance (KnownSymbol tag) => Internal ('JsonTag tag) where- internal _ =- mempty & set enum_ (Just [toJSON (sym @tag :: Text)])+{-|+ Specifications that can be turned into OpenApi 'Schema's. -instance Internal 'JsonString where- internal _ =- mempty & set type_ (Just OpenApiString)-instance (Internal left, Internal right) => Internal ('JsonEither left right) where- internal _ =- mempty- & set oneOf (Just- [ Inline (internal (Proxy @left))- , Inline (internal (Proxy @right))- ]- )-instance Internal 'JsonNum where- internal _ =- mempty & set type_ (Just OpenApiNumber)-instance Internal 'JsonInt where- internal _ =- mempty & set type_ (Just OpenApiInteger)-instance Internal ('JsonObject '[]) where- internal _ =- mempty- & set type_ (Just OpenApiObject)- & set additionalProperties (Just (AdditionalPropertiesAllowed False))-instance (KnownSymbol key, Internal spec, Internal ('JsonObject more)) => Internal ('JsonObject ( '(key, spec) : more )) where- internal _ =- let- propertyName :: Text- propertyName = sym @key+ This is intended to be an opaque implementation detail. The only+ reason it is exported is because there are some cases where you might+ need to be able to spell this constraint in code that builds off of+ this package.+-}+class Schemaable (spec :: Specification) where+ schemaable+ :: (MonadDeclare (Definitions Schema) m)+ => Proxy spec+ -> m Schema+instance (KnownSymbol tag) => Schemaable ('JsonTag tag) where+ schemaable Proxy =+ pure $+ mempty & set enum_ (Just [toJSON (sym @tag :: Text)])+instance Schemaable 'JsonString where+ schemaable Proxy =+ pure $+ mempty & set type_ (Just OpenApiString)+instance {- Schemaable ('JsonEither left right) -}+ ( Schemaable left+ , Schemaable right+ )+ =>+ Schemaable ('JsonEither left right)+ where+ schemaable Proxy = do+ schemaLeft <- schemaable (Proxy @left)+ schemaRight <- schemaable (Proxy @right)+ pure $+ mempty+ & set oneOf (Just+ [ Inline schemaLeft+ , Inline schemaRight+ ]+ )+instance Schemaable 'JsonNum where+ schemaable Proxy =+ pure $+ mempty & set type_ (Just OpenApiNumber)+instance Schemaable 'JsonInt where+ schemaable Proxy =+ pure $+ mempty & set type_ (Just OpenApiInteger)+instance Schemaable ('JsonObject '[]) where+ schemaable Proxy =+ pure $+ mempty+ & set type_ (Just OpenApiObject)+ & set additionalProperties (Just (AdditionalPropertiesAllowed False))+instance {- Schemaable ('JsonObject ( '(key, spec) : more )) -}+ ( Schemaable ('JsonObject more)+ , Refable spec+ , KnownSymbol key+ )+ =>+ Schemaable ('JsonObject ( '(key, spec) : more ))+ where+ schemaable Proxy = do+ let+ propertyName :: Text+ propertyName = sym @key - propertySchema :: Schema- propertySchema = internal (Proxy @spec)- in- internal (Proxy @('JsonObject more))- & over properties (set (at propertyName) (Just (Inline propertySchema)))- & over required (propertyName:)-instance (Internal spec) => Internal ('JsonArray spec) where- internal _ =- let- elementSchema :: Schema- elementSchema = internal (Proxy @spec)- in+ propertySchema <- refable (Proxy @spec)+ more <- schemaable (Proxy @('JsonObject more))+ pure $+ more+ & over+ properties+ (set (at propertyName) (Just propertySchema))+ & over required (propertyName:)+instance (Schemaable spec) => Schemaable ('JsonArray spec) where+ schemaable Proxy = do+ elementSchema <- schemaable (Proxy @spec)+ pure $ mempty & set type_ (Just OpenApiArray) & set items (Just (OpenApiItemsObject (Inline elementSchema)))-instance Internal 'JsonBool where- internal _ =- mempty & set type_ (Just OpenApiBoolean)+instance Schemaable 'JsonBool where+ schemaable Proxy =+ pure $+ mempty & set type_ (Just OpenApiBoolean)+instance Schemaable 'JsonDateTime where+ schemaable Proxy =+ pure $+ mempty+ & set type_ (Just OpenApiString)+ & set format (Just "date-time")+instance+ Unsatisfiable (+ T "`JsonRef \"" :<>: T target :<>: T "\"` is not defined.\n"+ :$$: T "You are trying to use a JsonRef as the \"top level\" "+ :$$: T "schema. We try to satisfy this request by looking up "+ :$$: T "the reference and inlining it. However in this case you "+ :$$: T "are trying to reference a schema which is not defined, "+ :$$: T "so this won't work.\n"+ )+ =>+ Schemaable (JsonLet '[] (JsonRef target))+ where+ schemaable = unsatisfiable+instance {- Schemaable (JsonLet ( '(target, def) ': more) (JsonRef target)) -}+ {-# overlaps #-}+ ( KnownSymbol target+ , Schemaable def+ , Schemaable (JsonLet more def)+ )+ =>+ Schemaable (JsonLet ( '(target, def) ': more) (JsonRef target))+ where+ schemaable Proxy = do+ defSchema <- schemaable (Proxy @def)+ declare (HMI.singleton (sym @target) defSchema)+ schemaable (Proxy @(JsonLet more def))+instance {- Schemaable (JsonLet ( '(name, def) ': more) (JsonRef target)) -}+ {-# overlaps #-}+ ( KnownSymbol name+ , Schemaable def+ , Schemaable (JsonLet more (JsonRef target))+ )+ =>+ Schemaable (JsonLet ( '(name, def) ': more) (JsonRef target))+ where+ schemaable Proxy = do+ defSchema <- schemaable (Proxy @def)+ declare (HMI.singleton (sym @name) defSchema)+ schemaable (Proxy @(JsonLet more (JsonRef target)))+instance {- Schemaable (JsonLet defs spec) -}+ {-# overlaps #-}+ ( Defs defs+ , Schemaable spec+ )+ =>+ Schemaable (JsonLet defs spec)+ where+ schemaable Proxy = do+ mkDefs (Proxy @defs)+ schemaable (Proxy @spec) -instance Internal 'JsonDateTime where- internal _ =- mempty- & set type_ (Just OpenApiString)- & set format (Just "date-time") +{-| Go through and make a declaration for each item in a JsonLet. -}+class Defs (defs :: [(Symbol, Specification)]) where+ mkDefs+ :: (MonadDeclare (Definitions Schema) m)+ => Proxy defs+ -> m ()+instance Defs '[] where+ mkDefs Proxy = pure ()+instance+ ( Defs more+ , Schemaable spec+ , KnownSymbol name+ )+ =>+ Defs ( '(name, spec) ': more)+ where+ mkDefs Proxy = do+ schema <- schemaable (Proxy @spec)+ declare (HMI.singleton (sym @name) schema)+ mkDefs (Proxy @more) + {-| Helper for defining `ToSchema` instances based on `HasJsonEncodingSpec` using @deriving via@.@@ -221,9 +401,17 @@ -} newtype EncodingSchema a = EncodingSchema {unEncodingSchema :: a}-instance (Typeable a, Internal (EncodingSpec a)) => ToSchema (EncodingSchema a) where- declareNamedSchema _ =- pure (NamedSchema Nothing (toOpenApiSchema (Proxy @(EncodingSpec a))))+instance+ ( Schemaable (EncodingSpec a)+ , Typeable a+ )+ =>+ ToSchema (EncodingSchema a)+ where+ declareNamedSchema _ = do+ let (declarations, schema) = toOpenApiSchema (Proxy @(EncodingSpec a))+ declare declarations+ pure (NamedSchema Nothing schema) {-|@@ -239,9 +427,17 @@ -} newtype DecodingSchema a = DecodingSchema {unDecodingSchema :: a}-instance (Typeable a, Internal (DecodingSpec a)) => ToSchema (DecodingSchema a) where- declareNamedSchema _ =- pure (NamedSchema Nothing (toOpenApiSchema (Proxy @(DecodingSpec a))))+instance+ ( Schemaable (DecodingSpec a)+ , Typeable a+ )+ =>+ ToSchema (DecodingSchema a)+ where+ declareNamedSchema _ = do+ let (declarations, schema) = toOpenApiSchema (Proxy @(DecodingSpec a))+ declare declarations+ pure (NamedSchema Nothing schema) {- | Shorthand for demoting type-level strings. -}@@ -252,5 +448,13 @@ ) => b sym = fromString $ symbolVal (Proxy @a)+++ref :: Text -> Referenced a+ref = Ref . Reference+++{-| Shorthand for building custom type errors. -}+type T (msg :: Symbol) = TE.Text msg
test/test.hs view
@@ -12,19 +12,20 @@ module Main (main) where import Control.Lens (At(at), (&), set)-import Data.Aeson (FromJSON, ToJSON, encode, toJSON)+import Data.Aeson (ToJSON(toJSON), FromJSON, encode) import Data.JsonSpec (Field(Field), HasJsonDecodingSpec(DecodingSpec, fromJSONStructure), HasJsonEncodingSpec(EncodingSpec, toJSONStructure), SpecJSON(SpecJSON), Specification(JsonArray, JsonBool, JsonDateTime,- JsonEither, JsonNum, JsonObject, JsonString, JsonTag))+ JsonEither, JsonLet, JsonNum, JsonObject, JsonRef, JsonString, JsonTag)) import Data.JsonSpec.OpenApi (EncodingSchema, toOpenApiSchema)-import Data.OpenApi (ToSchema)+import Data.OpenApi (Definitions, ToSchema) import Data.Proxy (Proxy(Proxy)) import Data.Text (Text) import Data.Time (UTCTime) import Prelude (Applicative(pure), Bool(False), Maybe(Just), Monoid(mempty), ($), Eq, IO, Show) import Test.Hspec (describe, hspec, it, shouldBe)+import qualified Data.HashMap.Strict.InsOrd as HMI import qualified Data.OpenApi as OA @@ -34,18 +35,17 @@ describe "toOpenApiSchema" $ do it "string" $ let- actual :: OA.Schema- actual =- toOpenApiSchema (Proxy @JsonString)+ actual :: (Definitions OA.Schema, OA.Schema)+ actual = toOpenApiSchema (Proxy @JsonString) - expected :: OA.Schema- expected = stringSchema+ expected :: (Definitions OA.Schema, OA.Schema)+ expected = (mempty, stringSchema) in actual `shouldBe` expected it "sum" $ let- actual :: OA.Schema+ actual :: (Definitions OA.Schema, OA.Schema) actual = toOpenApiSchema (Proxy @( JsonEither@@ -63,47 +63,48 @@ ) )) - expected :: OA.Schema+ expected :: (Definitions OA.Schema, OA.Schema) expected =- mempty- & set OA.oneOf (Just- [ OA.Inline $- mempty- & set OA.type_ (Just OA.OpenApiObject)- & set OA.properties (- mempty- & set (at "tag") (Just (OA.Inline (- mempty & set OA.enum_ (Just [toJSON ("a" :: Text)])- )))- & set (at "content") (Just (OA.Inline stringSchema))- )- & set OA.required ["tag", "content"]- & set- OA.additionalProperties- (Just (OA.AdditionalPropertiesAllowed False))- , OA.Inline $- mempty- & set OA.type_ (Just OA.OpenApiObject)- & set OA.properties (- mempty- & set (at "tag") (Just (OA.Inline (- mempty & set OA.enum_ (Just [toJSON ("b" :: Text)])- )))- & set (at "content") (Just (OA.Inline stringSchema))- )- & set OA.required ["tag", "content"]- & set- OA.additionalProperties- (Just (OA.AdditionalPropertiesAllowed False))- ]- )+ ( mempty+ , mempty+ & set OA.oneOf (Just+ [ OA.Inline $+ mempty+ & set OA.type_ (Just OA.OpenApiObject)+ & set OA.properties (+ mempty+ & set (at "tag") (Just (OA.Inline (+ mempty & set OA.enum_ (Just [toJSON ("a" :: Text)])+ )))+ & set (at "content") (Just (OA.Inline stringSchema))+ )+ & set OA.required ["tag", "content"]+ & set+ OA.additionalProperties+ (Just (OA.AdditionalPropertiesAllowed False))+ , OA.Inline $+ mempty+ & set OA.type_ (Just OA.OpenApiObject)+ & set OA.properties (+ mempty+ & set (at "tag") (Just (OA.Inline (+ mempty & set OA.enum_ (Just [toJSON ("b" :: Text)])+ )))+ & set (at "content") (Just (OA.Inline stringSchema))+ )+ & set OA.required ["tag", "content"]+ & set+ OA.additionalProperties+ (Just (OA.AdditionalPropertiesAllowed False))+ ]+ )+ ) in actual `shouldBe` expected - it "object" $ let- actual :: OA.Schema+ actual :: (Definitions OA.Schema, OA.Schema) actual = toOpenApiSchema (Proxy @( JsonObject '[@@ -112,36 +113,37 @@ ] )) - expected :: OA.Schema+ expected :: (Definitions OA.Schema, OA.Schema) expected =- mempty- & set OA.type_ (Just OA.OpenApiObject)- & set OA.properties (- mempty- & set (at "Foo") (Just (OA.Inline stringSchema))- & set (at "Bar") (Just (OA.Inline stringSchema))- )- & set OA.required ["Foo", "Bar"]- & set- OA.additionalProperties- (Just (OA.AdditionalPropertiesAllowed False))+ ( mempty+ , mempty+ & set OA.type_ (Just OA.OpenApiObject)+ & set OA.properties (+ mempty+ & set (at "Foo") (Just (OA.Inline stringSchema))+ & set (at "Bar") (Just (OA.Inline stringSchema))+ )+ & set OA.required ["Foo", "Bar"]+ & set+ OA.additionalProperties+ (Just (OA.AdditionalPropertiesAllowed False))+ ) in actual `shouldBe` expected it "num" $ let- actual :: OA.Schema- actual =- toOpenApiSchema (Proxy @JsonNum)+ actual :: (Definitions OA.Schema, OA.Schema)+ actual = toOpenApiSchema (Proxy @JsonNum) - expected :: OA.Schema- expected = numSchema+ expected :: (Definitions OA.Schema, OA.Schema)+ expected = (mempty, numSchema) in actual `shouldBe` expected it "complex array" $ let- actual :: OA.Schema+ actual :: (Definitions OA.Schema, OA.Schema) actual = toOpenApiSchema (Proxy @( JsonArray (@@ -152,53 +154,140 @@ ) )) - expected :: OA.Schema+ expected :: (Definitions OA.Schema, OA.Schema) expected =- let- elementSchema :: OA.Schema- elementSchema =+ ( mempty+ , let+ elementSchema :: OA.Schema+ elementSchema =+ mempty+ & set OA.type_ (Just OA.OpenApiObject)+ & set OA.properties (+ mempty+ & set (at "Foo") (Just (OA.Inline stringSchema))+ & set (at "Bar") (Just (OA.Inline stringSchema))+ )+ & set OA.required ["Foo", "Bar"]+ & set+ OA.additionalProperties+ (Just (OA.AdditionalPropertiesAllowed False))+ in mempty- & set OA.type_ (Just OA.OpenApiObject)- & set OA.properties (- mempty- & set (at "Foo") (Just (OA.Inline stringSchema))- & set (at "Bar") (Just (OA.Inline stringSchema))- )- & set OA.required ["Foo", "Bar"]- & set- OA.additionalProperties- (Just (OA.AdditionalPropertiesAllowed False))- in- mempty- & set OA.type_ (Just OA.OpenApiArray)- & set OA.items (Just (OA.OpenApiItemsObject (OA.Inline elementSchema)))+ & set OA.type_ (Just OA.OpenApiArray)+ & set OA.items (Just (OA.OpenApiItemsObject (OA.Inline elementSchema)))+ ) in actual `shouldBe` expected it "bool" $ let- actual :: OA.Schema+ actual :: (Definitions OA.Schema, OA.Schema) actual = toOpenApiSchema (Proxy @JsonBool) - expected :: OA.Schema- expected = boolSchema+ expected :: (Definitions OA.Schema, OA.Schema)+ expected = (mempty, boolSchema) in actual `shouldBe` expected it "date-time" $ let- actual :: OA.Schema+ actual :: (Definitions OA.Schema, OA.Schema) actual = toOpenApiSchema (Proxy @JsonDateTime) - expected :: OA.Schema+ expected :: (Definitions OA.Schema, OA.Schema) expected =- stringSchema- & set OA.format (Just "date-time")+ ( mempty+ , stringSchema & set OA.format (Just "date-time")+ ) in actual `shouldBe` expected++ it "let expression" $+ let+ actual :: (Definitions OA.Schema, OA.Schema)+ actual =+ toOpenApiSchema (Proxy @(+ JsonLet '[+ '("thing", JsonString)+ ]+ (+ JsonObject '[+ '("foo", JsonRef "thing")+ ]+ )+ ))++ expected :: (Definitions OA.Schema, OA.Schema)+ expected =+ ( HMI.singleton "thing" stringSchema+ , mempty+ & set OA.type_ (Just OA.OpenApiObject)+ & set OA.properties (+ mempty+ & set (at "foo") (Just (OA.Ref (OA.Reference "thing")))+ )+ & set OA.required ["foo"]+ & set+ OA.additionalProperties+ (Just (OA.AdditionalPropertiesAllowed False))+ )+ in+ actual `shouldBe` expected++ it "top level reference" $+ let+ actual :: (Definitions OA.Schema, OA.Schema)+ actual =+ toOpenApiSchema (Proxy @(+ JsonLet '[+ '("foo", JsonNum),+ '("bar", JsonString)+ ]+ (JsonRef "bar")+ ))++ expected :: (Definitions OA.Schema, OA.Schema)+ expected =+ ( HMI.fromList [("foo", numSchema), ("bar", stringSchema)]+ , stringSchema+ )+ in+ actual `shouldBe` expected++ it "lower level reference" $+ let+ actual :: (Definitions OA.Schema, OA.Schema)+ actual =+ toOpenApiSchema (Proxy @(+ JsonObject '[+ '("foo",+ JsonLet+ '[ '("thing", JsonString)]+ (JsonRef "thing")+ )+ ]+ ))++ expected :: (Definitions OA.Schema, OA.Schema)+ expected =+ ( HMI.singleton "thing" stringSchema+ , mempty+ & set OA.type_ (Just OA.OpenApiObject)+ & set OA.properties (+ mempty+ & set (at "foo") (Just (OA.Ref (OA.Reference "thing")))+ )+ & set OA.required ["foo"]+ & set+ OA.additionalProperties+ (Just (OA.AdditionalPropertiesAllowed False))+ )+ in+ actual `shouldBe` expected+ describe "EncodingSpec" $ it "works" $ let