From b2d0f7240e8d8a743a1293c001723789bbdacfb6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tom=C3=A1=C5=A1=20Svoboda?= Date: Tue, 13 May 2025 16:24:11 +0200 Subject: [PATCH] Add toEncoding to preserve field order encode/toEncoding of an OpenApi document re-sorted object keys alphabetically. Schema and the eight Referenced instances had no toEncoding and fell back to the default `toEncoding = toEncoding . toJSON`, which routes through Value and cannot represent key order. The fallback is transitive, so the whole sub-tree below them was alphabetized as well. Schema.toEncoding existed in swagger2 but was dropped in 11f8f97 ("Merge ParamSchema into Schema"), where the merged Schema started needing inline aeson options and no encoding counterpart of sopSwaggerGenericToJSONWithOpts existed. Data/OpenApi/Internal/AesonUtils.hs: * Add sopSwaggerGenericToEncodingWithOpts, the encoding counterpart of sopSwaggerGenericToJSONWithOpts. * Add sopSwaggerGenericToSeries, the body of sopSwaggerGenericToEncoding without the final `pairs`, so an instance can splice a record's fields into an enclosing object. * Splice sub-objects (saoSubObject) on the encoding path rather than through toJSON/Value. The caller supplies the sub-object's members as a Series via sopSwaggerGenericToEncodingWithSub, because the generic traversal only has ToJSON for them and an Encoding is an opaque Builder that cannot be taken apart. A declared sub-object with no Series is now a loud error instead of silently dropped fields. * Handle Newtype in the three generic traversals. They matched only ADT, so a newtype record hit the "unsupported type" error. * Replace the dead saoAdditionalPairs option with saoRequiredFields, which forces a field to be emitted even when it equals its default. saoAdditionalPairs existed for swagger2's constant "swagger": "2.0" field, which is a real record field in openapi3, and nothing had set it since. Drops pairsToSeries and parseAdditionalField with it. Data/OpenApi/Internal.hs: * Restore Schema.toEncoding and the eight Referenced instances, the latter via a new referencedToEncoding. * Add toEncoding to every remaining ToJSON in the model so nothing falls back to the Value path: the hand-written instances (SecuritySchemeType, OpenApiItems, SecurityDefinitions, AdditionalProperties, ExpressionOrValue, Callback, Reference, MimeList, OpenApiSpecVersion) and the jsonPrefix-derived records and enums. * Move ApiKeyParams and the four OAuth2*Flow records to the generics-sop family. Their fields are spliced into an enclosing object, which needs a Series, and deriving it keeps the field names in the records instead of in string literals. * Emit the required-but-empty OpenApi "paths" and OAuth2Flow "scopes" objects via saoRequiredFields, which removes the special case from both toJSON and toEncoding. * Add the Series helpers the sub-object splices need: openApiItemsSeries, securitySchemeTypeSeries and responsesSeries, reused by the corresponding toEncoding instances so each has a single definition. * Drop the stale `saoSubObject ?~ "paramSchema"` from Schema's HasSwaggerAesonOptions. No field has produced that name since the ParamSchema merge. It cannot be corrected to "items" either: FromJSON Schema shares these options and would then try to parse the whole schema object as OpenApiItems. test/SpecCommon.hs: * (<=>) now also asserts `decode (toEncoding x) == Right (toJSON x)`, so every curated example checks that the two encoders agree. Two behavior changes beyond key order: * An empty "paths" is emitted in its declared position rather than appended last. * parseJSON failure messages for ApiKeyParams and the four OAuth2*Flow records now read "Swagger Record Object", like the other generics-sop types, instead of naming the constructor. Successful parses and all serialized output are unchanged. --- src/Data/OpenApi/Internal.hs | 229 ++++++++++++++++++------ src/Data/OpenApi/Internal/AesonUtils.hs | 160 ++++++++++++----- test/SpecCommon.hs | 3 + 3 files changed, 294 insertions(+), 98 deletions(-) diff --git a/src/Data/OpenApi/Internal.hs b/src/Data/OpenApi/Internal.hs index be77723b..8081134e 100644 --- a/src/Data/OpenApi/Internal.hs +++ b/src/Data/OpenApi/Internal.hs @@ -34,11 +34,14 @@ import Text.Read (readMaybe) import Data.HashMap.Strict.InsOrd.Compat (InsOrdHashMap) import qualified Data.HashMap.Strict.InsOrd.Compat as InsOrdHashMap -import Data.OpenApi.Aeson.Compat (deleteKey) +import Data.OpenApi.Aeson.Compat (deleteKey, stringToKey) import Data.OpenApi.Internal.AesonUtils (AesonDefaultValue (..), HasSwaggerAesonOptions (..), - mkSwaggerAesonOptions, saoAdditionalPairs, saoSubObject, + mkSwaggerAesonOptions, saoRequiredFields, saoSubObject, sopSwaggerGenericParseJSON, sopSwaggerGenericToEncoding, - sopSwaggerGenericToJSON, sopSwaggerGenericToJSONWithOpts) + sopSwaggerGenericToEncodingWithOpts, + sopSwaggerGenericToEncodingWithSub, sopSwaggerGenericToJSON, + sopSwaggerGenericToJSONWithOpts, sopSwaggerGenericToSeries, + SubObjectSeries (..)) import Data.OpenApi.Internal.Utils import Generics.SOP.TH (deriveGeneric) import Data.Version @@ -970,6 +973,11 @@ newtype OpenApiSpecVersion = OpenApiSpecVersion {getVersion :: Version} deriving -- Generic instances ------------------------------------------------------------------------------- +deriveGeneric ''ApiKeyParams +deriveGeneric ''OAuth2ImplicitFlow +deriveGeneric ''OAuth2PasswordFlow +deriveGeneric ''OAuth2ClientCredentialsFlow +deriveGeneric ''OAuth2AuthorizationCodeFlow deriveGeneric ''Server deriveGeneric ''Components deriveGeneric ''Header @@ -1166,54 +1174,51 @@ instance Monoid a => SwaggerMonoid (Referenced a) where instance ToJSON Style where toJSON = genericToJSON (jsonPrefix "Style") + toEncoding = genericToEncoding (jsonPrefix "Style") instance ToJSON OpenApiType where toJSON = genericToJSON (jsonPrefix "Swagger") + toEncoding = genericToEncoding (jsonPrefix "Swagger") instance ToJSON ParamLocation where toJSON = genericToJSON (jsonPrefix "Param") + toEncoding = genericToEncoding (jsonPrefix "Param") instance ToJSON Info where toJSON = genericToJSON (jsonPrefix "Info") + toEncoding = genericToEncoding (jsonPrefix "Info") instance ToJSON Contact where toJSON = genericToJSON (jsonPrefix "Contact") + toEncoding = genericToEncoding (jsonPrefix "Contact") instance ToJSON License where toJSON = genericToJSON (jsonPrefix "License") + toEncoding = genericToEncoding (jsonPrefix "License") instance ToJSON ServerVariable where toJSON = genericToJSON (jsonPrefix "ServerVariable") + toEncoding = genericToEncoding (jsonPrefix "ServerVariable") instance ToJSON ApiKeyLocation where toJSON = genericToJSON (jsonPrefix "ApiKey") - -instance ToJSON ApiKeyParams where - toJSON = genericToJSON (jsonPrefix "apiKey") + toEncoding = genericToEncoding (jsonPrefix "ApiKey") instance ToJSON Tag where toJSON = genericToJSON (jsonPrefix "Tag") + toEncoding = genericToEncoding (jsonPrefix "Tag") instance ToJSON ExternalDocs where toJSON = genericToJSON (jsonPrefix "ExternalDocs") + toEncoding = genericToEncoding (jsonPrefix "ExternalDocs") instance ToJSON Xml where toJSON = genericToJSON (jsonPrefix "Xml") + toEncoding = genericToEncoding (jsonPrefix "Xml") instance ToJSON Discriminator where toJSON = genericToJSON (jsonPrefix "Discriminator") - -instance ToJSON OAuth2ImplicitFlow where - toJSON = genericToJSON (jsonPrefix "OAuth2ImplicitFlow") - -instance ToJSON OAuth2PasswordFlow where - toJSON = genericToJSON (jsonPrefix "OAuth2PasswordFlow") - -instance ToJSON OAuth2ClientCredentialsFlow where - toJSON = genericToJSON (jsonPrefix "OAuth2ClientCredentialsFlow") - -instance ToJSON OAuth2AuthorizationCodeFlow where - toJSON = genericToJSON (jsonPrefix "OAuth2AuthorizationCodeFlow") + toEncoding = genericToEncoding (jsonPrefix "Discriminator") -- ======================================================================= -- Simple Generic-based FromJSON instances @@ -1243,9 +1248,6 @@ instance FromJSON ServerVariable where instance FromJSON ApiKeyLocation where parseJSON = genericParseJSON (jsonPrefix "ApiKey") -instance FromJSON ApiKeyParams where - parseJSON = genericParseJSON (jsonPrefix "apiKey") - instance FromJSON Tag where parseJSON = genericParseJSON (jsonPrefix "Tag") @@ -1255,24 +1257,13 @@ instance FromJSON ExternalDocs where instance FromJSON Discriminator where parseJSON = genericParseJSON (jsonPrefix "Discriminator") -instance FromJSON OAuth2ImplicitFlow where - parseJSON = genericParseJSON (jsonPrefix "OAuth2ImplicitFlow") - -instance FromJSON OAuth2PasswordFlow where - parseJSON = genericParseJSON (jsonPrefix "OAuth2PasswordFlow") - -instance FromJSON OAuth2ClientCredentialsFlow where - parseJSON = genericParseJSON (jsonPrefix "OAuth2ClientCredentialsFlow") - -instance FromJSON OAuth2AuthorizationCodeFlow where - parseJSON = genericParseJSON (jsonPrefix "OAuth2AuthorizationCodeFlow") - -- ======================================================================= -- Manual ToJSON instances -- ======================================================================= instance ToJSON OpenApiSpecVersion where toJSON (OpenApiSpecVersion v)= toJSON . showVersion $ v + toEncoding (OpenApiSpecVersion v) = toEncoding . showVersion $ v instance ToJSON MediaType where toJSON = toJSON . show @@ -1281,17 +1272,38 @@ instance ToJSON MediaType where instance ToJSONKey MediaType where toJSONKey = JSON.toJSONKeyText (Text.pack . show) -instance (Eq p, ToJSON p, AesonDefaultValue p) => ToJSON (OAuth2Flow p) where - toJSON a = sopSwaggerGenericToJSON a & - if InsOrdHashMap.null (_oAuth2Scopes a) - then (<+> object ["scopes" .= object []]) - else id - toEncoding = sopSwaggerGenericToEncoding +instance (Eq p, ToJSON p, SubObjectSeries p, AesonDefaultValue p) => ToJSON (OAuth2Flow p) where + toJSON = sopSwaggerGenericToJSON + toEncoding = sopSwaggerGenericToEncodingWithSub (subObjectSeries . _oAuth2Params) instance ToJSON OAuth2Flows where toJSON = sopSwaggerGenericToJSON toEncoding = sopSwaggerGenericToEncoding +-- | The members 'SecuritySchemeType' contributes to the enclosing +-- 'SecurityScheme' object. +securitySchemeTypeSeries :: SecuritySchemeType -> Series +securitySchemeTypeSeries (SecuritySchemeHttp ty) = case ty of + HttpSchemeBearer mFmt -> + "type" .= ("http" :: Text) + <> "scheme" .= ("bearer" :: Text) + <> maybe mempty ("bearerFormat" .=) mFmt + HttpSchemeBasic -> + "type" .= ("http" :: Text) + <> "scheme" .= ("basic" :: Text) + HttpSchemeCustom t -> + "type" .= ("http" :: Text) + <> "scheme" .= t +securitySchemeTypeSeries (SecuritySchemeApiKey params) = + sopSwaggerGenericToSeries params + <> "type" .= ("apiKey" :: Text) +securitySchemeTypeSeries (SecuritySchemeOAuth2 params) = + "type" .= ("oauth2" :: Text) + <> "flows" .= params +securitySchemeTypeSeries (SecuritySchemeOpenIdConnect url) = + "type" .= ("openIdConnect" :: Text) + <> "openIdConnectUrl" .= url + instance ToJSON SecuritySchemeType where toJSON (SecuritySchemeHttp ty) = case ty of HttpSchemeBearer mFmt -> @@ -1318,12 +1330,45 @@ instance ToJSON SecuritySchemeType where , "openIdConnectUrl" .= url ] + toEncoding = pairs . securitySchemeTypeSeries + instance ToJSON OpenApi where - toJSON a = sopSwaggerGenericToJSON a & - if InsOrdHashMap.null (_openApiPaths a) - then (<+> object ["paths" .= object []]) - else id + toJSON = sopSwaggerGenericToJSON + toEncoding = sopSwaggerGenericToEncoding + +-- | Encoded via generics-sop rather than @'jsonPrefix' "apiKey"@ so that +-- 'SecuritySchemeType' can splice these fields into the enclosing +-- @"type": "apiKey"@ object as a 'Series'. Both derive the same field names. +instance ToJSON ApiKeyParams where + toJSON = sopSwaggerGenericToJSON + toEncoding = sopSwaggerGenericToEncoding + +-- | The four OAuth2 flow parameter records. Encoded via generics-sop rather +-- than @'jsonPrefix'@ so that 'OAuth2Flow' can splice their fields into the +-- enclosing object as a 'Series'. Both derive the same field names. +instance ToJSON OAuth2ImplicitFlow where + toJSON = sopSwaggerGenericToJSON toEncoding = sopSwaggerGenericToEncoding +instance SubObjectSeries OAuth2ImplicitFlow where + subObjectSeries = sopSwaggerGenericToSeries + +instance ToJSON OAuth2PasswordFlow where + toJSON = sopSwaggerGenericToJSON + toEncoding = sopSwaggerGenericToEncoding +instance SubObjectSeries OAuth2PasswordFlow where + subObjectSeries = sopSwaggerGenericToSeries + +instance ToJSON OAuth2ClientCredentialsFlow where + toJSON = sopSwaggerGenericToJSON + toEncoding = sopSwaggerGenericToEncoding +instance SubObjectSeries OAuth2ClientCredentialsFlow where + subObjectSeries = sopSwaggerGenericToSeries + +instance ToJSON OAuth2AuthorizationCodeFlow where + toJSON = sopSwaggerGenericToJSON + toEncoding = sopSwaggerGenericToEncoding +instance SubObjectSeries OAuth2AuthorizationCodeFlow where + subObjectSeries = sopSwaggerGenericToSeries instance ToJSON Server where toJSON = sopSwaggerGenericToJSON @@ -1331,11 +1376,14 @@ instance ToJSON Server where instance ToJSON SecurityScheme where toJSON = sopSwaggerGenericToJSON - toEncoding = sopSwaggerGenericToEncoding + toEncoding = sopSwaggerGenericToEncodingWithSub (securitySchemeTypeSeries . _securitySchemeType) instance ToJSON Schema where toJSON = sopSwaggerGenericToJSONWithOpts $ mkSwaggerAesonOptions "schema" & saoSubObject ?~ "items" + toEncoding = sopSwaggerGenericToEncodingWithOpts + (mkSwaggerAesonOptions "schema" & saoSubObject ?~ "items") + (foldMap openApiItemsSeries . _schemaItems) instance ToJSON Header where toJSON = sopSwaggerGenericToJSON @@ -1351,6 +1399,15 @@ instance ToJSON Header where -- "maxItems": 0 -- } -- +-- | The members 'OpenApiItems' contributes to the enclosing 'Schema' object. +openApiItemsSeries :: OpenApiItems -> Series +openApiItemsSeries (OpenApiItemsObject x) = "items" .= x +openApiItemsSeries (OpenApiItemsArray []) = + "items" .= object [] + <> "maxItems" .= (0 :: Int) + <> "example" .= Array mempty +openApiItemsSeries (OpenApiItemsArray x) = "items" .= x + instance ToJSON OpenApiItems where toJSON (OpenApiItemsObject x) = object [ "items" .= x ] toJSON (OpenApiItemsArray []) = object @@ -1360,20 +1417,28 @@ instance ToJSON OpenApiItems where ] toJSON (OpenApiItemsArray x) = object [ "items" .= x ] + toEncoding = pairs . openApiItemsSeries + instance ToJSON Components where toJSON = sopSwaggerGenericToJSON toEncoding = sopSwaggerGenericToEncoding instance ToJSON MimeList where toJSON (MimeList xs) = toJSON (map show xs) + toEncoding (MimeList xs) = toEncoding (map show xs) instance ToJSON Param where toJSON = sopSwaggerGenericToJSON toEncoding = sopSwaggerGenericToEncoding +-- | The members of the responses map, spliced into the enclosing 'Responses' +-- object. Status-code keys render as decimal strings, matching @'ToJSONKey' Int@. +responsesSeries :: InsOrdHashMap HttpStatusCode (Referenced Response) -> Series +responsesSeries = InsOrdHashMap.foldrWithKey (\k v rest -> (stringToKey (show k) .= v) <> rest) mempty + instance ToJSON Responses where toJSON = sopSwaggerGenericToJSON - toEncoding = sopSwaggerGenericToEncoding + toEncoding = sopSwaggerGenericToEncodingWithSub (responsesSeries . _responsesResponses) instance ToJSON Response where toJSON = sopSwaggerGenericToJSON @@ -1409,33 +1474,60 @@ instance ToJSON Link where instance ToJSON SecurityDefinitions where toJSON (SecurityDefinitions sd) = toJSON sd + toEncoding (SecurityDefinitions sd) = toEncoding sd instance ToJSON Reference where toJSON (Reference ref) = object [ "$ref" .= ref ] + toEncoding (Reference ref) = pairs ( "$ref" .= ref ) referencedToJSON :: ToJSON a => Text -> Referenced a -> Value referencedToJSON prefix (Ref (Reference ref)) = object [ "$ref" .= (prefix <> ref) ] referencedToJSON _ (Inline x) = toJSON x -instance ToJSON (Referenced Schema) where toJSON = referencedToJSON "#/components/schemas/" -instance ToJSON (Referenced Param) where toJSON = referencedToJSON "#/components/parameters/" -instance ToJSON (Referenced Response) where toJSON = referencedToJSON "#/components/responses/" -instance ToJSON (Referenced RequestBody) where toJSON = referencedToJSON "#/components/requestBodies/" -instance ToJSON (Referenced Example) where toJSON = referencedToJSON "#/components/examples/" -instance ToJSON (Referenced Header) where toJSON = referencedToJSON "#/components/headers/" -instance ToJSON (Referenced Link) where toJSON = referencedToJSON "#/components/links/" -instance ToJSON (Referenced Callback) where toJSON = referencedToJSON "#/components/callbacks/" +referencedToEncoding :: ToJSON a => Text -> Referenced a -> JSON.Encoding +referencedToEncoding prefix (Ref (Reference ref)) = pairs $ "$ref" .= (prefix <> ref) +referencedToEncoding _ (Inline x) = toEncoding x + +instance ToJSON (Referenced Schema) where + toJSON = referencedToJSON "#/components/schemas/" + toEncoding = referencedToEncoding "#/components/schemas/" +instance ToJSON (Referenced Param) where + toJSON = referencedToJSON "#/components/parameters/" + toEncoding = referencedToEncoding "#/components/parameters/" +instance ToJSON (Referenced Response) where + toJSON = referencedToJSON "#/components/responses/" + toEncoding = referencedToEncoding "#/components/responses/" +instance ToJSON (Referenced RequestBody) where + toJSON = referencedToJSON "#/components/requestBodies/" + toEncoding = referencedToEncoding "#/components/requestBodies/" +instance ToJSON (Referenced Example) where + toJSON = referencedToJSON "#/components/examples/" + toEncoding = referencedToEncoding "#/components/examples/" +instance ToJSON (Referenced Header) where + toJSON = referencedToJSON "#/components/headers/" + toEncoding = referencedToEncoding "#/components/headers/" +instance ToJSON (Referenced Link) where + toJSON = referencedToJSON "#/components/links/" + toEncoding = referencedToEncoding "#/components/links/" +instance ToJSON (Referenced Callback) where + toJSON = referencedToJSON "#/components/callbacks/" + toEncoding = referencedToEncoding "#/components/callbacks/" instance ToJSON AdditionalProperties where toJSON (AdditionalPropertiesAllowed b) = toJSON b toJSON (AdditionalPropertiesSchema s) = toJSON s + toEncoding (AdditionalPropertiesAllowed b) = toEncoding b + toEncoding (AdditionalPropertiesSchema s) = toEncoding s instance ToJSON ExpressionOrValue where toJSON (Expression expr) = toJSON expr toJSON (Value val) = toJSON val + toEncoding (Expression expr) = toEncoding expr + toEncoding (Value val) = toEncoding val instance ToJSON Callback where toJSON (Callback ps) = toJSON ps + toEncoding (Callback ps) = toEncoding ps -- ======================================================================= -- Manual FromJSON instances @@ -1464,6 +1556,21 @@ instance FromJSON MediaType where instance FromJSONKey MediaType where fromJSONKey = FromJSONKeyTextParser (parseJSON . String) +instance FromJSON ApiKeyParams where + parseJSON = sopSwaggerGenericParseJSON + +instance FromJSON OAuth2ImplicitFlow where + parseJSON = sopSwaggerGenericParseJSON + +instance FromJSON OAuth2PasswordFlow where + parseJSON = sopSwaggerGenericParseJSON + +instance FromJSON OAuth2ClientCredentialsFlow where + parseJSON = sopSwaggerGenericParseJSON + +instance FromJSON OAuth2AuthorizationCodeFlow where + parseJSON = sopSwaggerGenericParseJSON + instance (Eq p, FromJSON p, AesonDefaultValue p) => FromJSON (OAuth2Flow p) where parseJSON = sopSwaggerGenericParseJSON @@ -1602,10 +1709,21 @@ instance HasSwaggerAesonOptions Server where swaggerAesonOptions _ = mkSwaggerAesonOptions "server" instance HasSwaggerAesonOptions Components where swaggerAesonOptions _ = mkSwaggerAesonOptions "components" +instance HasSwaggerAesonOptions ApiKeyParams where + swaggerAesonOptions _ = mkSwaggerAesonOptions "apiKey" +instance HasSwaggerAesonOptions OAuth2ImplicitFlow where + swaggerAesonOptions _ = mkSwaggerAesonOptions "oAuth2ImplicitFlow" +instance HasSwaggerAesonOptions OAuth2PasswordFlow where + swaggerAesonOptions _ = mkSwaggerAesonOptions "oAuth2PasswordFlow" +instance HasSwaggerAesonOptions OAuth2ClientCredentialsFlow where + swaggerAesonOptions _ = mkSwaggerAesonOptions "oAuth2ClientCredentialsFlow" +instance HasSwaggerAesonOptions OAuth2AuthorizationCodeFlow where + swaggerAesonOptions _ = mkSwaggerAesonOptions "oAuth2AuthorizationCodeFlow" instance HasSwaggerAesonOptions Header where swaggerAesonOptions _ = mkSwaggerAesonOptions "header" instance AesonDefaultValue p => HasSwaggerAesonOptions (OAuth2Flow p) where swaggerAesonOptions _ = mkSwaggerAesonOptions "oauth2" & saoSubObject ?~ "params" + & saoRequiredFields .~ ["scopes"] instance HasSwaggerAesonOptions OAuth2Flows where swaggerAesonOptions _ = mkSwaggerAesonOptions "oauth2Flows" instance HasSwaggerAesonOptions Operation where @@ -1625,11 +1743,11 @@ instance HasSwaggerAesonOptions Responses where instance HasSwaggerAesonOptions SecurityScheme where swaggerAesonOptions _ = mkSwaggerAesonOptions "securityScheme" & saoSubObject ?~ "type" instance HasSwaggerAesonOptions Schema where - swaggerAesonOptions _ = mkSwaggerAesonOptions "schema" & saoSubObject ?~ "paramSchema" + swaggerAesonOptions _ = mkSwaggerAesonOptions "schema" instance HasSwaggerAesonOptions OpenApiSpecVersion where swaggerAesonOptions _ = mkSwaggerAesonOptions "openapi" instance HasSwaggerAesonOptions OpenApi where - swaggerAesonOptions _ = mkSwaggerAesonOptions "swagger" + swaggerAesonOptions _ = mkSwaggerAesonOptions "swagger" & saoRequiredFields .~ ["paths"] instance HasSwaggerAesonOptions Example where swaggerAesonOptions _ = mkSwaggerAesonOptions "example" instance HasSwaggerAesonOptions Encoding where @@ -1654,6 +1772,7 @@ instance AesonDefaultValue OpenApiType instance AesonDefaultValue MimeList where defaultValue = Just mempty instance AesonDefaultValue Info instance AesonDefaultValue ParamLocation +instance AesonDefaultValue ApiKeyLocation instance AesonDefaultValue Link instance AesonDefaultValue SecurityDefinitions where defaultValue = Just mempty diff --git a/src/Data/OpenApi/Internal/AesonUtils.hs b/src/Data/OpenApi/Internal/AesonUtils.hs index 2b1e2625..cb4a0307 100644 --- a/src/Data/OpenApi/Internal/AesonUtils.hs +++ b/src/Data/OpenApi/Internal/AesonUtils.hs @@ -3,27 +3,29 @@ module Data.OpenApi.Internal.AesonUtils ( AesonDefaultValue(..), sopSwaggerGenericToJSON, sopSwaggerGenericToEncoding, + sopSwaggerGenericToSeries, sopSwaggerGenericToJSONWithOpts, + sopSwaggerGenericToEncodingWithOpts, + sopSwaggerGenericToEncodingWithSub, sopSwaggerGenericParseJSON, + SubObjectSeries (..), -- * Options HasSwaggerAesonOptions(..), SwaggerAesonOptions, mkSwaggerAesonOptions, saoPrefix, - saoAdditionalPairs, saoSubObject, + saoRequiredFields, ) where import Prelude () import Prelude.Compat import Control.Applicative ((<|>)) -import Control.Lens (makeLenses, (^.)) -import Control.Monad (unless) +import Control.Lens (makeLenses) import Data.Aeson (ToJSON(..), FromJSON(..), Value(..), Object, object, (.:), (.:?), (.!=), withObject, Encoding, pairs, (.=), Series) import Data.Aeson.Types (Parser, Pair) import Data.Char (toLower, isUpper) -import Data.Foldable (traverse_) import Data.Text (Text) import Generics.SOP @@ -33,25 +35,35 @@ import qualified Data.Set as Set import qualified Data.HashMap.Strict.InsOrd.Compat as InsOrd import qualified Data.HashSet.InsOrd as InsOrdHS -import Data.OpenApi.Aeson.Compat (keyToString, objectToList, stringToKey) +import Data.OpenApi.Aeson.Compat (objectToList, stringToKey) ------------------------------------------------------------------------------- -- SwaggerAesonOptions ------------------------------------------------------------------------------- data SwaggerAesonOptions = SwaggerAesonOptions - { _saoPrefix :: String - , _saoAdditionalPairs :: [Pair] - , _saoSubObject :: Maybe String + { _saoPrefix :: String + , _saoSubObject :: Maybe String + -- | Fields that must be serialised, rather than omitted, even when they hold their + -- default value, because the OpenAPI schema requires them to be present. + , _saoRequiredFields :: [String] } mkSwaggerAesonOptions :: String -- ^ prefix -> SwaggerAesonOptions -mkSwaggerAesonOptions pfx = SwaggerAesonOptions pfx [] Nothing +mkSwaggerAesonOptions pfx = SwaggerAesonOptions pfx Nothing [] makeLenses ''SwaggerAesonOptions +{- | Types whose fields are merged into the enclosing object rather than nested +under a key of their own (see 'saoSubObject'). Encoding needs those fields as a +'Series'; 'ToJSON' can only supply a finished 'Encoding', which is an opaque +'Builder' and cannot be taken apart. +-} +class ToJSON a => SubObjectSeries a where + subObjectSeries :: a -> Series + class (Generic a, All2 AesonDefaultValue (Code a)) => HasSwaggerAesonOptions a where swaggerAesonOptions :: Proxy a -> SwaggerAesonOptions @@ -83,7 +95,7 @@ instance AesonDefaultValue (InsOrd.InsOrdHashMap k v) where defaultValue = Just -- Features -- -- * omits nulls, empty objects and empty arrays (configurable) --- * possible to add fields +-- * possible to force required fields to be emitted even when empty -- * possible to merge sub-object sopSwaggerGenericToJSON :: forall a xs. @@ -97,12 +109,13 @@ sopSwaggerGenericToJSON -> Value sopSwaggerGenericToJSON x = let ps = sopSwaggerGenericToJSON' opts (from x) (datatypeInfo proxy) (aesonDefaults proxy) - in object (opts ^. saoAdditionalPairs ++ ps) + in object ps where proxy = Proxy :: Proxy a opts = swaggerAesonOptions proxy --- | *TODO:* This is only used by ToJSON (ParamSchema SwaggerKindSchema) +-- | As 'sopSwaggerGenericToJSON', with explicit options. Used by 'Schema', +-- which overrides the sub-object of its 'HasSwaggerAesonOptions' instance. -- -- Also uses default `aesonDefaults` sopSwaggerGenericToJSONWithOpts @@ -119,7 +132,7 @@ sopSwaggerGenericToJSONWithOpts -> Value sopSwaggerGenericToJSONWithOpts opts x = let ps = sopSwaggerGenericToJSON' opts (from x) (datatypeInfo proxy) defs - in object (opts ^. saoAdditionalPairs ++ ps) + in object ps where proxy = Proxy :: Proxy a defs = hcpure (Proxy :: Proxy AesonDefaultValue) defaultValue @@ -133,6 +146,8 @@ sopSwaggerGenericToJSON' -> [Pair] sopSwaggerGenericToJSON' opts (SOP (Z fields)) (ADT _ _ (Record _ fieldsInfo :* Nil) _) (POP (defs :* Nil)) = sopSwaggerGenericToJSON'' opts fields fieldsInfo defs +sopSwaggerGenericToJSON' opts (SOP (Z fields)) (Newtype _ _ (Record _ fieldsInfo)) (POP (defs :* Nil)) = + sopSwaggerGenericToJSON'' opts fields fieldsInfo defs sopSwaggerGenericToJSON' _ _ _ _ = error "sopSwaggerGenericToJSON: unsupported type" sopSwaggerGenericToJSON'' @@ -142,7 +157,7 @@ sopSwaggerGenericToJSON'' -> NP FieldInfo xs -> NP Maybe xs -> [Pair] -sopSwaggerGenericToJSON'' (SwaggerAesonOptions prefix _ sub) = go +sopSwaggerGenericToJSON'' (SwaggerAesonOptions prefix sub required) = go where go :: (All ToJSON ys, All Eq ys) => NP I ys -> NP FieldInfo ys -> NP Maybe ys -> [Pair] go Nil Nil Nil = [] @@ -151,8 +166,8 @@ sopSwaggerGenericToJSON'' (SwaggerAesonOptions prefix _ sub) = go Object m -> objectToList m ++ rest Null -> rest _ -> error $ "sopSwaggerGenericToJSON: subjson is not an object: " ++ show json - -- If default value: omit it. - | Just x == def = + -- If default value: omit it, unless the field is required. + | Just x == def && name' `notElem` required = rest | otherwise = (stringToKey name', json) : rest @@ -182,21 +197,11 @@ sopSwaggerGenericParseJSON -> Parser a sopSwaggerGenericParseJSON = withObject "Swagger Record Object" $ \obj -> let ps = sopSwaggerGenericParseJSON' opts obj (datatypeInfo proxy) (aesonDefaults proxy) - in do - traverse_ (parseAdditionalField obj) (opts ^. saoAdditionalPairs) - to <$> ps + in to <$> ps where proxy = Proxy :: Proxy a opts = swaggerAesonOptions proxy - parseAdditionalField :: Object -> Pair -> Parser () - parseAdditionalField obj (k, v) = do - v' <- obj .: k - unless (v == v') $ fail $ - "Additonal field don't match for key " ++ keyToString k - ++ ": " ++ show v - ++ " /= " ++ show v' - sopSwaggerGenericParseJSON' :: (All2 FromJSON '[xs], All2 Eq '[xs]) => SwaggerAesonOptions @@ -206,6 +211,8 @@ sopSwaggerGenericParseJSON' -> Parser (SOP I '[xs]) sopSwaggerGenericParseJSON' opts obj (ADT _ _ (Record _ fieldsInfo :* Nil) _) (POP (defs :* Nil)) = SOP . Z <$> sopSwaggerGenericParseJSON'' opts obj fieldsInfo defs +sopSwaggerGenericParseJSON' opts obj (Newtype _ _ (Record _ fieldsInfo)) (POP (defs :* Nil)) = + SOP . Z <$> sopSwaggerGenericParseJSON'' opts obj fieldsInfo defs sopSwaggerGenericParseJSON' _ _ _ _ = error "sopSwaggerGenericParseJSON: unsupported type" sopSwaggerGenericParseJSON'' @@ -215,7 +222,7 @@ sopSwaggerGenericParseJSON'' -> NP FieldInfo xs -> NP Maybe xs -> Parser (NP I xs) -sopSwaggerGenericParseJSON'' (SwaggerAesonOptions prefix _ sub) obj = go +sopSwaggerGenericParseJSON'' (SwaggerAesonOptions prefix sub _) obj = go where go :: (All FromJSON ys, All Eq ys) => NP FieldInfo ys -> NP Maybe ys -> Parser (NP I ys) go Nil Nil = pure Nil @@ -254,45 +261,112 @@ sopSwaggerGenericToEncoding ) => a -> Encoding -sopSwaggerGenericToEncoding x = - let ps = sopSwaggerGenericToEncoding' opts (from x) (datatypeInfo proxy) (aesonDefaults proxy) - in pairs (pairsToSeries (opts ^. saoAdditionalPairs) <> ps) +sopSwaggerGenericToEncoding = pairs . sopSwaggerGenericToSeries + +-- | As 'sopSwaggerGenericToEncoding', but returning the record's fields as a +-- 'Series' rather than a finished object 'Encoding'. Useful when an instance +-- needs to splice those fields into an enclosing object. +sopSwaggerGenericToSeries + :: forall a xs. + ( HasDatatypeInfo a + , HasSwaggerAesonOptions a + , All2 ToJSON (Code a) + , All2 Eq (Code a) + , Code a ~ '[xs] + ) + => a + -> Series +sopSwaggerGenericToSeries = sopSwaggerGenericToSeriesWith Nothing + +-- | As 'sopSwaggerGenericToEncoding', for a record that declares a +-- 'saoSubObject'. The caller supplies that field's members, because the +-- generic traversal only has 'ToJSON' for them and could not take the +-- resulting 'Encoding' apart. +sopSwaggerGenericToEncodingWithSub + :: forall a xs. + ( HasDatatypeInfo a + , HasSwaggerAesonOptions a + , All2 ToJSON (Code a) + , All2 Eq (Code a) + , Code a ~ '[xs] + ) + => (a -> Series) + -> a + -> Encoding +sopSwaggerGenericToEncodingWithSub sub x = + pairs (sopSwaggerGenericToSeriesWith (Just (sub x)) x) + +sopSwaggerGenericToSeriesWith + :: forall a xs. + ( HasDatatypeInfo a + , HasSwaggerAesonOptions a + , All2 ToJSON (Code a) + , All2 Eq (Code a) + , Code a ~ '[xs] + ) + => Maybe Series + -> a + -> Series +sopSwaggerGenericToSeriesWith sub x = + sopSwaggerGenericToEncoding' opts sub (from x) (datatypeInfo proxy) (aesonDefaults proxy) where proxy = Proxy :: Proxy a opts = swaggerAesonOptions proxy -pairsToSeries :: [Pair] -> Series -pairsToSeries = foldMap (\(k, v) -> (k .= v)) +-- | As 'sopSwaggerGenericToEncodingWithSub', with explicit options. +sopSwaggerGenericToEncodingWithOpts + :: forall a xs. + ( Generic a + , All2 AesonDefaultValue (Code a) + , HasDatatypeInfo a + , All2 ToJSON (Code a) + , All2 Eq (Code a) + , Code a ~ '[xs] + ) + => SwaggerAesonOptions + -> (a -> Series) + -> a + -> Encoding +sopSwaggerGenericToEncodingWithOpts opts sub x = + let ps = sopSwaggerGenericToEncoding' opts (Just (sub x)) (from x) (datatypeInfo proxy) defs + in pairs ps + where + proxy = Proxy :: Proxy a + defs = hcpure (Proxy :: Proxy AesonDefaultValue) defaultValue sopSwaggerGenericToEncoding' :: (All2 ToJSON '[xs], All2 Eq '[xs]) => SwaggerAesonOptions + -> Maybe Series -> SOP I '[xs] -> DatatypeInfo '[xs] -> POP Maybe '[xs] -> Series -sopSwaggerGenericToEncoding' opts (SOP (Z fields)) (ADT _ _ (Record _ fieldsInfo :* Nil) _) (POP (defs :* Nil)) = - sopSwaggerGenericToEncoding'' opts fields fieldsInfo defs -sopSwaggerGenericToEncoding' _ _ _ _ = error "sopSwaggerGenericToEncoding: unsupported type" +sopSwaggerGenericToEncoding' opts sub (SOP (Z fields)) (ADT _ _ (Record _ fieldsInfo :* Nil) _) (POP (defs :* Nil)) = + sopSwaggerGenericToEncoding'' opts sub fields fieldsInfo defs +sopSwaggerGenericToEncoding' opts sub (SOP (Z fields)) (Newtype _ _ (Record _ fieldsInfo)) (POP (defs :* Nil)) = + sopSwaggerGenericToEncoding'' opts sub fields fieldsInfo defs +sopSwaggerGenericToEncoding' _ _ _ _ _ = error "sopSwaggerGenericToEncoding: unsupported type" sopSwaggerGenericToEncoding'' :: (All ToJSON xs, All Eq xs) => SwaggerAesonOptions + -> Maybe Series -> NP I xs -> NP FieldInfo xs -> NP Maybe xs -> Series -sopSwaggerGenericToEncoding'' (SwaggerAesonOptions prefix _ sub) = go +sopSwaggerGenericToEncoding'' (SwaggerAesonOptions prefix sub required) subSeries = go where go :: (All ToJSON ys, All Eq ys) => NP I ys -> NP FieldInfo ys -> NP Maybe ys -> Series go Nil Nil Nil = mempty go (I x :* xs) (FieldInfo name :* names) (def :* defs) - | Just name' == sub = case toJSON x of - Object m -> pairsToSeries (objectToList m) <> rest - Null -> rest - _ -> error $ "sopSwaggerGenericToJSON: subjson is not an object: " ++ show (toJSON x) - -- If default value: omit it. - | Just x == def = + | Just name' == sub = case subSeries of + Just s -> s <> rest + Nothing -> error $ + "sopSwaggerGenericToEncoding: no Series supplied for sub-object field " ++ name' + -- If default value: omit it, unless the field is required. + | Just x == def && name' `notElem` required = rest | otherwise = (stringToKey name' .= x) <> rest diff --git a/test/SpecCommon.hs b/test/SpecCommon.hs index 11828fb8..2bfcd724 100644 --- a/test/SpecCommon.hs +++ b/test/SpecCommon.hs @@ -20,3 +20,6 @@ x <=> js = do eitherDecode (encode $ toJSON x) `shouldBe` Right x it "roundtrips with toEncoding" $ do eitherDecode (toLazyByteString $ fromEncoding $ toEncoding x) `shouldBe` Right x + it "toEncoding is consistent with toJSON" $ do + (eitherDecode (toLazyByteString $ fromEncoding $ toEncoding x) :: Either String Value) + `shouldBe` Right (toJSON x)