autodocodec-openapi3 0.1.0.0 → 0.2.0.0
raw patch · 3 files changed
+64/−24 lines, 3 filesdep +mtldep +unordered-containers
Dependencies added: mtl, unordered-containers
Files
- CHANGELOG.md +8/−0
- autodocodec-openapi3.cabal +4/−2
- src/Autodocodec/OpenAPI/Schema.hs +52/−22
CHANGELOG.md view
@@ -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
autodocodec-openapi3.cabal view
@@ -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
src/Autodocodec/OpenAPI/Schema.hs view
@@ -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