diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,13 @@ # Changelog +## [0.2.0.0] - 2022-04-05 + +### Changed +* Fixed an issue where, when using `named` and mutually recursive types, not all schemas would be declared when the top level type was declared with `declareSchemaRef` from openapi3 (#16) +* Fixed an issue where using `named` would declare a named schema, but would return an un-named schema, sometimes leading to duplicate schema definitions (#16) +* `declareSpecificNamedSchemaRef` and `declareSpecificSchemaRef` now work with any `MonadDeclare`, not just the `Declare` concrete monad (#16) +* Added a type field when generating enum schema from `EqCodec`. This is required so that enum values are shown in `swagger-ui`. + ## [0.1.0.0] - 2021-12-23 ### Added diff --git a/autodocodec-openapi3.cabal b/autodocodec-openapi3.cabal --- a/autodocodec-openapi3.cabal +++ b/autodocodec-openapi3.cabal @@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.5. +-- This file has been generated from package.yaml by hpack version 0.34.6. -- -- see: https://github.com/sol/hpack name: autodocodec-openapi3 -version: 0.1.0.0 +version: 0.2.0.0 synopsis: Autodocodec interpreters for openapi3 homepage: https://github.com/NorfairKing/autodocodec#readme bug-reports: https://github.com/NorfairKing/autodocodec/issues @@ -38,7 +38,9 @@ , base >=4.7 && <5 , insert-ordered-containers , lens + , mtl , openapi3 , scientific , text + , unordered-containers default-language: Haskell2010 diff --git a/src/Autodocodec/OpenAPI/Schema.hs b/src/Autodocodec/OpenAPI/Schema.hs --- a/src/Autodocodec/OpenAPI/Schema.hs +++ b/src/Autodocodec/OpenAPI/Schema.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedLists #-} @@ -12,6 +13,12 @@ import Autodocodec import Control.Lens (Lens', (&), (?~), (^.)) import Control.Monad +import Control.Monad.State.Lazy (StateT, evalStateT, runStateT) +import qualified Control.Monad.State.Lazy as State +import Control.Monad.Trans (lift) +import qualified Data.Aeson as Aeson +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap import Data.OpenApi as OpenAPI import Data.OpenApi.Declare as OpenAPI @@ -25,9 +32,9 @@ -- | Use a given 'codec' to implement 'declareNamedSchema'. declareNamedSchemaVia :: JSONCodec value -> Proxy value -> Declare (Definitions Schema) NamedSchema -declareNamedSchemaVia c' Proxy = go c' +declareNamedSchemaVia c' Proxy = evalStateT (go c') mempty where - go :: ValueCodec input output -> Declare (Definitions Schema) NamedSchema + go :: ValueCodec input output -> StateT (HashMap Text Schema) (Declare (Definitions Schema)) NamedSchema go = \case NullCodec -> pure $ @@ -35,10 +42,10 @@ mempty { _schemaType = Just OpenApiNull } - BoolCodec mname -> NamedSchema mname <$> declareSchema (Proxy :: Proxy Bool) - StringCodec mname -> NamedSchema mname <$> declareSchema (Proxy :: Proxy Text) + BoolCodec mname -> lift $ NamedSchema mname <$> declareSchema (Proxy :: Proxy Bool) + StringCodec mname -> lift $ NamedSchema mname <$> declareSchema (Proxy :: Proxy Text) NumberCodec mname mBounds -> do - s <- declareSchema (Proxy :: Proxy Scientific) + s <- lift $ declareSchema (Proxy :: Proxy Scientific) let addNumberBounds NumberBounds {..} s_ = s_ { _schemaMinimum = Just numberBoundsLower, @@ -80,15 +87,23 @@ EqCodec val valCodec -> pure $ NamedSchema Nothing $ - mempty - { _schemaEnum = Just [toJSONVia valCodec val] - } + let jsonVal = toJSONVia valCodec val + in mempty + { _schemaEnum = Just [jsonVal], + _schemaType = Just $ case jsonVal of + Aeson.Object {} -> OpenApiObject + Aeson.Array {} -> OpenApiArray + Aeson.String {} -> OpenApiString + Aeson.Number {} -> OpenApiNumber + Aeson.Bool {} -> OpenApiBoolean + Aeson.Null -> OpenApiNull + } BimapCodec _ _ c -> go c ObjectOfCodec mname oc -> do ss <- goObject oc pure $ NamedSchema mname $ combineObjectSchemas ss EitherCodec u c1 c2 -> - let orNull :: forall input output. ValueCodec input output -> Declare (Definitions Schema) NamedSchema + let orNull :: forall input output. ValueCodec input output -> StateT (HashMap Text Schema) (Declare (Definitions Schema)) NamedSchema orNull c = do ns <- go c pure $ ns & schema . nullable ?~ True @@ -103,17 +118,28 @@ NamedSchema mName s <- go c pure $ NamedSchema mName $ addDoc t s ReferenceCodec n c -> do - d <- look - case InsOrdHashMap.lookup n d of + seenSchemas <- State.get + case HashMap.lookup n seenSchemas of Nothing -> do - -- Insert a dummy to prevent an infinite loop. - let dummy = mempty - let (d', ns) = runDeclare (go c) (InsOrdHashMap.insert n dummy d) - -- Override the dummy once we actually know what the result will be. - declare $ InsOrdHashMap.insert n (_namedSchemaSchema ns) d' - pure ns - Just s -> pure $ NamedSchema (Just n) s - goObject :: ObjectCodec input output -> Declare (Definitions Schema) [Schema] + existingDeclaredSchemas <- look + + -- Insert a dummy schema to prevent an infinite loop in recursive data structures + let dummySchema = mempty + let seenSchemas' = HashMap.insert n dummySchema seenSchemas + + -- Run in a new isolated Declare monad so that we can get the results and override + -- the dummy before declaring it in our main Declare monad (Declare does not allow overriding itself) + let (newDeclaredSchemas, (namedSchema, newSeenSchemas)) = flip runDeclare existingDeclaredSchemas . flip runStateT seenSchemas' $ go c + + -- Override the dummy now we actually know what the result will be + State.put $ HashMap.insert n (_namedSchemaSchema namedSchema) newSeenSchemas + declare $ InsOrdHashMap.insert n (_namedSchemaSchema namedSchema) newDeclaredSchemas + pure $ namedSchema {_namedSchemaName = Just n} + Just s -> + -- We've been here before recursively, just reuse the schema we've previously created + pure $ NamedSchema (Just n) s + + goObject :: ObjectCodec input output -> StateT (HashMap Text Schema) (Declare (Definitions Schema)) [Schema] goObject = \case RequiredKeyCodec key vs mDoc -> do ns <- go vs @@ -159,8 +185,10 @@ ss2 <- goObject oc2 pure $ ss1 ++ ss2 BimapCodec _ _ oc -> goObject oc + addMDoc :: Maybe Text -> Schema -> Schema addMDoc = maybe id addDoc + addDoc :: Text -> Schema -> Schema addDoc doc s = s @@ -168,9 +196,11 @@ Nothing -> Just doc Just doc' -> Just $ doc <> "\n" <> doc' } + combineObjectSchemas :: [Schema] -> Schema combineObjectSchemas = mconcat - combineSchemasOr :: Union -> NamedSchema -> NamedSchema -> Declare (Definitions Schema) NamedSchema + + combineSchemasOr :: MonadDeclare (Definitions Schema) m => Union -> NamedSchema -> NamedSchema -> m NamedSchema combineSchemasOr u ns1 ns2 = do let s1 = _namedSchemaSchema ns1 let s2 = _namedSchemaSchema ns2 @@ -193,12 +223,12 @@ (Nothing, Just s2s) -> prototype & orLens ?~ (s1Ref : s2s) (Nothing, Nothing) -> prototype & orLens ?~ [s1Ref, s2Ref] -declareSpecificNamedSchemaRef :: OpenAPI.NamedSchema -> Declare (Definitions Schema) (Referenced NamedSchema) +declareSpecificNamedSchemaRef :: MonadDeclare (Definitions Schema) m => OpenAPI.NamedSchema -> m (Referenced NamedSchema) declareSpecificNamedSchemaRef namedSchema = fmap (NamedSchema (_namedSchemaName namedSchema)) <$> declareSpecificSchemaRef (_namedSchemaName namedSchema) (_namedSchemaSchema namedSchema) -declareSpecificSchemaRef :: Maybe Text -> OpenAPI.Schema -> Declare (Definitions Schema) (Referenced Schema) +declareSpecificSchemaRef :: MonadDeclare (Definitions Schema) m => Maybe Text -> OpenAPI.Schema -> m (Referenced Schema) declareSpecificSchemaRef mName s = case mName of Nothing -> pure $ Inline s