diff --git a/json-spec-openapi.cabal b/json-spec-openapi.cabal --- a/json-spec-openapi.cabal +++ b/json-spec-openapi.cabal @@ -1,11 +1,11 @@ cabal-version: 3.0 name: json-spec-openapi -version: 1.0.1.3 +version: 1.1.0.0 synopsis: json-spec-openapi description: This package provides a way to produce [openapi3](https://hackage.haskell.org/package/openapi3) documentation from a - [json-spec](https://hackage.haskell.org/package/json-spec-0.1.0.0) + [json-spec](https://hackage.haskell.org/package/json-spec-1.2.0.0) specification. = Example @@ -64,7 +64,7 @@ , aeson >= 2.2.1.0 && < 2.3 , base >= 4.19.0.0 && < 4.22 , insert-ordered-containers >= 0.2.5.3 && < 0.3 - , json-spec >= 0.5.0.0 && < 1.2 + , json-spec >= 1.2.0.0 && < 1.3 , lens >= 5.2.3 && < 5.4 , openapi3 >= 3.2.4 && < 3.3 , text >= 2.1 && < 2.2 diff --git a/src/Data/JsonSpec/OpenApi.hs b/src/Data/JsonSpec/OpenApi.hs --- a/src/Data/JsonSpec/OpenApi.hs +++ b/src/Data/JsonSpec/OpenApi.hs @@ -108,15 +108,16 @@ ( FieldSpec(Optional, Required), HasJsonDecodingSpec(DecodingSpec) , HasJsonEncodingSpec(EncodingSpec) , Specification - ( JsonArray, JsonBool, JsonDateTime, JsonEither, JsonInt, JsonLet - , JsonNullable, JsonNum, JsonObject, JsonRaw, JsonRef, JsonString, JsonTag + ( JsonAnnotated, JsonArray, JsonBool, JsonDateTime, JsonEither, JsonInt + , JsonLet, JsonNullable, JsonNum, JsonObject, JsonRaw, JsonRef, JsonString + , JsonTag ) ) import Data.JsonSpec.OpenApi.Rename (Rename) import Data.OpenApi ( AdditionalProperties(AdditionalPropertiesAllowed) - , HasAdditionalProperties(additionalProperties), HasEnum(enum_) - , HasFormat(format), HasItems(items), HasOneOf(oneOf) + , HasAdditionalProperties(additionalProperties), HasDescription(description) + , HasEnum(enum_), HasFormat(format), HasItems(items), HasOneOf(oneOf) , HasProperties(properties), HasRequired(required), HasType(type_) , NamedSchema(NamedSchema), OpenApiItems(OpenApiItemsObject) , OpenApiType @@ -134,7 +135,7 @@ import GHC.TypeLits (KnownSymbol, Symbol, symbolVal) import Prelude ( Applicative(pure), Bool(False), Functor(fmap), Maybe(Just, Nothing) - , Monoid(mempty), ($), (.) + , Monoid(mempty), ($), (.), id ) import qualified Data.HashMap.Strict.InsOrd as HMI import qualified Data.OpenApi as OA @@ -357,6 +358,16 @@ Inlineable defs (JsonRef target) where inlineable = deref @defs @defs @target +instance {- Inlineable defs (JsonAnnotated annotations spec) -} + ( Inlineable defs spec + , ApplyAnnotations annotations + ) + => + Inlineable defs (JsonAnnotated annotations spec) + where + inlineable = do + schema <- inlineable @defs @spec + pure (applyAnnotations @annotations schema) {-| @@ -523,5 +534,46 @@ where Concat '[] b = b Concat (a : more) b = a : Concat more b + + +{-| + Look up a key in a list of annotation pairs. Returns 'Just value if found, + 'Nothing otherwise. +-} +type family + LookupAnnotation + (key :: Symbol) + (annotations :: [(Symbol, Symbol)]) + :: Maybe Symbol + where + LookupAnnotation key '[] = 'Nothing + LookupAnnotation key ( '(key, value) ': more ) = 'Just value + LookupAnnotation key ( '(other, value) ': more ) = LookupAnnotation key more + + +{-| + Apply annotations to a schema. Currently only "description" is supported; + all other annotations are ignored. +-} +class ApplyAnnotations (annotations :: [(Symbol, Symbol)]) where + applyAnnotations :: Schema -> Schema +instance + (ApplyDescription (LookupAnnotation "description" annotations)) + => + ApplyAnnotations annotations + where + applyAnnotations = applyDescription @(LookupAnnotation "description" annotations) + + +{-| + Helper class for applying a description annotation to a schema. +-} +class ApplyDescription (desc :: Maybe Symbol) where + applyDescription :: Schema -> Schema +instance ApplyDescription 'Nothing where + applyDescription = id +instance (KnownSymbol desc) => ApplyDescription ('Just desc) where + applyDescription schema = + schema & set description (Just (sym @desc)) diff --git a/test/test.hs b/test/test.hs --- a/test/test.hs +++ b/test/test.hs @@ -20,8 +20,9 @@ , HasJsonDecodingSpec(DecodingSpec, fromJSONStructure) , HasJsonEncodingSpec(EncodingSpec, toJSONStructure), SpecJSON(SpecJSON) , Specification - ( JsonArray, JsonBool, JsonDateTime, JsonEither, JsonInt, JsonLet - , JsonNullable, JsonNum, JsonObject, JsonRaw, JsonRef, JsonString, JsonTag + ( JsonAnnotated, JsonArray, JsonBool, JsonDateTime, JsonEither, JsonInt + , JsonLet, JsonNullable, JsonNum, JsonObject, JsonRaw, JsonRef, JsonString + , JsonTag ) , (:::), (::?), unField ) @@ -31,8 +32,8 @@ import Data.Text (Text) import Data.Time (UTCTime) import Prelude - ( Applicative(pure), Bool(False), Functor(fmap), Maybe(Just), Monoid(mempty) - , ($), (.), Eq, IO, Show + ( Applicative(pure), Bool(False), Eq, Functor(fmap), Int, IO, Maybe(Just) + , Monoid(mempty), Show, ($), (.) ) import Test.Hspec (describe, hspec, it, shouldBe) import qualified Data.Aeson as Aeson @@ -666,6 +667,31 @@ in Aeson.encode actual `shouldBe` Aeson.encode expected + describe "annotated" $ do + it "JsonAnnotated wrapping object (EncodingSpec AnnotatedUser)" $ + let + actual :: (Definitions OA.Schema, OA.Schema) + actual = toOpenApiSchema (Proxy @(EncodingSpec AnnotatedUser)) + + expected :: (Definitions OA.Schema, OA.Schema) + expected = + ( mempty + , mempty + & set OA.type_ (Just OA.OpenApiObject) + & set OA.description (Just "A user with a name and age") + & set OA.properties ( + mempty + & set (at "name") (Just (OA.Inline stringSchema)) + & set (at "age") (Just (OA.Inline intSchema)) + ) + & set OA.required ["name", "age"] + & set + OA.additionalProperties + (Just (OA.AdditionalPropertiesAllowed False)) + ) + in + actual `shouldBe` expected + describe "EncodingSchema" $ it "works" $ let @@ -721,12 +747,47 @@ pure User { name , lastLogin } +{- Annotated test: EncodingSpec uses JsonAnnotated. -} +data AnnotatedUser = AnnotatedUser + { auName :: Text + , auAge :: Int + } + deriving stock (Show, Eq) + deriving (ToJSON, FromJSON) via (SpecJSON AnnotatedUser) +instance HasJsonEncodingSpec AnnotatedUser where + type EncodingSpec AnnotatedUser = + JsonAnnotated + '[ '("description", "A user with a name and age") + , '("example", "{\"name\": \"alice\", \"age\": 30}") + ] + (JsonObject + '[ Required "name" JsonString + , Required "age" JsonInt + ]) + toJSONStructure AnnotatedUser { auName, auAge } = + (Field @"name" auName, + (Field @"age" auAge, + ())) +instance HasJsonDecodingSpec AnnotatedUser where + type DecodingSpec AnnotatedUser = EncodingSpec AnnotatedUser + fromJSONStructure + (Field @"name" auName, + (Field @"age" auAge, + ())) + = + pure AnnotatedUser { auName, auAge } + + stringSchema :: OA.Schema stringSchema = mempty & set OA.type_ (Just OA.OpenApiString) numSchema :: OA.Schema numSchema = mempty & set OA.type_ (Just OA.OpenApiNumber) + + +intSchema :: OA.Schema +intSchema = mempty & set OA.type_ (Just OA.OpenApiInteger) boolSchema :: OA.Schema