diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,9 @@ +# Changelog + +All notable changes to this project will be documented in this file. + +## Unreleased + +- Upgraded the json-spec dependency (adapts to json-spec 1.3 breaking change + where `JsonEither` takes a type-level list of specs instead of two + arguments). diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,6 +1,6 @@ MIT License -Copyright (c) 2023 Rick Owens +Copyright (c) 2026 Rick Owens Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal diff --git a/json-spec-openapi.cabal b/json-spec-openapi.cabal --- a/json-spec-openapi.cabal +++ b/json-spec-openapi.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: json-spec-openapi -version: 1.1.0.0 +version: 1.2.0.1 synopsis: json-spec-openapi description: This package provides a way to produce @@ -52,19 +52,20 @@ license-file: LICENSE author: Rick Owens maintainer: rick@owensmurray.com -copyright: 2025 Owens Murray, LLC. +copyright: 2026 Owens Murray, LLC. category: JSON, OpenApi build-type: Simple -extra-source-files: +extra-doc-files: README.md LICENSE + CHANGELOG.md common dependencies build-depends: , aeson >= 2.2.1.0 && < 2.3 - , base >= 4.19.0.0 && < 4.22 + , base >= 4.19.2.0 && < 4.22 , insert-ordered-containers >= 0.2.5.3 && < 0.3 - , json-spec >= 1.2.0.0 && < 1.3 + , json-spec >= 1.3.0.0 && < 1.4 , 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 @@ -91,6 +91,36 @@ > (Just (AdditionalPropertiesAllowed True)) > ) + === Annotations and schema modification + + You can wrap a specification in 'JsonAnnotated' to attach + type-level annotations. This library interprets one annotation: + @\"schema-modifier\"@ with a value of kind 'Type'. Use it to + customize the generated schema (e.g. set description, readOnly, or + other OpenAPI fields) by giving that type a 'SchemaModifier' + instance. While you may use any type that has an instance, using the + base type for which you are specifying an encoding may be the most + convenient. + + Other annotation kinds (e.g. @[(Symbol, Symbol)]@ for description + strings) and other keys are no-op here so that other tools can + interpret them without causing compile errors. + + Example (you may need @-XFlexibleInstances@ for the instance): + + > data AnnotatedUser = AnnotatedUser { name_ :: Text, age_ :: Int } + > deriving (ToJSON, FromJSON) via (SpecJSON AnnotatedUser) + > instance SchemaModifier AnnotatedUser where + > modifySchema s = s & set description (Just \"A user with name and age\") + > instance HasJsonEncodingSpec AnnotatedUser where + > type EncodingSpec AnnotatedUser = + > JsonAnnotated '[ '(\"schema-modifier\", AnnotatedUser) ] + > (JsonObject '[ Required \"name\" JsonString, Required \"age\" JsonInt ]) + > toJSONStructure (AnnotatedUser n a) = (Field @"name" n, (Field @"age" a, ())) + + The type in @\"schema-modifier\"@ must have a 'SchemaModifier' + instance or you get a type error; it is not ignored. + -} module Data.JsonSpec.OpenApi ( toOpenApiSchema, @@ -98,6 +128,7 @@ EncodingSchema(..), DecodingSchema(..), Rename, + SchemaModifier(..), ) where @@ -116,7 +147,7 @@ import Data.JsonSpec.OpenApi.Rename (Rename) import Data.OpenApi ( AdditionalProperties(AdditionalPropertiesAllowed) - , HasAdditionalProperties(additionalProperties), HasDescription(description) + , HasAdditionalProperties(additionalProperties) , HasEnum(enum_), HasFormat(format), HasItems(items), HasOneOf(oneOf) , HasProperties(properties), HasRequired(required), HasType(type_) , NamedSchema(NamedSchema), OpenApiItems(OpenApiItemsObject) @@ -130,12 +161,13 @@ import Data.OpenApi.Declare (DeclareT(runDeclareT), MonadDeclare(declare)) import Data.String (IsString(fromString)) import Data.Text (Text) +import Data.Kind (Type) import Data.Typeable (Proxy(Proxy), Typeable) 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), ($), (.), id + ( Applicative(pure, (<*>)), Bool(False), Functor(fmap), Maybe(Just, Nothing) + , Monoid(mempty), ($), (.), (<$>), id ) import qualified Data.HashMap.Strict.InsOrd as HMI import qualified Data.OpenApi as OA @@ -246,23 +278,16 @@ inlineable = pure $ mempty & set type_ (Just OpenApiString) -instance {- Inlineable defs ('JsonEither left right) -} - ( Refable defs left - , Refable defs right - ) +instance {- Inlineable defs ('JsonEither specs) -} + (RefableList defs specs) => - Inlineable defs ('JsonEither left right) + Inlineable defs (JsonEither specs) where inlineable = do - schemaLeft <- refable @defs @left - schemaRight <- refable @defs @right + schemaList <- refableList @defs @specs pure $ mempty - & set oneOf (Just - [ schemaLeft - , schemaRight - ] - ) + & set oneOf (Just schemaList) instance Inlineable defs JsonNum where inlineable = pure $ @@ -367,10 +392,35 @@ where inlineable = do schema <- inlineable @defs @spec - pure (applyAnnotations @annotations schema) + pure (applyAnnotations (Proxy @annotations) schema) {-| + Like 'Refable' but for a type-level list of specifications; produces + a list of schemas (used for 'JsonEither' oneOf). +-} +class + RefableList + (defs :: [(Symbol, Specification)]) + (specs :: [Specification]) + where + refableList + :: (MonadDeclare (Definitions Schema) m) + => m [Referenced Schema] +instance RefableList defs '[] where + refableList = pure [] +instance + ( Refable defs spec + , RefableList defs more + ) + => + RefableList defs (spec ': more) + where + refableList = + (:) <$> refable @defs @spec <*> refableList @defs @more + + +{-| Specifications that can be turned into OpenApi Schemas or a reference to a schema. -} @@ -538,13 +588,15 @@ {-| Look up a key in a list of annotation pairs. Returns 'Just value if found, - 'Nothing otherwise. + 'Nothing otherwise. The annotations list is poly-kinded in the value type + so that different tools can use different kinds (e.g. this library looks up + \"schema-modifier\" for a value of kind 'Type' to apply 'SchemaModifier'). -} type family LookupAnnotation (key :: Symbol) - (annotations :: [(Symbol, Symbol)]) - :: Maybe Symbol + (annotations :: [(Symbol, k)]) + :: Maybe k where LookupAnnotation key '[] = 'Nothing LookupAnnotation key ( '(key, value) ': more ) = 'Just value @@ -552,28 +604,54 @@ {-| - Apply annotations to a schema. Currently only "description" is supported; - all other annotations are ignored. + Apply annotations to a schema. We only interpret @[(Symbol, Type)]@ + (for the \"schema-modifier\" hook); all other annotation kinds are + no-op here so that json-spec users can use other kinds (e.g. 'Symbol', + 'Bool', 'Nat', or custom kinds) for other tools without causing + compile errors in this library. -} -class ApplyAnnotations (annotations :: [(Symbol, Symbol)]) where - applyAnnotations :: Schema -> Schema +class ApplyAnnotations (annotations :: [(Symbol, k)]) where + applyAnnotations :: Proxy annotations -> Schema -> Schema +instance {-# OVERLAPPABLE #-} ApplyAnnotations (annotations :: [(Symbol, k)]) where + applyAnnotations _proxy = id instance - (ApplyDescription (LookupAnnotation "description" annotations)) + (ApplySchemaModifier (LookupAnnotation "schema-modifier" annotations)) => - ApplyAnnotations annotations + ApplyAnnotations (annotations :: [(Symbol, Type)]) where - applyAnnotations = applyDescription @(LookupAnnotation "description" annotations) + applyAnnotations _proxy = applySchemaModifier @(LookupAnnotation "schema-modifier" annotations) {-| - Helper class for applying a description annotation to a schema. + User-defined schema modifier. Use this to customize how a schema is + transformed when the \"schema-modifier\" annotation appears in a + 'JsonAnnotated' list with a value of your type. + + While you may use any type that has an instance, using the base type + for which you are specifying an encoding may be the most convenient. If you + use a type that has no 'SchemaModifier' instance, you get a type + error (it is not ignored). + + Example (you may need @-XFlexibleInstances@ for the instance): + + > type EncodingSpec AnnotatedUser = + > JsonAnnotated '[ '(\"schema-modifier\", AnnotatedUser) ] + > (JsonObject ...) + > instance SchemaModifier AnnotatedUser where + > modifySchema schema = schema & set description (Just \"A user\") -} -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)) +class SchemaModifier (t :: Type) where + modifySchema :: Schema -> Schema + + +{-| + Apply a schema modifier when present in the annotation lookup result. +-} +class ApplySchemaModifier (m :: Maybe Type) where + applySchemaModifier :: Schema -> Schema +instance ApplySchemaModifier 'Nothing where + applySchemaModifier = id +instance (SchemaModifier t) => ApplySchemaModifier ('Just t) where + applySchemaModifier = modifySchema @t diff --git a/src/Data/JsonSpec/OpenApi/Rename.hs b/src/Data/JsonSpec/OpenApi/Rename.hs --- a/src/Data/JsonSpec/OpenApi/Rename.hs +++ b/src/Data/JsonSpec/OpenApi/Rename.hs @@ -73,6 +73,22 @@ type family + Snd + (a :: (Specification, Global)) + :: Global + where + Snd '(spec, global) = global + + +type family + GetEitherList + (spec :: Specification) + :: [Specification] + where + GetEitherList (JsonEither specs) = specs + + +type family FoldRename (global :: Global) (active :: Active) @@ -104,8 +120,8 @@ FoldRename global active (JsonObject fields) = RenameObject global active fields - FoldRename global active (JsonEither left right) = - RenameEither global active left right + FoldRename global active (JsonEither specs) = + RenameEitherList global active specs FoldRename global active (JsonLet defs spec) = RenameLet @@ -208,39 +224,21 @@ type family - RenameEither + RenameEitherList (global :: Global) (active :: Active) - ( left :: Specification) - ( right :: Specification) - :: (Specification, Global) - where - RenameEither global active left right = - RenameEither2 - active - (FoldRename global active left) - right - - -type family - RenameEither2 - (active :: Active) - ( left :: (Specification, Global)) - ( right :: Specification) - :: (Specification, Global) - where - RenameEither2 active '(left, global) right = - RenameEither3 left (FoldRename global active right) - - -type family - RenameEither3 - (left :: Specification) - (right :: (Specification, Global)) + (specs :: [Specification]) :: (Specification, Global) where - RenameEither3 left '(right, global) = - '(JsonEither left right, global) + RenameEitherList global active '[spec] = + '(JsonEither '[Fst (FoldRename global active spec)], Snd (FoldRename global active spec)) + RenameEitherList global active (spec ': more) = + '( JsonEither + (Fst (FoldRename global active spec) + ': GetEitherList + (Fst (RenameEitherList (Snd (FoldRename global active spec)) active more))) + , Snd (RenameEitherList (Snd (FoldRename global active spec)) active more) + ) type family diff --git a/test/test.hs b/test/test.hs --- a/test/test.hs +++ b/test/test.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} @@ -26,7 +27,9 @@ ) , (:::), (::?), unField ) -import Data.JsonSpec.OpenApi (EncodingSchema, Rename, toOpenApiSchema) +import Data.JsonSpec.OpenApi + ( EncodingSchema, Rename, SchemaModifier(modifySchema), toOpenApiSchema + ) import Data.OpenApi (Definitions, ToSchema) import Data.Proxy (Proxy(Proxy)) import Data.Text (Text) @@ -61,18 +64,15 @@ actual = toOpenApiSchema (Proxy @( JsonEither - ( - JsonObject + '[ JsonObject '[ Required "tag" (JsonTag "a") , Required "content" JsonString ] - ) - ( - JsonObject + , JsonObject '[ Required "tag" (JsonTag "b") , Required "content" JsonString ] - ) + ] )) expected :: (Definitions OA.Schema, OA.Schema) @@ -692,6 +692,75 @@ in actual `shouldBe` expected + it "JsonAnnotated with empty list is no-op" $ + let + actual :: (Definitions OA.Schema, OA.Schema) + actual = toOpenApiSchema (Proxy @(EncodingSpec EmptyAnnotatedUser)) + + expected :: (Definitions OA.Schema, OA.Schema) + expected = + ( mempty + , mempty + & set OA.type_ (Just OA.OpenApiObject) + & 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 + + it "JsonAnnotated with Symbol-valued \"schema-modifier\" is ignored (no-op)" $ + let + actual :: (Definitions OA.Schema, OA.Schema) + actual = toOpenApiSchema (Proxy @(EncodingSpec SymbolSchemaModifierUser)) + + expected :: (Definitions OA.Schema, OA.Schema) + expected = + ( mempty + , mempty + & set OA.type_ (Just OA.OpenApiObject) + & 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 + + it "JsonAnnotated with Type-valued list but no \"schema-modifier\" key is no-op" $ + let + actual :: (Definitions OA.Schema, OA.Schema) + actual = toOpenApiSchema (Proxy @(EncodingSpec OtherTypeAnnotationUser)) + + expected :: (Definitions OA.Schema, OA.Schema) + expected = + ( mempty + , mempty + & set OA.type_ (Just OA.OpenApiObject) + & 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 @@ -747,18 +816,20 @@ pure User { name , lastLogin } -{- Annotated test: EncodingSpec uses JsonAnnotated. -} +{- Annotated test: EncodingSpec uses JsonAnnotated and SchemaModifier. -} data AnnotatedUser = AnnotatedUser { auName :: Text , auAge :: Int } deriving stock (Show, Eq) deriving (ToJSON, FromJSON) via (SpecJSON AnnotatedUser) +instance SchemaModifier AnnotatedUser where + modifySchema schema = + schema & set OA.description (Just "A user with a name and age") instance HasJsonEncodingSpec AnnotatedUser where type EncodingSpec AnnotatedUser = JsonAnnotated - '[ '("description", "A user with a name and age") - , '("example", "{\"name\": \"alice\", \"age\": 30}") + '[ '("schema-modifier", AnnotatedUser) ] (JsonObject '[ Required "name" JsonString @@ -776,6 +847,96 @@ ())) = pure AnnotatedUser { auName, auAge } + + +{- Empty annotations: catch-all applies, no-op. -} +data EmptyAnnotatedUser = EmptyAnnotatedUser + { eauName :: Text + , eauAge :: Int + } + deriving stock (Show, Eq) + deriving (ToJSON, FromJSON) via (SpecJSON EmptyAnnotatedUser) +instance HasJsonEncodingSpec EmptyAnnotatedUser where + type EncodingSpec EmptyAnnotatedUser = + JsonAnnotated + '[] + (JsonObject + '[ Required "name" JsonString + , Required "age" JsonInt + ]) + toJSONStructure EmptyAnnotatedUser { eauName, eauAge } = + (Field @"name" eauName, + (Field @"age" eauAge, + ())) +instance HasJsonDecodingSpec EmptyAnnotatedUser where + type DecodingSpec EmptyAnnotatedUser = EncodingSpec EmptyAnnotatedUser + fromJSONStructure + (Field @"name" eauName, + (Field @"age" eauAge, + ())) + = + pure EmptyAnnotatedUser { eauName, eauAge } + + +{- Symbol-valued "schema-modifier" key: kind is [(Symbol, Symbol)], no-op. -} +data SymbolSchemaModifierUser = SymbolSchemaModifierUser + { ssmName :: Text + , ssmAge :: Int + } + deriving stock (Show, Eq) + deriving (ToJSON, FromJSON) via (SpecJSON SymbolSchemaModifierUser) +instance HasJsonEncodingSpec SymbolSchemaModifierUser where + type EncodingSpec SymbolSchemaModifierUser = + JsonAnnotated + '[ '("schema-modifier", "ignored-symbol-value") + ] + (JsonObject + '[ Required "name" JsonString + , Required "age" JsonInt + ]) + toJSONStructure SymbolSchemaModifierUser { ssmName, ssmAge } = + (Field @"name" ssmName, + (Field @"age" ssmAge, + ())) +instance HasJsonDecodingSpec SymbolSchemaModifierUser where + type DecodingSpec SymbolSchemaModifierUser = EncodingSpec SymbolSchemaModifierUser + fromJSONStructure + (Field @"name" ssmName, + (Field @"age" ssmAge, + ())) + = + pure SymbolSchemaModifierUser { ssmName, ssmAge } + + +{- Type-valued annotations but key is not "schema-modifier": no-op. -} +data OtherAnnotation +data OtherTypeAnnotationUser = OtherTypeAnnotationUser + { otaName :: Text + , otaAge :: Int + } + deriving stock (Show, Eq) + deriving (ToJSON, FromJSON) via (SpecJSON OtherTypeAnnotationUser) +instance HasJsonEncodingSpec OtherTypeAnnotationUser where + type EncodingSpec OtherTypeAnnotationUser = + JsonAnnotated + '[ '("other-key", OtherAnnotation) + ] + (JsonObject + '[ Required "name" JsonString + , Required "age" JsonInt + ]) + toJSONStructure OtherTypeAnnotationUser { otaName, otaAge } = + (Field @"name" otaName, + (Field @"age" otaAge, + ())) +instance HasJsonDecodingSpec OtherTypeAnnotationUser where + type DecodingSpec OtherTypeAnnotationUser = EncodingSpec OtherTypeAnnotationUser + fromJSONStructure + (Field @"name" otaName, + (Field @"age" otaAge, + ())) + = + pure OtherTypeAnnotationUser { otaName, otaAge } stringSchema :: OA.Schema