diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,43 @@ Unreleased ---------- +3.2.5 +----- + +- Support insert-ordered-containers 0.3 [#119](https://github.com/biocad/openapi3/pull/119). + +3.2.4 +----- + +- Give `title` to sub schemas of sum types [#88](https://github.com/biocad/openapi3/pull/88). + +3.2.3 +----- + +- Fix generation of `allOf` / `oneOf` schemas when variants are not objects [#49](https://github.com/biocad/openapi3/pull/49). +- Support parsing OpenAPI 3.0.1, 3.0.2, 3.0.3 versions [#68](https://github.com/biocad/openapi3/pull/68). +- Support GHC-9.4 [#61](https://github.com/biocad/openapi3/pull/61). +- Output `scopes` in schema even if empty [#65](https://github.com/biocad/openapi3/pull/65). +- Fix `mtl-2.3` compatibility [#60](https://github.com/biocad/openapi3/pull/60). + +3.2.2 +----- + +- Fix bug with infinite recursion in GToSchema [#37](https://github.com/biocad/openapi3/pull/37). + +3.2.1 +----- + +- Support aeson-2.0.3. +- Support GHC-9.2 (doctests still fail). + +3.2.0 +----- + +- Support aeson-2 [#34](https://github.com/biocad/openapi3/pull/34). +- Use `SecurityDefinitions` type for `_componentsSecuritySchemes` + [#32](https://github.com/biocad/openapi3/pull/32). + 3.1.0 ----- diff --git a/openapi3.cabal b/openapi3.cabal --- a/openapi3.cabal +++ b/openapi3.cabal @@ -1,6 +1,6 @@ cabal-version: >=1.10 name: openapi3 -version: 3.1.0 +version: 3.2.5 synopsis: OpenAPI 3.0 data model category: Web, Swagger, OpenApi @@ -23,15 +23,23 @@ , CHANGELOG.md , examples/*.hs tested-with: - GHC ==8.4.4 - || ==8.6.5 + GHC ==8.6.5 || ==8.8.4 - || ==8.10.4 - || ==9.0.1 + || ==8.10.7 + || ==9.0.2 + || ==9.2.8 + || ==9.4.8 + || ==9.6.7 + || ==9.8.4 + || ==9.10.3 + || ==9.12.4 + || ==9.14.1 custom-setup setup-depends: - base, Cabal, cabal-doctest >=1.0.6 && <1.1 + base < 5, + Cabal < 4, + cabal-doctest >=1.0.6 && <1.1 library hs-source-dirs: src @@ -56,49 +64,85 @@ Data.OpenApi.Internal.AesonUtils Data.OpenApi.Internal.TypeShape + Data.OpenApi.Aeson.Compat + Data.HashMap.Strict.InsOrd.Compat + -- GHC boot libraries build-depends: - base >=4.11.1.0 && <4.16 - , bytestring >=0.10.8.2 && <0.11 - , containers >=0.5.11.0 && <0.7 - , template-haskell >=2.13.0.0 && <2.18 - , time >=1.8.0.2 && <1.10 - , transformers >=0.5.5.0 && <0.6 + base >=4.11.1.0 && <4.23 + , bytestring >=0.10.8.2 && <0.13 + , containers >=0.5.11.0 && <0.9 + , template-haskell >=2.13.0.0 && <2.25 + , time >=1.8.0.2 && <1.16 + , transformers >=0.5.5.0 && <0.7 build-depends: - mtl >=2.2.2 && <2.3 - , text >=1.2.3.1 && <1.3 + mtl >=2.2.2 && <2.4 + , text >=1.2.3.1 && <2.2 -- other dependencies build-depends: - base-compat-batteries >=0.11.1 && <0.12 - , aeson >=1.4.2.0 && <1.6 + base-compat-batteries >=0.11.1 && <0.16 + , aeson >=1.4.2.0 && <1.6 || >=2.0.1.0 && < 2.3 , aeson-pretty >=0.8.7 && <0.9 -- cookie 0.4.3 is needed by GHC 7.8 due to time>=1.4 constraint - , cookie >=0.4.3 && <0.5 + , cookie >=0.4.3 && <0.6 , generics-sop >=0.5.1.0 && <0.6 - , hashable >=1.2.7.0 && <1.4 + , hashable >=1.2.7.0 && <1.6 , http-media >=0.8.0.0 && <0.9 - , insert-ordered-containers >=0.2.3 && <0.3 - , lens >=4.16.1 && <5.1 - , network >=2.6.3.5 && <3.2 + , insert-ordered-containers >=0.2.3 && <0.4 + , lens >=4.16.1 && <5.4 , optics-core >=0.2 && <0.5 , optics-th >=0.2 && <0.5 , scientific >=0.3.6.2 && <0.4 , unordered-containers >=0.2.9.0 && <0.3 , uuid-types >=1.0.3 && <1.1 - , vector >=0.12.0.1 && <0.13 - , QuickCheck >=2.10.1 && <2.15 + , vector >=0.12.0.1 && <0.14 + , QuickCheck >=2.10.1 && <2.19 default-language: Haskell2010 + default-extensions: + ConstraintKinds + DataKinds + DefaultSignatures + DeriveDataTypeable + DeriveFunctor + DeriveGeneric + DeriveTraversable + ExplicitForAll + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralizedNewtypeDeriving + KindSignatures + LambdaCase + MultiParamTypeClasses + OverloadedLabels + OverloadedStrings + PackageImports + PolyKinds + RankNTypes + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + TemplateHaskell + TupleSections + TypeApplications + TypeFamilies + TypeOperators + TypeSynonymInstances + UndecidableInstances + UndecidableSuperClasses + ViewPatterns test-suite spec type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Spec.hs - -- From library parat - -- We need aeson's toEncoding for doctests too + -- From library part + -- We need aeson's toEncoding for doctests too build-depends: base , QuickCheck @@ -119,14 +163,14 @@ -- test-suite only dependencies build-depends: - hspec >=2.5.5 && <2.8 + hspec >=2.5.5 && <2.12 , HUnit >=1.6.0.0 && <1.7 , quickcheck-instances >=0.3.19 && <0.14 , utf8-string >=1.0.1.1 && <1.1 -- https://github.com/haskell/cabal/issues/3708 build-tool-depends: - hspec-discover:hspec-discover >=2.5.5 && <2.8 + hspec-discover:hspec-discover >=2.5.5 && <2.12 other-modules: SpecCommon @@ -145,6 +189,8 @@ hs-source-dirs: test main-is: doctests.hs type: exitcode-stdio-1.0 + build-depends: base, openapi3 + ghc-options: -Wno-unused-packages executable example hs-source-dirs: examples diff --git a/src/Data/HashMap/Strict/InsOrd/Compat.hs b/src/Data/HashMap/Strict/InsOrd/Compat.hs new file mode 100644 --- /dev/null +++ b/src/Data/HashMap/Strict/InsOrd/Compat.hs @@ -0,0 +1,438 @@ +-- Ported from GetShopTV/swagger2 (pull request #262) to apply the same +-- insert-ordered-containers-0.3 compatibility fix to openapi3. +-- Credit for the design and implementation belongs to the swagger2 authors. +{-# LANGUAGE CPP #-} +-- | +-- Module: Data.HashMap.Strict.InsOrd.Compat +-- Maintainer: Nickolay Kudasov +-- Stability: experimental +-- +-- Compatibility wrapper around @insert-ordered-containers@ to mitigate the +-- breaking changes introduced in @insert-ordered-containers-0.3.0@: +-- . +-- +-- That change fixed 'Eq' and Aeson instances in the upstream package, but it is +-- a behavioral break for @swagger2@ where we need stable Swagger Schema +-- generation and JSON object-like encoding. +-- +-- This module keeps the old @swagger2@ expectations: +-- +-- * 'InsOrdHashMap' values are encoded as JSON objects (not arrays of key/value +-- tuples), so field names remain first-class object keys. +-- * Equality intentionally ignores insertion order (compares as plain hash +-- maps), which matches how many tests currently assert JSON equality. +-- +-- Simple encoding examples: +-- +-- >>> import Data.Aeson (encode, eitherDecode) +-- >>> import qualified Data.ByteString.Lazy.Char8 as BSL8 +-- >>> import qualified Data.HashMap.Strict as HM +-- >>> import qualified Data.HashMap.Strict.InsOrd.Compat as IOHM +-- >>> let decodeIOHM s = either error id (eitherDecode (BSL8.pack s) :: Either String (IOHM.InsOrdHashMap String Int)) +-- +-- A regular hash map has no insertion order guarantee: +-- +-- >>> encode (HM.fromList [("a", 1 :: Int), ("b", 2)]) +-- "{\"a\":1,\"b\":2}" +-- >>> encode (HM.fromList [("b", 1 :: Int), ("a", 2)]) +-- "{\"a\":2,\"b\":1}" +-- +-- Our compat 'InsOrdHashMap' encodes to a JSON object as well, but preserves insertion order: +-- +-- >>> encode (IOHM.fromList [("a", 1 :: Int), ("b", 2)]) +-- "{\"a\":1,\"b\":2}" +-- >>> encode (IOHM.fromList [("b", 1 :: Int), ("a", 2)]) +-- "{\"b\":1,\"a\":2}" +-- +-- Round-tripping through decode/encode demonstrates the caveat: encoding +-- preserves insertion order, but decoded object key order is not guaranteed. +-- +-- >>> encode (decodeIOHM "{\"a\":1,\"b\":2}") +-- "{\"a\":1,\"b\":2}" +-- >>> encode (decodeIOHM "{\"b\":1,\"a\":2}") +-- "{\"a\":2,\"b\":1}" +-- +-- This object encoding is what @swagger2@ wants for generated Swagger +-- definitions/properties because it keeps emitted schemas easy to consume and +-- stable in practice. +-- +-- Important caveat: decoding cannot be fully stable with respect to insertion +-- order due to @aeson@ limitations. In particular, object parsing goes through +-- structures that do not preserve all ordering guarantees end-to-end. We accept +-- this trade-off for now because the primary requirement is deterministic +-- /encoding/ for generated Swagger Schema artifacts. +-- +-- Many tests rely on @aesonQQ@-style JSON equality, where semantic object +-- equality matters more than insertion order. Comparing via plain hash maps +-- makes those tests robust under benign key-order variation. This is a weaker +-- notion of equality and hopefully will be revisited later. +module Data.HashMap.Strict.InsOrd.Compat ( + InsOrdHashMap, + -- * Construction + empty, + singleton, + -- * Basic interface + null, + size, + member, + lookup, + lookupDefault, + insert, + insertWith, + delete, + adjust, + update, + alter, + -- * Combine + union, + unionWith, + unionWithKey, + unions, + -- * Transformations + map, + mapKeys, + traverseKeys, + mapWithKey, + traverseWithKey, + -- ** Unordered + unorderedTraverse, + unorderedTraverseWithKey, + -- * Difference and intersection + difference, + intersection, + intersectionWith, + intersectionWithKey, + -- * Folds + foldl', + foldlWithKey', + foldr, + foldrWithKey, + foldMapWithKey, + -- ** Unordered + unorderedFoldMap, + unorderedFoldMapWithKey, + -- * Filter + filter, + filterWithKey, + mapMaybe, + mapMaybeWithKey, + -- * Conversions + keys, + elems, + toList, + toRevList, + fromList, + toHashMap, + fromHashMap, + -- * Lenses + hashMap, + unorderedTraversal, + -- * Debugging + valid, + ) where + +#if !MIN_VERSION_insert_ordered_containers(0,3,0) +import Prelude hiding (null, lookup, map, foldl', foldr, filter) +import Data.HashMap.Strict.InsOrd +#else +import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap + +import Prelude hiding (null, size, member, lookup, lookupDefault, map, foldl', filter) +import qualified Prelude + +import qualified Data.Aeson as A +import qualified Data.Aeson.Encoding as E +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap + +import qualified GHC.Exts as Exts + +import Data.Data (Data) +import Data.Foldable (Foldable (foldMap)) +import Data.Hashable (Hashable (..)) + +import qualified Control.Lens as Lens +import Control.Lens + (At (..), Index, Iso, IxValue, Ixed (..), Traversal, _1, _2, iso, (<&>)) + +import qualified Optics.Core as Optics + +newtype InsOrdHashMap k v = InsOrdHashMap { unCompatInsOrdHashMap :: InsOrdHashMap.InsOrdHashMap k v } + deriving (Show, Read, Data, Functor, Foldable, Traversable, Semigroup, Monoid) + +instance (Eq k, Eq v) => Eq (InsOrdHashMap k v) where + a == b = toHashMap a == toHashMap b + +instance (Eq k, Hashable k) => Exts.IsList (InsOrdHashMap k v) where + type Item (InsOrdHashMap k v) = Exts.Item (InsOrdHashMap.InsOrdHashMap k v) + fromList = InsOrdHashMap . InsOrdHashMap.fromList + toList = InsOrdHashMap.toList . unCompatInsOrdHashMap + +------------------------------------------------------------------------------- +-- Aeson +------------------------------------------------------------------------------- + +instance (A.ToJSONKey k) => A.ToJSON1 (InsOrdHashMap k) where + liftToJSON _ t _ = case A.toJSONKey :: A.ToJSONKeyFunction k of + A.ToJSONKeyText f _ -> A.object . fmap (\(k, v) -> (f k, t v)) . toList + A.ToJSONKeyValue f _ -> A.toJSON . fmap (\(k,v) -> A.toJSON (f k, t v)) . toList + + liftToEncoding o t _ = case A.toJSONKey :: A.ToJSONKeyFunction k of + A.ToJSONKeyText _ f -> E.dict f t foldrWithKey + A.ToJSONKeyValue _ f -> E.list (A.liftToEncoding2 (const False) f (E.list f) o t (E.list t)) . toList + +instance (A.ToJSONKey k, A.ToJSON v) => A.ToJSON (InsOrdHashMap k v) where + toJSON = A.toJSON1 + toEncoding = A.toEncoding1 + +------------------------------------------------------------------------------- + +instance (Eq k, Hashable k, A.FromJSONKey k) => A.FromJSON1 (InsOrdHashMap k) where + liftParseJSON o p pl v = fromList . HashMap.toList <$> A.liftParseJSON o p pl v + +instance (Eq k, Hashable k, A.FromJSONKey k, A.FromJSON v) => A.FromJSON (InsOrdHashMap k v) where + parseJSON = A.parseJSON1 + +------------------------------------------------------------------------------- +-- indexed-traversals +------------------------------------------------------------------------------- + +instance (Eq k, Hashable k) => Optics.FunctorWithIndex k (InsOrdHashMap k) where + imap = mapWithKey +instance (Eq k, Hashable k) => Optics.FoldableWithIndex k (InsOrdHashMap k) where + ifoldMap = foldMapWithKey + ifoldr = foldrWithKey +instance (Eq k, Hashable k) => Optics.TraversableWithIndex k (InsOrdHashMap k) where + itraverse = traverseWithKey + +------------------------------------------------------------------------------- +-- Lens +------------------------------------------------------------------------------- + +type instance Index (InsOrdHashMap k v) = k +type instance IxValue (InsOrdHashMap k v) = v + +instance (Eq k, Hashable k) => Ixed (InsOrdHashMap k v) where + ix k f m = ixImpl k pure f m + {-# INLINABLE ix #-} + +ixImpl + :: (Eq k, Hashable k, Functor f) + => k + -> (InsOrdHashMap k v -> f (InsOrdHashMap k v)) + -> (v -> f v) + -> InsOrdHashMap k v + -> f (InsOrdHashMap k v) +ixImpl k point f m = case lookup k m of + Just v -> f v <&> \v' -> insert k v' m + Nothing -> point m +{-# INLINE ixImpl #-} + +instance (Eq k, Hashable k) => At (InsOrdHashMap k a) where + at k f m = f mv <&> \r -> case r of + Nothing -> maybe m (const (delete k m)) mv + Just v' -> insert k v' m + where mv = lookup k m + {-# INLINABLE at #-} + +------------------------------------------------------------------------------- +-- Optics +------------------------------------------------------------------------------- + +type instance Optics.Index (InsOrdHashMap k v) = k +type instance Optics.IxValue (InsOrdHashMap k v) = v + +instance (Eq k, Hashable k) => Optics.Ixed (InsOrdHashMap k v) where + ix k = Optics.atraversalVL $ \point f m -> ixImpl k point f m + {-# INLINE ix #-} + +instance (Eq k, Hashable k) => Optics.At (InsOrdHashMap k a) where + at k = Optics.lensVL $ \f m -> Lens.at k f m + {-# INLINE at #-} + +------------------------------------------------------------------------------- + +-- | This is a slight lie, as roundtrip doesn't preserve ordering. +hashMap :: Iso (InsOrdHashMap k a) (InsOrdHashMap k b) (HashMap k a) (HashMap k b) +hashMap = iso toHashMap fromHashMap + +unorderedTraversal :: Traversal (InsOrdHashMap k a) (InsOrdHashMap k b) a b +unorderedTraversal = hashMap . traverse + +------------------------------------------------------------------------------- +-- * Construction +------------------------------------------------------------------------------- + +empty :: InsOrdHashMap k v +empty = InsOrdHashMap InsOrdHashMap.empty + +singleton :: Hashable k => k -> v -> InsOrdHashMap k v +singleton k v = InsOrdHashMap (InsOrdHashMap.singleton k v) + +------------------------------------------------------------------------------- +-- * Basic interface +------------------------------------------------------------------------------- + +null :: InsOrdHashMap k v -> Bool +null = InsOrdHashMap.null . unCompatInsOrdHashMap + +size :: InsOrdHashMap k v -> Int +size = InsOrdHashMap.size . unCompatInsOrdHashMap + +insert :: Hashable k => k -> v -> InsOrdHashMap k v -> InsOrdHashMap k v +insert k v = InsOrdHashMap . InsOrdHashMap.insert k v . unCompatInsOrdHashMap + +insertWith :: Hashable k => (v -> v -> v) -> k -> v -> InsOrdHashMap k v -> InsOrdHashMap k v +insertWith f k v = InsOrdHashMap . InsOrdHashMap.insertWith f k v . unCompatInsOrdHashMap + +delete :: Hashable k => k -> InsOrdHashMap k v -> InsOrdHashMap k v +delete k = InsOrdHashMap . InsOrdHashMap.delete k . unCompatInsOrdHashMap + +adjust :: Hashable k => (v -> v) -> k -> InsOrdHashMap k v -> InsOrdHashMap k v +adjust f k = InsOrdHashMap . InsOrdHashMap.adjust f k . unCompatInsOrdHashMap + +update :: Hashable k => (v -> Maybe v) -> k -> InsOrdHashMap k v -> InsOrdHashMap k v +update f k = InsOrdHashMap . InsOrdHashMap.update f k . unCompatInsOrdHashMap + +alter :: Hashable k => (Maybe v -> Maybe v) -> k -> InsOrdHashMap k v -> InsOrdHashMap k v +alter f k = InsOrdHashMap . InsOrdHashMap.alter f k . unCompatInsOrdHashMap + +member :: Hashable k => k -> InsOrdHashMap k v -> Bool +member k = InsOrdHashMap.member k . unCompatInsOrdHashMap + +lookup :: Hashable k => k -> InsOrdHashMap k v -> Maybe v +lookup k = InsOrdHashMap.lookup k . unCompatInsOrdHashMap + +lookupDefault :: Hashable k => v -> k -> InsOrdHashMap k v -> v +lookupDefault k def = InsOrdHashMap.lookupDefault k def . unCompatInsOrdHashMap + +-- * Combine + +union :: Hashable k => InsOrdHashMap k v -> InsOrdHashMap k v -> InsOrdHashMap k v +union m1 m2 = InsOrdHashMap (InsOrdHashMap.union (unCompatInsOrdHashMap m1) (unCompatInsOrdHashMap m2)) + +unionWith :: Hashable k => (v -> v -> v) -> InsOrdHashMap k v -> InsOrdHashMap k v -> InsOrdHashMap k v +unionWith f m1 m2 = InsOrdHashMap (InsOrdHashMap.unionWith f (unCompatInsOrdHashMap m1) (unCompatInsOrdHashMap m2)) + +unionWithKey :: Hashable k => (k -> v -> v -> v) -> InsOrdHashMap k v -> InsOrdHashMap k v -> InsOrdHashMap k v +unionWithKey f m1 m2 = InsOrdHashMap (InsOrdHashMap.unionWithKey f (unCompatInsOrdHashMap m1) (unCompatInsOrdHashMap m2)) + +unions :: Hashable k => [InsOrdHashMap k v] -> InsOrdHashMap k v +unions = InsOrdHashMap . InsOrdHashMap.unions . Prelude.map unCompatInsOrdHashMap + +------------------------------------------------------------------------------- +-- * Transformations +------------------------------------------------------------------------------- + +map :: (v -> v) -> InsOrdHashMap k v -> InsOrdHashMap k v +map f = InsOrdHashMap . InsOrdHashMap.map f . unCompatInsOrdHashMap + +mapKeys :: Hashable k => (k -> k) -> InsOrdHashMap k v -> InsOrdHashMap k v +mapKeys f = InsOrdHashMap . InsOrdHashMap.mapKeys f . unCompatInsOrdHashMap + +traverseKeys :: (Applicative f, Hashable k) => (k -> f k) -> InsOrdHashMap k v -> f (InsOrdHashMap k v) +traverseKeys f = fmap InsOrdHashMap . InsOrdHashMap.traverseKeys f . unCompatInsOrdHashMap + +mapWithKey :: (k -> v1 -> v2) -> InsOrdHashMap k v1 -> InsOrdHashMap k v2 +mapWithKey f = InsOrdHashMap . InsOrdHashMap.mapWithKey f . unCompatInsOrdHashMap + +traverseWithKey :: (Applicative f, Hashable k) => (k -> v1 -> f v2) -> InsOrdHashMap k v1 -> f (InsOrdHashMap k v2) +traverseWithKey f = fmap InsOrdHashMap . InsOrdHashMap.traverseWithKey f . unCompatInsOrdHashMap + +-- ** Unordered + +unorderedTraverse :: (Applicative f, Hashable k) => (v -> f v) -> InsOrdHashMap k v -> f (InsOrdHashMap k v) +unorderedTraverse f = fmap InsOrdHashMap . InsOrdHashMap.unorderedTraverse f . unCompatInsOrdHashMap + +unorderedTraverseWithKey :: (Applicative f, Hashable k) => (k -> v -> f v) -> InsOrdHashMap k v -> f (InsOrdHashMap k v) +unorderedTraverseWithKey f = fmap InsOrdHashMap . InsOrdHashMap.unorderedTraverseWithKey f . unCompatInsOrdHashMap + +------------------------------------------------------------------------------- +-- * Difference and intersection +------------------------------------------------------------------------------- + +difference :: Hashable k => InsOrdHashMap k v -> InsOrdHashMap k v -> InsOrdHashMap k v +difference m1 m2 = InsOrdHashMap (InsOrdHashMap.difference (unCompatInsOrdHashMap m1) (unCompatInsOrdHashMap m2)) + +intersection :: Hashable k => InsOrdHashMap k v -> InsOrdHashMap k v -> InsOrdHashMap k v +intersection m1 m2 = InsOrdHashMap (InsOrdHashMap.intersection (unCompatInsOrdHashMap m1) (unCompatInsOrdHashMap m2)) + +intersectionWith :: Hashable k => (v -> v -> v) -> InsOrdHashMap k v -> InsOrdHashMap k v -> InsOrdHashMap k v +intersectionWith f m1 m2 = InsOrdHashMap (InsOrdHashMap.intersectionWith f (unCompatInsOrdHashMap m1) (unCompatInsOrdHashMap m2)) + +intersectionWithKey :: Hashable k => (k -> v -> v -> v) -> InsOrdHashMap k v -> InsOrdHashMap k v -> InsOrdHashMap k v +intersectionWithKey f m1 m2 = InsOrdHashMap (InsOrdHashMap.intersectionWithKey f (unCompatInsOrdHashMap m1) (unCompatInsOrdHashMap m2)) + +------------------------------------------------------------------------------- +-- * Folds +------------------------------------------------------------------------------- + +foldl' :: (a -> v -> a) -> a -> InsOrdHashMap k v -> a +foldl' f z = InsOrdHashMap.foldl' f z . unCompatInsOrdHashMap + +foldlWithKey' :: (a -> k -> v -> a) -> a -> InsOrdHashMap k v -> a +foldlWithKey' f z = InsOrdHashMap.foldlWithKey' f z . unCompatInsOrdHashMap + +foldMapWithKey :: Monoid m => (k -> v -> m) -> InsOrdHashMap k v -> m +foldMapWithKey f = InsOrdHashMap.foldMapWithKey f . unCompatInsOrdHashMap + +foldrWithKey :: (k -> v -> a -> a) -> a -> InsOrdHashMap k v -> a +foldrWithKey f z = InsOrdHashMap.foldrWithKey f z . unCompatInsOrdHashMap + +-- ** Unordered + +unorderedFoldMap :: Monoid m => (v -> m) -> InsOrdHashMap k v -> m +unorderedFoldMap f = InsOrdHashMap.unorderedFoldMap f . unCompatInsOrdHashMap + +unorderedFoldMapWithKey :: Monoid m => (k -> v -> m) -> InsOrdHashMap k v -> m +unorderedFoldMapWithKey f = InsOrdHashMap.unorderedFoldMapWithKey f . unCompatInsOrdHashMap + +------------------------------------------------------------------------------- +-- * Filter +------------------------------------------------------------------------------- + +filter :: (v -> Bool) -> InsOrdHashMap k v -> InsOrdHashMap k v +filter f = InsOrdHashMap . InsOrdHashMap.filter f . unCompatInsOrdHashMap + +filterWithKey :: (k -> v -> Bool) -> InsOrdHashMap k v -> InsOrdHashMap k v +filterWithKey f = InsOrdHashMap . InsOrdHashMap.filterWithKey f . unCompatInsOrdHashMap + +mapMaybe :: (v -> Maybe v) -> InsOrdHashMap k v -> InsOrdHashMap k v +mapMaybe f = InsOrdHashMap . InsOrdHashMap.mapMaybe f . unCompatInsOrdHashMap + +mapMaybeWithKey :: (k -> v -> Maybe v) -> InsOrdHashMap k v -> InsOrdHashMap k v +mapMaybeWithKey f = InsOrdHashMap . InsOrdHashMap.mapMaybeWithKey f . unCompatInsOrdHashMap + +------------------------------------------------------------------------------- +-- * Conversions +------------------------------------------------------------------------------- + +keys :: InsOrdHashMap k v -> [k] +keys = InsOrdHashMap.keys . unCompatInsOrdHashMap + +elems :: InsOrdHashMap k v -> [v] +elems = InsOrdHashMap.elems . unCompatInsOrdHashMap + +toRevList :: InsOrdHashMap k v -> [(k, v)] +toRevList = InsOrdHashMap.toRevList . unCompatInsOrdHashMap + +fromList :: Hashable k => [(k, v)] -> InsOrdHashMap k v +fromList = InsOrdHashMap . InsOrdHashMap.fromList + +toList :: InsOrdHashMap k v -> [(k, v)] +toList = InsOrdHashMap.toList . unCompatInsOrdHashMap + +toHashMap :: InsOrdHashMap k v -> HashMap k v +toHashMap = InsOrdHashMap.toHashMap . unCompatInsOrdHashMap + +fromHashMap :: HashMap k v -> InsOrdHashMap k v +fromHashMap = InsOrdHashMap . InsOrdHashMap.fromHashMap + +------------------------------------------------------------------------------- +-- * Debugging +------------------------------------------------------------------------------- + +valid :: (Eq k, Hashable k) => InsOrdHashMap k v -> Bool +valid = InsOrdHashMap.valid . unCompatInsOrdHashMap + +#endif diff --git a/src/Data/OpenApi.hs b/src/Data/OpenApi.hs --- a/src/Data/OpenApi.hs +++ b/src/Data/OpenApi.hs @@ -137,10 +137,13 @@ -- >>> import Data.Proxy -- >>> import GHC.Generics -- >>> import qualified Data.ByteString.Lazy.Char8 as BSL +-- >>> import Data.OpenApi.Internal +-- >>> import Data.OpenApi.Internal.Schema +-- >>> import qualified Data.HashMap.Strict.InsOrd.Compat as IOHM -- >>> import Data.OpenApi.Internal.Utils +-- >>> import Data.OpenApi.Lens -- >>> :set -XDeriveGeneric -- >>> :set -XOverloadedStrings --- >>> :set -XOverloadedLists -- >>> :set -fno-warn-missing-methods -- $howto @@ -211,9 +214,9 @@ -- -- >>> :{ -- BSL.putStrLn $ encodePretty $ (mempty :: OpenApi) --- & components . schemas .~ [ ("User", mempty & type_ ?~ OpenApiString) ] +-- & components . schemas .~ IOHM.fromList [ ("User", mempty & type_ ?~ OpenApiString) ] -- & paths .~ --- [ ("/user", mempty & get ?~ (mempty +-- IOHM.fromList [ ("/user", mempty & get ?~ (mempty -- & at 200 ?~ ("OK" & _Inline.content.at "application/json" ?~ (mempty & schema ?~ Ref (Reference "User"))) -- & at 404 ?~ "User info not found")) ] -- :} @@ -389,6 +392,7 @@ -- "userId", -- "tag" -- ], +-- "title": "ErrorNoUser", -- "type": "object" -- }, -- { @@ -407,10 +411,10 @@ -- "requiredPermission", -- "tag" -- ], +-- "title": "ErrorAccessDenied", -- "type": "object" -- } --- ], --- "type": "object" +-- ] -- } -- $manipulation diff --git a/src/Data/OpenApi/Aeson/Compat.hs b/src/Data/OpenApi/Aeson/Compat.hs new file mode 100644 --- /dev/null +++ b/src/Data/OpenApi/Aeson/Compat.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE CPP #-} + +module Data.OpenApi.Aeson.Compat where + +#if MIN_VERSION_aeson(2,0,0) +import Data.Aeson (Key) +import qualified Data.Aeson.Key as Key +import qualified Data.Aeson.KeyMap as KeyMap +#else +import qualified Data.HashMap.Strict as HM +#endif +import Data.Bifunctor (first) +import qualified Data.HashMap.Strict.InsOrd.Compat as InsOrdHashMap +import qualified Data.Text as T + +#if MIN_VERSION_aeson(2,0,0) +deleteKey :: Key -> KeyMap.KeyMap v -> KeyMap.KeyMap v +deleteKey = KeyMap.delete + +objectToList :: KeyMap.KeyMap v -> [(Key, v)] +objectToList = KeyMap.toList + +objectKeys :: KeyMap.KeyMap v -> [T.Text] +objectKeys = map Key.toText . KeyMap.keys + +stringToKey :: String -> Key +stringToKey = Key.fromString + +keyToString :: Key -> String +keyToString = Key.toString + +keyToText :: Key -> T.Text +keyToText = Key.toText + +toInsOrdHashMap :: KeyMap.KeyMap v -> InsOrdHashMap.InsOrdHashMap T.Text v +toInsOrdHashMap = InsOrdHashMap.fromList . fmap (first Key.toText) . KeyMap.toList + +fromInsOrdHashMap :: InsOrdHashMap.InsOrdHashMap T.Text v -> KeyMap.KeyMap v +fromInsOrdHashMap = KeyMap.fromList . fmap (first Key.fromText) . InsOrdHashMap.toList + +lookupKey :: T.Text -> KeyMap.KeyMap v -> Maybe v +lookupKey = KeyMap.lookup . Key.fromText + +hasKey :: T.Text -> KeyMap.KeyMap a -> Bool +hasKey = KeyMap.member . Key.fromText +#else +deleteKey :: T.Text -> HM.HashMap T.Text v -> HM.HashMap T.Text v +deleteKey = HM.delete + +objectToList :: HM.HashMap T.Text v -> [(T.Text, v)] +objectToList = HM.toList + +objectKeys :: HM.HashMap T.Text v -> [T.Text] +objectKeys = HM.keys + +stringToKey :: String -> T.Text +stringToKey = T.pack + +keyToString :: T.Text -> String +keyToString = T.unpack + +keyToText :: T.Text -> T.Text +keyToText = id + +toInsOrdHashMap :: HM.HashMap T.Text v -> InsOrdHashMap.InsOrdHashMap T.Text v +toInsOrdHashMap = InsOrdHashMap.fromHashMap + +fromInsOrdHashMap :: InsOrdHashMap.InsOrdHashMap T.Text v -> HM.HashMap T.Text v +fromInsOrdHashMap = InsOrdHashMap.toHashMap + +lookupKey :: T.Text -> HM.HashMap T.Text v -> Maybe v +lookupKey = HM.lookup + +hasKey :: T.Text -> HM.HashMap T.Text a -> Bool +hasKey = HM.member +#endif diff --git a/src/Data/OpenApi/Declare.hs b/src/Data/OpenApi/Declare.hs --- a/src/Data/OpenApi/Declare.hs +++ b/src/Data/OpenApi/Declare.hs @@ -1,8 +1,3 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE UndecidableInstances #-} -- | -- Module: Data.OpenApi.Declare -- Maintainer: Nickolay Kudasov @@ -16,7 +11,6 @@ import Control.Monad import Control.Monad.Cont (ContT) -import Control.Monad.List (ListT) import Control.Monad.Reader (ReaderT) import Control.Monad.Trans import Control.Monad.Trans.Except (ExceptT) @@ -53,7 +47,6 @@ return (mappend d' d'', f x) instance (Applicative m, Monad m, Monoid d) => Monad (DeclareT d m) where - return x = DeclareT (\_ -> pure (mempty, x)) DeclareT dx >>= f = DeclareT $ \d -> do ~(d', x) <- dx d ~(d'', y) <- runDeclareT (f x) (mappend d d') diff --git a/src/Data/OpenApi/Internal.hs b/src/Data/OpenApi/Internal.hs --- a/src/Data/OpenApi/Internal.hs +++ b/src/Data/OpenApi/Internal.hs @@ -1,18 +1,5 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -Wno-orphans #-} module Data.OpenApi.Internal where import Prelude () @@ -21,6 +8,9 @@ import Control.Applicative import Control.Lens ((&), (.~), (?~)) import Data.Aeson hiding (Encoding) +#if MIN_VERSION_aeson(2,0,0) +import qualified Data.Aeson.KeyMap as KeyMap +#endif import qualified Data.Aeson.Types as JSON import Data.Data (Constr, Data (..), DataType, Fixity (..), Typeable, constrIndex, mkConstr, mkDataType) @@ -39,23 +29,21 @@ import GHC.Generics (Generic) import Network.HTTP.Media (MediaType, mainType, parameters, parseAccept, subType, (//), (/:)) -import Network.Socket (HostName, PortNumber) import Text.Read (readMaybe) -import Data.HashMap.Strict.InsOrd (InsOrdHashMap) -import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap +import Data.HashMap.Strict.InsOrd.Compat (InsOrdHashMap) +import qualified Data.HashMap.Strict.InsOrd.Compat as InsOrdHashMap -import Generics.SOP.TH (deriveGeneric) -import Data.OpenApi.Internal.AesonUtils (sopSwaggerGenericToJSON - ,sopSwaggerGenericToJSONWithOpts - ,sopSwaggerGenericParseJSON - ,HasSwaggerAesonOptions(..) - ,AesonDefaultValue(..) - ,mkSwaggerAesonOptions - ,saoAdditionalPairs - ,saoSubObject) +import Data.OpenApi.Aeson.Compat (deleteKey) +import Data.OpenApi.Internal.AesonUtils (AesonDefaultValue (..), HasSwaggerAesonOptions (..), + mkSwaggerAesonOptions, saoAdditionalPairs, saoSubObject, + sopSwaggerGenericParseJSON, sopSwaggerGenericToEncoding, + sopSwaggerGenericToJSON, sopSwaggerGenericToJSONWithOpts) import Data.OpenApi.Internal.Utils -import Data.OpenApi.Internal.AesonUtils (sopSwaggerGenericToEncoding) +import Generics.SOP.TH (deriveGeneric) +import Data.Version +import Control.Monad (unless) +import Text.ParserCombinators.ReadP (readP_to_S) -- $setup -- >>> :seti -XDataKinds @@ -99,8 +87,19 @@ -- | Additional external documentation. , _openApiExternalDocs :: Maybe ExternalDocs + + , -- | The spec of OpenApi this spec adheres to. Must be between 'lowerOpenApiSpecVersion' and 'upperOpenApiSpecVersion' + _openApiOpenapi :: OpenApiSpecVersion } deriving (Eq, Show, Generic, Data, Typeable) +-- | This is the lower version of the OpenApi Spec this library can parse or produce +lowerOpenApiSpecVersion :: Version +lowerOpenApiSpecVersion = makeVersion [3, 0, 0] + +-- | This is the upper version of the OpenApi Spec this library can parse or produce +upperOpenApiSpecVersion :: Version +upperOpenApiSpecVersion = makeVersion [3, 0, 3] + -- | The object provides metadata about the API. -- The metadata MAY be used by the clients if needed, -- and MAY be presented in editing or documentation generation tools for convenience. @@ -196,7 +195,7 @@ , _componentsExamples :: Definitions Example , _componentsRequestBodies :: Definitions RequestBody , _componentsHeaders :: Definitions Header - , _componentsSecuritySchemes :: Definitions SecurityScheme + , _componentsSecuritySchemes :: SecurityDefinitions , _componentsLinks :: Definitions Link , _componentsCallbacks :: Definitions Callback } deriving (Eq, Show, Generic, Data, Typeable) @@ -322,7 +321,10 @@ dataTypeOf _ = mediaTypeData +mediaTypeConstr :: Constr mediaTypeConstr = mkConstr mediaTypeData "MediaType" [] Prefix + +mediaTypeData :: DataType mediaTypeData = mkDataType "MediaType" [mediaTypeConstr] instance Hashable MediaType where @@ -337,7 +339,7 @@ -- | The content of the request body. -- The key is a media type or media type range and the value describes it. -- For requests that match multiple keys, only the most specific key is applicable. - -- e.g. @text/plain@ overrides @text/*@ + -- e.g. @text/plain@ overrides @text/\*@ , _requestBodyContent :: InsOrdHashMap MediaType MediaTypeObject -- | Determines if the request body is required in the request. @@ -394,7 +396,7 @@ -- for other primitive types – @text/plain@; for object - @application/json@; -- for array – the default is defined based on the inner type. -- The value can be a specific media type (e.g. @application/json@), - -- a wildcard media type (e.g. @image/*@), or a comma-separated list of the two types. + -- a wildcard media type (e.g. @image/\*@), or a comma-separated list of the two types. _encodingContentType :: Maybe MediaType -- | A map allowing additional information to be provided as headers, @@ -734,7 +736,7 @@ -- | A map containing descriptions of potential response payloads. -- The key is a media type or media type range and the value describes it. -- For responses that match multiple keys, only the most specific key is applicable. - -- e.g. @text/plain@ overrides @text/*@. + -- e.g. @text/plain@ overrides @text/\*@. , _responseContent :: InsOrdHashMap MediaType MediaTypeObject -- | Maps a header name to its definition. @@ -962,6 +964,8 @@ | AdditionalPropertiesSchema (Referenced Schema) deriving (Eq, Show, Data, Typeable) +newtype OpenApiSpecVersion = OpenApiSpecVersion {getVersion :: Version} deriving (Eq, Show, Generic, Data, Typeable) + ------------------------------------------------------------------------------- -- Generic instances ------------------------------------------------------------------------------- @@ -984,11 +988,19 @@ deriveGeneric ''Example deriveGeneric ''Encoding deriveGeneric ''Link +deriveGeneric ''OpenApiSpecVersion -- ======================================================================= -- Monoid instances -- ======================================================================= +instance Semigroup OpenApiSpecVersion where + (<>) (OpenApiSpecVersion a) (OpenApiSpecVersion b) = OpenApiSpecVersion $ max a b + +instance Monoid OpenApiSpecVersion where + mempty = OpenApiSpecVersion (makeVersion [3,0,0]) + mappend = (<>) + instance Semigroup OpenApi where (<>) = genericMappend instance Monoid OpenApi where @@ -1125,6 +1137,8 @@ instance SwaggerMonoid ExternalDocs instance SwaggerMonoid Operation instance (Eq a, Hashable a) => SwaggerMonoid (InsOrdHashSet a) +instance SwaggerMonoid SecurityDefinitions +instance SwaggerMonoid OpenApiSpecVersion instance SwaggerMonoid MimeList deriving instance SwaggerMonoid URL @@ -1257,6 +1271,9 @@ -- Manual ToJSON instances -- ======================================================================= +instance ToJSON OpenApiSpecVersion where + toJSON (OpenApiSpecVersion v)= toJSON . showVersion $ v + instance ToJSON MediaType where toJSON = toJSON . show toEncoding = toEncoding . show @@ -1265,7 +1282,10 @@ toJSONKey = JSON.toJSONKeyText (Text.pack . show) instance (Eq p, ToJSON p, AesonDefaultValue p) => ToJSON (OAuth2Flow p) where - toJSON = sopSwaggerGenericToJSON + toJSON a = sopSwaggerGenericToJSON a & + if InsOrdHashMap.null (_oAuth2Scopes a) + then (<+> object ["scopes" .= object []]) + else id toEncoding = sopSwaggerGenericToEncoding instance ToJSON OAuth2Flows where @@ -1421,6 +1441,22 @@ -- Manual FromJSON instances -- ======================================================================= +instance FromJSON OpenApiSpecVersion where + parseJSON = withText "OpenApiSpecVersion" $ \str -> + let validatedVersion :: Either String Version + validatedVersion = do + parsedVersion <- readVersion str + unless ((parsedVersion >= lowerOpenApiSpecVersion) && (parsedVersion <= upperOpenApiSpecVersion)) $ + Left ("The provided version " <> showVersion parsedVersion <> " is out of the allowed range >=" <> showVersion lowerOpenApiSpecVersion <> " && <=" <> showVersion upperOpenApiSpecVersion) + return parsedVersion + in + either fail (return . OpenApiSpecVersion) validatedVersion + where + readVersion :: Text -> Either String Version + readVersion v = case readP_to_S parseVersion (Text.unpack v) of + [] -> Left $ "Failed to parse as a version string " <> Text.unpack v + solutions -> Right (fst . last $ solutions) + instance FromJSON MediaType where parseJSON = withText "MediaType" $ \str -> maybe (fail $ "Invalid media type literal " <> Text.unpack str) pure $ parseAccept $ encodeUtf8 str @@ -1491,7 +1527,7 @@ instance FromJSON Responses where parseJSON (Object o) = Responses <$> o .:? "default" - <*> parseJSON (Object (HashMap.delete "default" o)) + <*> parseJSON (Object (deleteKey "default" o)) parseJSON _ = empty instance FromJSON Example where @@ -1590,8 +1626,10 @@ swaggerAesonOptions _ = mkSwaggerAesonOptions "securityScheme" & saoSubObject ?~ "type" instance HasSwaggerAesonOptions Schema where swaggerAesonOptions _ = mkSwaggerAesonOptions "schema" & saoSubObject ?~ "paramSchema" +instance HasSwaggerAesonOptions OpenApiSpecVersion where + swaggerAesonOptions _ = mkSwaggerAesonOptions "openapi" instance HasSwaggerAesonOptions OpenApi where - swaggerAesonOptions _ = mkSwaggerAesonOptions "swagger" & saoAdditionalPairs .~ [("openapi", "3.0.0")] + swaggerAesonOptions _ = mkSwaggerAesonOptions "swagger" instance HasSwaggerAesonOptions Example where swaggerAesonOptions _ = mkSwaggerAesonOptions "example" instance HasSwaggerAesonOptions Encoding where @@ -1600,6 +1638,9 @@ instance HasSwaggerAesonOptions Link where swaggerAesonOptions _ = mkSwaggerAesonOptions "link" +instance AesonDefaultValue Version where + defaultValue = Just (makeVersion [3,0,0]) +instance AesonDefaultValue OpenApiSpecVersion instance AesonDefaultValue Server instance AesonDefaultValue Components instance AesonDefaultValue OAuth2ImplicitFlow @@ -1614,3 +1655,5 @@ instance AesonDefaultValue Info instance AesonDefaultValue ParamLocation 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 --- a/src/Data/OpenApi/Internal/AesonUtils.hs +++ b/src/Data/OpenApi/Internal/AesonUtils.hs @@ -1,10 +1,3 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE ExplicitForAll #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE UndecidableSuperClasses #-} module Data.OpenApi.Internal.AesonUtils ( -- * Generic functions AesonDefaultValue(..), @@ -36,18 +29,19 @@ import Generics.SOP import qualified Data.Text as T -import qualified Data.HashMap.Strict as HM import qualified Data.Set as Set -import qualified Data.HashMap.Strict.InsOrd as InsOrd +import qualified Data.HashMap.Strict.InsOrd.Compat as InsOrd import qualified Data.HashSet.InsOrd as InsOrdHS +import Data.OpenApi.Aeson.Compat (keyToString, objectToList, stringToKey) + ------------------------------------------------------------------------------- -- SwaggerAesonOptions ------------------------------------------------------------------------------- data SwaggerAesonOptions = SwaggerAesonOptions { _saoPrefix :: String - , _saoAdditionalPairs :: [(Text, Value)] + , _saoAdditionalPairs :: [Pair] , _saoSubObject :: Maybe String } @@ -154,14 +148,14 @@ go Nil Nil Nil = [] go (I x :* xs) (FieldInfo name :* names) (def :* defs) | Just name' == sub = case json of - Object m -> HM.toList m ++ rest + Object m -> objectToList m ++ rest Null -> rest _ -> error $ "sopSwaggerGenericToJSON: subjson is not an object: " ++ show json -- If default value: omit it. | Just x == def = rest | otherwise = - (T.pack name', json) : rest + (stringToKey name', json) : rest where json = toJSON x name' = fieldNameModifier name @@ -195,11 +189,11 @@ proxy = Proxy :: Proxy a opts = swaggerAesonOptions proxy - parseAdditionalField :: Object -> (Text, Value) -> Parser () + parseAdditionalField :: Object -> Pair -> Parser () parseAdditionalField obj (k, v) = do v' <- obj .: k unless (v == v') $ fail $ - "Additonal field don't match for key " ++ T.unpack k + "Additonal field don't match for key " ++ keyToString k ++ ": " ++ show v ++ " /= " ++ show v' @@ -230,8 +224,8 @@ -- Note: we might strip fields of outer structure. cons <$> (withDef $ parseJSON $ Object obj) <*> rest | otherwise = case def of - Just def' -> cons <$> obj .:? T.pack name' .!= def' <*> rest - Nothing -> cons <$> obj .: T.pack name' <*> rest + Just def' -> cons <$> obj .:? stringToKey name' .!= def' <*> rest + Nothing -> cons <$> obj .: stringToKey name' <*> rest where cons h t = I h :* t name' = fieldNameModifier name @@ -294,14 +288,14 @@ go Nil Nil Nil = mempty go (I x :* xs) (FieldInfo name :* names) (def :* defs) | Just name' == sub = case toJSON x of - Object m -> pairsToSeries (HM.toList m) <> rest + 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 = rest | otherwise = - (T.pack name' .= x) <> rest + (stringToKey name' .= x) <> rest where name' = fieldNameModifier name rest = go xs names defs diff --git a/src/Data/OpenApi/Internal/ParamSchema.hs b/src/Data/OpenApi/Internal/ParamSchema.hs --- a/src/Data/OpenApi/Internal/ParamSchema.hs +++ b/src/Data/OpenApi/Internal/ParamSchema.hs @@ -1,16 +1,3 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PackageImports #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE UndecidableInstances #-} -- Generic a is redundant in ToParamSchema a default imple {-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For TypeErrors @@ -19,6 +6,7 @@ import Control.Lens import Data.Aeson (ToJSON (..)) +import Data.Kind (Type) import Data.Proxy import GHC.Generics @@ -313,7 +301,7 @@ genericToParamSchema :: forall a t. (Generic a, GToParamSchema (Rep a)) => SchemaOptions -> Proxy a -> Schema genericToParamSchema opts _ = gtoParamSchema opts (Proxy :: Proxy (Rep a)) mempty -class GToParamSchema (f :: * -> *) where +class GToParamSchema (f :: Type -> Type) where gtoParamSchema :: SchemaOptions -> Proxy f -> Schema -> Schema instance GToParamSchema f => GToParamSchema (D1 d f) where @@ -331,7 +319,7 @@ instance (GEnumParamSchema f, GEnumParamSchema g) => GToParamSchema (f :+: g) where gtoParamSchema opts _ = genumParamSchema opts (Proxy :: Proxy (f :+: g)) -class GEnumParamSchema (f :: * -> *) where +class GEnumParamSchema (f :: Type -> Type) where genumParamSchema :: SchemaOptions -> Proxy f -> Schema -> Schema instance (GEnumParamSchema f, GEnumParamSchema g) => GEnumParamSchema (f :+: g) where diff --git a/src/Data/OpenApi/Internal/Schema.hs b/src/Data/OpenApi/Internal/Schema.hs --- a/src/Data/OpenApi/Internal/Schema.hs +++ b/src/Data/OpenApi/Internal/Schema.hs @@ -1,21 +1,5 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PackageImports #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For TypeErrors {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} @@ -24,11 +8,14 @@ import Prelude () import Prelude.Compat +import Data.Kind (Type) + import Control.Lens hiding (allOf) import Data.Data.Lens (template) +import Control.Applicative ((<|>)) import Control.Monad -import Control.Monad.Writer +import Control.Monad.Writer hiding (First, Last) import Data.Aeson (Object (..), SumEncoding (..), ToJSON (..), ToJSONKey (..), ToJSONKeyFunction (..), Value (..)) import Data.Char @@ -38,7 +25,7 @@ import qualified Data.HashMap.Strict as HashMap import "unordered-containers" Data.HashSet (HashSet) import qualified "unordered-containers" Data.HashSet as HashSet -import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap +import qualified Data.HashMap.Strict.InsOrd.Compat as InsOrdHashMap import Data.Int import Data.IntSet (IntSet) import Data.IntMap (IntMap) @@ -50,6 +37,7 @@ import Data.Scientific (Scientific) import Data.Fixed (Fixed, HasResolution, Pico) import Data.Set (Set) +import Data.Semigroup import qualified Data.Text as T import qualified Data.Text.Lazy as TL import Data.Time @@ -64,13 +52,14 @@ import qualified Data.UUID.Types as UUID import Type.Reflection (Typeable, typeRep) -import Data.OpenApi.Declare -import Data.OpenApi.Internal -import Data.OpenApi.Internal.ParamSchema (ToParamSchema(..)) -import Data.OpenApi.Lens hiding (name, schema) -import qualified Data.OpenApi.Lens as Swagger -import Data.OpenApi.SchemaOptions -import Data.OpenApi.Internal.TypeShape +import Data.OpenApi.Aeson.Compat (keyToText, objectKeys, toInsOrdHashMap) +import Data.OpenApi.Declare +import Data.OpenApi.Internal +import Data.OpenApi.Internal.ParamSchema (ToParamSchema (..)) +import Data.OpenApi.Internal.TypeShape +import Data.OpenApi.Lens hiding (name, schema) +import qualified Data.OpenApi.Lens as Swagger +import Data.OpenApi.SchemaOptions import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy.Char8 as BSL @@ -91,6 +80,13 @@ rename :: Maybe T.Text -> NamedSchema -> NamedSchema rename name (NamedSchema _ schema) = NamedSchema name schema +-- $setup +-- >>> import Data.Aeson.Types (toJSONKeyText) +-- >>> import qualified Data.ByteString.Lazy.Char8 as BSL +-- >>> import Data.OpenApi.Internal +-- >>> import Data.OpenApi.Internal.Utils (encodePretty) +-- >>> import Data.OpenApi.Lens (name, schema) + -- | Convert a type into @'Schema'@. -- -- An example type and instance: @@ -405,8 +401,8 @@ _ -> Nothing go (Object o) = mempty & type_ ?~ OpenApiObject - & required .~ sort (HashMap.keys o) - & properties .~ fmap (Inline . go) (InsOrdHashMap.fromHashMap o) + & required .~ sort (objectKeys o) + & properties .~ fmap (Inline . go) (toInsOrdHashMap o) -- | Make a restrictive sketch of a @'Schema'@ based on a @'ToJSON'@ instance. -- Produced schema uses as much constraints as possible. @@ -570,14 +566,14 @@ go js@(Object o) = mempty & type_ ?~ OpenApiObject & required .~ sort names - & properties .~ fmap (Inline . go) (InsOrdHashMap.fromHashMap o) + & properties .~ fmap (Inline . go) (toInsOrdHashMap o) & maxProperties ?~ fromIntegral (length names) & minProperties ?~ fromIntegral (length names) & enum_ ?~ [js] where - names = HashMap.keys o + names = objectKeys o -class GToSchema (f :: * -> *) where +class GToSchema (f :: Type -> Type) where gdeclareNamedSchema :: SchemaOptions -> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema instance {-# OVERLAPPABLE #-} ToSchema a => ToSchema [a] where @@ -810,13 +806,13 @@ (Bounded key, Enum key, ToJSONKey key, ToSchema key, ToSchema value) => Proxy (map key value) -> Declare (Definitions Schema) Schema declareSchemaBoundedEnumKeyMapping _ = case toJSONKey :: ToJSONKeyFunction key of - ToJSONKeyText keyToText _ -> objectSchema keyToText + ToJSONKeyText getKey _ -> objectSchema getKey ToJSONKeyValue _ _ -> declareSchema (Proxy :: Proxy [(key, value)]) where - objectSchema keyToText = do + objectSchema getKey = do valueRef <- declareSchemaRef (Proxy :: Proxy value) let allKeys = [minBound..maxBound :: key] - mkPair k = (keyToText k, valueRef) + mkPair k = (keyToText $ getKey k, valueRef) return $ mempty & type_ ?~ OpenApiObject & properties .~ InsOrdHashMap.fromList (map mkPair allKeys) @@ -944,10 +940,13 @@ case schema ^. items of Just (OpenApiItemsArray [_]) -> fieldSchema _ -> do - declare defs - return (unnamed schema) + -- We have to run recordSchema instead of just using its defs, + -- since those can be recursive and will lead to infinite loop, + -- see https://github.com/biocad/openapi3/pull/37 + NamedSchema _ schema' <- recordSchema + return (unnamed schema') where - (defs, NamedSchema _ schema) = runDeclare recordSchema mempty + (_, NamedSchema _ schema) = runDeclare recordSchema mempty recordSchema = gdeclareNamedSchema opts (Proxy :: Proxy (S1 s f)) s fieldSchema = gdeclareNamedSchema opts (Proxy :: Proxy f) s @@ -1014,7 +1013,7 @@ ) => GToSchema (f :+: g) where -- Aeson does not unwrap unary record in sum types. - gdeclareNamedSchema opts p s = gdeclareNamedSumSchema (opts { unwrapUnaryRecords = False } )p s + gdeclareNamedSchema opts = gdeclareNamedSumSchema (opts { unwrapUnaryRecords = False }) gdeclareNamedSumSchema :: GSumToSchema f => SchemaOptions -> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema gdeclareNamedSumSchema opts proxy _ @@ -1022,7 +1021,6 @@ | otherwise = do (schemas, _) <- runWriterT declareSumSchema return $ unnamed $ mempty - & type_ ?~ OpenApiObject & oneOf ?~ (snd <$> schemas) where declareSumSchema = gsumToSchema opts proxy @@ -1034,7 +1032,7 @@ type AllNullary = All -class GSumToSchema (f :: * -> *) where +class GSumToSchema (f :: Type -> Type) where gsumToSchema :: SchemaOptions -> Proxy f -> WriterT AllNullary (Declare (Definitions Schema)) [(T.Text, Referenced Schema)] instance (GSumToSchema f, GSumToSchema g) => GSumToSchema (f :+: g) where @@ -1044,8 +1042,15 @@ -- | Convert one component of the sum to schema, to be later combined with @oneOf@. gsumConToSchemaWith :: forall c f. (GToSchema (C1 c f), Constructor c) => Maybe (Referenced Schema) -> SchemaOptions -> Proxy (C1 c f) -> (T.Text, Referenced Schema) -gsumConToSchemaWith ref opts _ = (tag, schema) +gsumConToSchemaWith ref opts _ = (tag, withTitle) where + -- Give sub-schemas @title@ attribute with constructor name, if none present. + -- This will look prettier in swagger-ui. + withTitle = case schema of + Inline sub -> Inline $ sub + & title %~ (<|> Just (T.pack constructorName)) + s -> s + schema = case sumEncoding opts of TaggedObject tagField contentsField -> case ref of @@ -1053,13 +1058,13 @@ -- to the record, as Aeson does it. Just (Inline sub) | sub ^. type_ == Just OpenApiObject && isRecord -> Inline $ sub & required <>~ [T.pack tagField] - & properties . at (T.pack tagField) ?~ (Inline $ mempty & type_ ?~ OpenApiString & enum_ ?~ [String tag]) + & properties . at (T.pack tagField) ?~ Inline (mempty & type_ ?~ OpenApiString & enum_ ?~ [String tag]) -- If it is not a record, we need to put subschema into "contents" field. _ | not isRecord -> Inline $ mempty & type_ ?~ OpenApiObject & required .~ [T.pack tagField] - & properties . at (T.pack tagField) ?~ (Inline $ mempty & type_ ?~ OpenApiString & enum_ ?~ [String tag]) + & properties . at (T.pack tagField) ?~ Inline (mempty & type_ ?~ OpenApiString & enum_ ?~ [String tag]) -- If constructor is nullary, there is no content. & case ref of Just r -> (properties . at (T.pack contentsField) ?~ r) . (required <>~ [T.pack contentsField]) @@ -1067,11 +1072,10 @@ -- In the remaining cases we combine "tag" object and "contents" object using allOf. _ -> Inline $ mempty - & type_ ?~ OpenApiObject & allOf ?~ [Inline $ mempty & type_ ?~ OpenApiObject & required .~ (T.pack tagField : if isRecord then [] else [T.pack contentsField]) - & properties . at (T.pack tagField) ?~ (Inline $ mempty & type_ ?~ OpenApiString & enum_ ?~ [String tag])] + & properties . at (T.pack tagField) ?~ Inline (mempty & type_ ?~ OpenApiString & enum_ ?~ [String tag])] & if isRecord then allOf . _Just <>~ [refOrNullary] else allOf . _Just <>~ [Inline $ mempty & type_ ?~ OpenApiObject & properties . at (T.pack contentsField) ?~ refOrNullary] @@ -1082,7 +1086,8 @@ & properties . at tag ?~ refOrNullary TwoElemArray -> error "unrepresentable in OpenAPI 3" - tag = T.pack (constructorTagModifier opts (conName (Proxy3 :: Proxy3 c f p))) + constructorName = conName (Proxy3 :: Proxy3 c f p) + tag = T.pack (constructorTagModifier opts constructorName) isRecord = conIsRecord (Proxy3 :: Proxy3 c f p) refOrNullary = fromMaybe (Inline nullarySchema) ref refOrEnum = fromMaybe (Inline $ mempty & type_ ?~ OpenApiString & enum_ ?~ [String tag]) ref diff --git a/src/Data/OpenApi/Internal/Schema/Validation.hs b/src/Data/OpenApi/Internal/Schema/Validation.hs --- a/src/Data/OpenApi/Internal/Schema/Validation.hs +++ b/src/Data/OpenApi/Internal/Schema/Validation.hs @@ -1,18 +1,5 @@ {-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PackageImports #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE CPP #-} -- | -- Module: Data.OpenApi.Internal.Schema.Validation -- Copyright: (c) 2015 GetShopTV @@ -31,11 +18,15 @@ import Control.Monad (forM, forM_, when) import Data.Aeson hiding (Result) +#if MIN_VERSION_aeson(2,0,0) +import qualified Data.Aeson.KeyMap as KeyMap +#endif import Data.Foldable (for_, sequenceA_, traverse_) +#if !MIN_VERSION_aeson(2,0,0) import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HashMap -import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap +#endif +import qualified Data.HashMap.Strict.InsOrd.Compat as InsOrdHashMap import qualified "unordered-containers" Data.HashSet as HashSet import Data.Maybe (fromMaybe) import Data.Proxy @@ -47,12 +38,16 @@ import Data.Vector (Vector) import qualified Data.Vector as Vector -import Data.OpenApi.Declare -import Data.OpenApi.Internal -import Data.OpenApi.Internal.Utils -import Data.OpenApi.Internal.Schema -import Data.OpenApi.Lens +import Data.OpenApi.Aeson.Compat (hasKey, keyToText, lookupKey, objectToList) +import Data.OpenApi.Declare +import Data.OpenApi.Internal +import Data.OpenApi.Internal.Schema +import Data.OpenApi.Internal.Utils +import Data.OpenApi.Lens +-- $setup +-- >>> import Data.OpenApi.Internal.Schema.Validation + -- | Validate @'ToJSON'@ instance matches @'ToSchema'@ for a given value. -- This can be used with QuickCheck to ensure those instances are coherent: -- @@ -366,10 +361,16 @@ len = Vector.length xs allUnique = len == HashSet.size (HashSet.fromList (Vector.toList xs)) -validateObject :: HashMap Text Value -> Validation Schema () +validateObject :: +#if MIN_VERSION_aeson(2,0,0) + KeyMap.KeyMap Value +#else + HashMap Text Value +#endif + -> Validation Schema () validateObject o = withSchema $ \sch -> case sch ^. discriminator of - Just (Discriminator pname types) -> case fromJSON <$> HashMap.lookup pname o of + Just (Discriminator pname types) -> case fromJSON <$> lookupKey pname o of Just (Success pvalue) -> let ref = fromMaybe pvalue $ InsOrdHashMap.lookup pvalue types -- TODO ref may be name or reference @@ -388,15 +389,15 @@ validateRequired validateProps where - size = fromIntegral (HashMap.size o) + size = fromIntegral (length o) validateRequired = withSchema $ \sch -> traverse_ validateReq (sch ^. required) validateReq n = - when (not (HashMap.member n o)) $ + when (not (hasKey n o)) $ invalid ("property " ++ show n ++ " is required, but not found in " ++ show (encode o)) validateProps = withSchema $ \sch -> do - for_ (HashMap.toList o) $ \(k, v) -> + for_ (objectToList o) $ \(keyToText -> k, v) -> case v of Null | not (k `elem` (sch ^. required)) -> valid -- null is fine for non-required property _ -> diff --git a/src/Data/OpenApi/Internal/TypeShape.hs b/src/Data/OpenApi/Internal/TypeShape.hs --- a/src/Data/OpenApi/Internal/TypeShape.hs +++ b/src/Data/OpenApi/Internal/TypeShape.hs @@ -1,11 +1,7 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} module Data.OpenApi.Internal.TypeShape where +import Data.Kind (Type) import Data.Proxy import GHC.Generics import GHC.TypeLits @@ -46,7 +42,7 @@ ) -- | Infer a 'TypeShape' for a generic representation of a type. -type family GenericShape (g :: * -> *) :: TypeShape +type family GenericShape (g :: Type -> Type) :: TypeShape type instance GenericShape (f :*: g) = ProdCombine (GenericShape f) (GenericShape g) type instance GenericShape (f :+: g) = SumCombine (GenericShape f) (GenericShape g) diff --git a/src/Data/OpenApi/Internal/Utils.hs b/src/Data/OpenApi/Internal/Utils.hs --- a/src/Data/OpenApi/Internal/Utils.hs +++ b/src/Data/OpenApi/Internal/Utils.hs @@ -1,9 +1,3 @@ -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeOperators #-} module Data.OpenApi.Internal.Utils where import Prelude () @@ -20,8 +14,8 @@ import Data.Hashable (Hashable) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap -import Data.HashMap.Strict.InsOrd (InsOrdHashMap) -import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap +import Data.HashMap.Strict.InsOrd.Compat (InsOrdHashMap) +import qualified Data.HashMap.Strict.InsOrd.Compat as InsOrdHashMap import Data.Map (Map) import Data.Set (Set) import Data.Text (Text) diff --git a/src/Data/OpenApi/Lens.hs b/src/Data/OpenApi/Lens.hs --- a/src/Data/OpenApi/Lens.hs +++ b/src/Data/OpenApi/Lens.hs @@ -1,13 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module: Data.OpenApi.Lens diff --git a/src/Data/OpenApi/Operation.hs b/src/Data/OpenApi/Operation.hs --- a/src/Data/OpenApi/Operation.hs +++ b/src/Data/OpenApi/Operation.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE RankNTypes #-} -- | -- Module: Data.OpenApi.Operation -- Maintainer: Nickolay Kudasov @@ -47,7 +46,7 @@ import Data.OpenApi.Lens import Data.OpenApi.Schema -import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap +import qualified Data.HashMap.Strict.InsOrd.Compat as InsOrdHashMap import qualified Data.HashSet.InsOrd as InsOrdHS -- $setup @@ -55,12 +54,13 @@ -- >>> import Data.Proxy -- >>> import Data.Time -- >>> import qualified Data.ByteString.Lazy.Char8 as BSL +-- >>> import qualified Data.HashMap.Strict.InsOrd.Compat as IOHM -- >>> import Data.OpenApi.Internal.Utils -- | Prepend path piece to all operations of the spec. -- Leading and trailing slashes are trimmed/added automatically. -- --- >>> let api = (mempty :: OpenApi) & paths .~ [("/info", mempty)] +-- >>> let api = (mempty :: OpenApi) & paths .~ IOHM.fromList [("/info", mempty)] -- >>> BSL.putStrLn $ encodePretty $ prependPath "user/{user_id}" api ^. paths -- { -- "/user/{user_id}/info": {} @@ -83,8 +83,8 @@ -- by both path and method. -- -- >>> let ok = (mempty :: Operation) & at 200 ?~ "OK" --- >>> let api = (mempty :: OpenApi) & paths .~ [("/user", mempty & get ?~ ok & post ?~ ok)] --- >>> let sub = (mempty :: OpenApi) & paths .~ [("/user", mempty & get ?~ mempty)] +-- >>> let api = (mempty :: OpenApi) & paths .~ IOHM.fromList [("/user", mempty & get ?~ ok & post ?~ ok)] +-- >>> let sub = (mempty :: OpenApi) & paths .~ IOHM.fromList [("/user", mempty & get ?~ mempty)] -- >>> BSL.putStrLn $ encodePretty api -- { -- "components": {}, @@ -215,7 +215,7 @@ -- -- Example: -- --- >>> let api = (mempty :: OpenApi) & paths .~ [("/user", mempty & get ?~ mempty)] +-- >>> let api = (mempty :: OpenApi) & paths .~ IOHM.fromList [("/user", mempty & get ?~ mempty)] -- >>> let res = declareResponse "application/json" (Proxy :: Proxy Day) -- >>> BSL.putStrLn $ encodePretty $ api & setResponse 200 res -- { diff --git a/src/Data/OpenApi/Optics.hs b/src/Data/OpenApi/Optics.hs --- a/src/Data/OpenApi/Optics.hs +++ b/src/Data/OpenApi/Optics.hs @@ -1,10 +1,3 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module: Data.OpenApi.Optics @@ -18,14 +11,15 @@ -- >>> import Optics.Core -- >>> :set -XOverloadedLabels -- >>> import qualified Data.ByteString.Lazy.Char8 as BSL +-- >>> import qualified Data.HashMap.Strict.InsOrd.Compat as IOHM -- -- Example from the "Data.OpenApi" module using @optics@: -- -- >>> :{ -- BSL.putStrLn $ encodePretty $ (mempty :: OpenApi) --- & #components % #schemas .~ [ ("User", mempty & #type ?~ OpenApiString) ] +-- & #components % #schemas .~ IOHM.fromList [ ("User", mempty & #type ?~ OpenApiString) ] -- & #paths .~ --- [ ("/user", mempty & #get ?~ (mempty +-- IOHM.fromList [ ("/user", mempty & #get ?~ (mempty -- & at 200 ?~ ("OK" & #_Inline % #content % at "application/json" ?~ (mempty & #schema ?~ Ref (Reference "User"))) -- & at 404 ?~ "User info not found")) ] -- :} diff --git a/src/Data/OpenApi/Schema/Generator.hs b/src/Data/OpenApi/Schema/Generator.hs --- a/src/Data/OpenApi/Schema/Generator.hs +++ b/src/Data/OpenApi/Schema/Generator.hs @@ -1,6 +1,4 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedLists #-} module Data.OpenApi.Schema.Generator where @@ -11,7 +9,7 @@ import Control.Monad (filterM) import Data.Aeson import Data.Aeson.Types -import qualified Data.HashMap.Strict.InsOrd as M +import qualified Data.HashMap.Strict.InsOrd.Compat as M import Data.Maybe import Data.Proxy import Data.Scientific @@ -25,6 +23,8 @@ import Test.QuickCheck.Gen import Test.QuickCheck.Property +import Data.OpenApi.Aeson.Compat (fromInsOrdHashMap) + -- | Note: 'schemaGen' may 'error', if schema type is not specified, -- and cannot be inferred. schemaGen :: Definitions Schema -> Schema -> Gen Value @@ -68,6 +68,7 @@ OpenApiItemsArray refs -> let itemGens = schemaGen defns . dereference defns <$> refs in fmap (Array . V.fromList) $ sequence itemGens + | otherwise -> pure $ Array V.empty Just OpenApiString -> do size <- getSize let minLength' = fromMaybe 0 $ fromInteger <$> schema ^. minLength @@ -95,7 +96,7 @@ return . M.fromList $ zip additionalKeys (repeat . schemaGen defns $ dereference defns addlSchema) _ -> return [] x <- sequence $ gens <> additionalGens - return . Object $ M.toHashMap x + return . Object $ fromInsOrdHashMap x dereference :: Definitions a -> Referenced a -> a dereference _ (Inline a) = a diff --git a/src/Data/OpenApi/SchemaOptions.hs b/src/Data/OpenApi/SchemaOptions.hs --- a/src/Data/OpenApi/SchemaOptions.hs +++ b/src/Data/OpenApi/SchemaOptions.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE RecordWildCards #-} -- | -- Module: Data.OpenApi.SchemaOptions -- Maintainer: Nickolay Kudasov diff --git a/test/Data/OpenApi/CommonTestTypes.hs b/test/Data/OpenApi/CommonTestTypes.hs --- a/test/Data/OpenApi/CommonTestTypes.hs +++ b/test/Data/OpenApi/CommonTestTypes.hs @@ -277,6 +277,7 @@ "tag", "contents" ], + "title": "PC", "type": "object", "properties": { "tag": { @@ -296,6 +297,7 @@ "npcPosition", "tag" ], + "title": "NPC", "type": "object", "properties": { "tag": { @@ -312,8 +314,7 @@ } } } - ], - "type": "object" + ] } |] @@ -327,6 +328,7 @@ "tag", "contents" ], + "title": "PC", "type": "object", "properties": { "tag": { @@ -368,6 +370,7 @@ "npcPosition", "tag" ], + "title": "NPC", "type": "object", "properties": { "tag": { @@ -398,8 +401,7 @@ } } } - ], - "type": "object" + ] } |] @@ -412,6 +414,7 @@ "tag", "contents" ], + "title": "PC", "type": "object", "properties": { "tag": { @@ -439,6 +442,7 @@ "npcPosition", "tag" ], + "title": "NPC", "type": "object", "properties": { "tag": { @@ -455,8 +459,7 @@ } } } - ], - "type": "object" + ] } |] @@ -639,6 +642,7 @@ "required": [ "tag" ], + "title": "NoLight", "type": "object", "properties": { "tag": { @@ -654,6 +658,7 @@ "tag", "contents" ], + "title": "LightFreq", "type": "object", "properties": { "tag": { @@ -673,6 +678,7 @@ "tag", "contents" ], + "title": "LightColor", "type": "object", "properties": { "tag": { @@ -691,6 +697,7 @@ "waveLength", "tag" ], + "title": "LightWaveLength", "type": "object", "properties": { "tag": { @@ -705,8 +712,7 @@ } } } - ], - "type": "object" + ] } |] @@ -718,6 +724,7 @@ "required": [ "tag" ], + "title": "NoLight", "type": "object", "properties": { "tag": { @@ -733,6 +740,7 @@ "tag", "contents" ], + "title": "LightFreq", "type": "object", "properties": { "tag": { @@ -752,6 +760,7 @@ "tag", "contents" ], + "title": "LightColor", "type": "object", "properties": { "tag": { @@ -775,6 +784,7 @@ "waveLength", "tag" ], + "title": "LightWaveLength", "type": "object", "properties": { "tag": { @@ -789,8 +799,7 @@ } } } - ], - "type": "object" + ] } |] @@ -863,6 +872,131 @@ } |] +-- ======================================================================== +-- Natural Language (single field data with recursive fields) +-- ======================================================================== + +data Predicate + = PredicateNoun Noun + | PredicateOmitted Omitted + deriving (Eq, Ord, Read, Show, Generic) +instance ToJSON Predicate +instance ToSchema Predicate + +data Noun + = Noun + { nounSurf :: LangWord + , nounModify :: [Modifier] + } + deriving (Eq, Ord, Read, Show, Generic) +instance ToJSON Noun +instance ToSchema Noun + +data LangWord + = LangWord + { langWordSurf :: String + , langWordBase :: String + } + deriving (Eq, Ord, Read, Show, Generic) +instance ToJSON LangWord +instance ToSchema LangWord + +data Modifier + = ModifierNoun Noun + | ModifierOmitted Omitted + deriving (Eq, Ord, Read, Show, Generic) +instance ToJSON Modifier +instance ToSchema Modifier + +newtype Omitted + = Omitted + { omittedModify :: [Modifier] + } + deriving (Eq, Ord, Read, Show, Generic) +instance ToJSON Omitted +instance ToSchema Omitted + +predicateSchemaDeclareJSON :: Value +predicateSchemaDeclareJSON = [aesonQQ| +[ + { + "Predicate": { + "oneOf": [ + { + "properties": { + "contents": { "$ref": "#/components/schemas/Noun" }, + "tag": { "enum": ["PredicateNoun"], "type": "string" } + }, + "required": ["tag", "contents"], + "title": "PredicateNoun", + "type": "object" + }, + { + "properties": { + "contents": { "$ref": "#/components/schemas/Omitted" }, + "tag": { "enum": ["PredicateOmitted"], "type": "string" } + }, + "required": ["tag", "contents"], + "title": "PredicateOmitted", + "type": "object" + } + ] + }, + "Noun": { + "properties": { + "nounModify": { + "items": { "$ref": "#/components/schemas/Modifier" }, + "type": "array" + }, + "nounSurf": { "$ref": "#/components/schemas/LangWord" } + }, + "required": ["nounSurf", "nounModify"], + "type": "object" + }, + "LangWord": { + "properties": { + "langWordBase": { "type": "string" }, + "langWordSurf": { "type": "string" } + }, + "required": ["langWordSurf", "langWordBase"], + "type": "object" + }, + "Modifier": { + "oneOf": [ + { + "properties": { + "contents": { "$ref": "#/components/schemas/Noun" }, + "tag": { "enum": ["ModifierNoun"], "type": "string" } + }, + "required": ["tag", "contents"], + "title": "ModifierNoun", + "type": "object" + }, + { + "properties": { + "contents": { "$ref": "#/components/schemas/Omitted" }, + "tag": { "enum": ["ModifierOmitted"], "type": "string" } + }, + "required": ["tag", "contents"], + "title": "ModifierOmitted", + "type": "object" + } + ] + }, + "Omitted": { + "properties": { + "omittedModify": { + "items": { "$ref": "#/components/schemas/Modifier" }, + "type": "array" + } + }, + "required": ["omittedModify"], + "type": "object" + } + }, + { "$ref": "#/components/schemas/Predicate" } +] +|] -- ======================================================================== -- TimeOfDay diff --git a/test/Data/OpenApi/Schema/ValidationSpec.hs b/test/Data/OpenApi/Schema/ValidationSpec.hs --- a/test/Data/OpenApi/Schema/ValidationSpec.hs +++ b/test/Data/OpenApi/Schema/ValidationSpec.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE PackageImports #-} {-# LANGUAGE RecordWildCards #-} @@ -8,6 +9,10 @@ import Control.Applicative import Control.Lens ((&), (.~), (?~)) import Data.Aeson +#if MIN_VERSION_aeson(2,0,0) +import qualified Data.Aeson.Key as Key +import qualified Data.Aeson.KeyMap as KeyMap +#endif import Data.Aeson.Types import Data.Hashable (Hashable) import Data.HashMap.Strict (HashMap) @@ -30,6 +35,7 @@ import Data.OpenApi import Data.OpenApi.Declare +import Data.OpenApi.Aeson.Compat (stringToKey) import Test.Hspec import Test.Hspec.QuickCheck @@ -124,9 +130,9 @@ invalidPersonToJSON :: Person -> Value invalidPersonToJSON Person{..} = object - [ T.pack "personName" .= toJSON name - , T.pack "personPhone" .= toJSON phone - , T.pack "personEmail" .= toJSON email + [ stringToKey "personName" .= toJSON name + , stringToKey "personPhone" .= toJSON phone + , stringToKey "personEmail" .= toJSON email ] -- ======================================================================== @@ -295,6 +301,8 @@ -- Arbitrary instance for Data.Aeson.Value -- ======================================================================== +-- These instances were introduces in aeson upstream in 2.0.3 +#if !MIN_VERSION_aeson(2,0,3) instance Arbitrary Value where -- Weights are almost random -- Uniform oneof tends not to build complex objects cause of recursive call. @@ -305,3 +313,12 @@ , (3, Number <$> arbitrary) , (3, Bool <$> arbitrary) , (1, return Null) ] + +#if MIN_VERSION_aeson(2,0,0) +instance Arbitrary v => Arbitrary (KeyMap.KeyMap v) where + arbitrary = KeyMap.fromList <$> arbitrary + +instance Arbitrary Key.Key where + arbitrary = Key.fromText <$> arbitrary +#endif +#endif diff --git a/test/Data/OpenApi/SchemaSpec.hs b/test/Data/OpenApi/SchemaSpec.hs --- a/test/Data/OpenApi/SchemaSpec.hs +++ b/test/Data/OpenApi/SchemaSpec.hs @@ -9,7 +9,7 @@ import Control.Lens ((^.)) import Data.Aeson (Value) -import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap +import qualified Data.HashMap.Strict.InsOrd.Compat as InsOrdHashMap import Data.Proxy import Data.Set (Set) import qualified Data.Text as Text @@ -59,6 +59,9 @@ where (defs, s) = runDeclare (declareSchema proxy) mempty +checkToSchemaDeclare :: (HasCallStack, ToSchema a) => Proxy a -> Value -> Spec +checkToSchemaDeclare proxy js = runDeclare (declareSchemaRef proxy) mempty <=> js + spec :: Spec spec = do describe "Generic ToSchema" $ do @@ -78,6 +81,7 @@ context "UserId (non-record newtype)" $ checkToSchema (Proxy :: Proxy UserId) userIdSchemaJSON context "Player (unary record)" $ checkToSchema (Proxy :: Proxy Player) playerSchemaJSON context "SingleMaybeField (unary record with Maybe)" $ checkToSchema (Proxy :: Proxy SingleMaybeField) singleMaybeFieldSchemaJSON + context "Natural Language (single field data with recursive fields)" $ checkToSchemaDeclare (Proxy :: Proxy Predicate) predicateSchemaDeclareJSON context "Players (inlining schema)" $ checkToSchema (Proxy :: Proxy Players) playersSchemaJSON context "MyRoseTree (datatypeNameModifier)" $ checkToSchema (Proxy :: Proxy MyRoseTree) myRoseTreeSchemaJSON context "MyRoseTree' (datatypeNameModifier)" $ checkToSchema (Proxy :: Proxy MyRoseTree') myRoseTreeSchemaJSON' diff --git a/test/Data/OpenApiSpec.hs b/test/Data/OpenApiSpec.hs --- a/test/Data/OpenApiSpec.hs +++ b/test/Data/OpenApiSpec.hs @@ -36,15 +36,23 @@ describe "Responses Definition Object" $ responsesDefinitionExample <=> responsesDefinitionExampleJSON describe "Security Definitions Object" $ securityDefinitionsExample <=> securityDefinitionsExampleJSON describe "OAuth2 Security Definitions with merged Scope" $ oAuth2SecurityDefinitionsExample <=> oAuth2SecurityDefinitionsExampleJSON + describe "OAuth2 Security Definitions with empty Scope" $ oAuth2SecurityDefinitionsEmptyExample <=> oAuth2SecurityDefinitionsEmptyExampleJSON describe "Composition Schema Example" $ compositionSchemaExample <=> compositionSchemaExampleJSON describe "Swagger Object" $ do - context "Example with no paths" $ emptyPathsFieldExample <=> emptyPathsFieldExampleJSON + context "Example with no paths" $ do + emptyPathsFieldExample <=> emptyPathsFieldExampleJSON + it "fails to parse a spec with a wrong Openapi spec version" $ do + (fromJSON wrongVersionExampleJSON :: Result OpenApi) `shouldBe` Error "The provided version 3.0.4 is out of the allowed range >=3.0.0 && <=3.0.3" context "Todo Example" $ swaggerExample <=> swaggerExampleJSON context "PetStore Example" $ do it "decodes successfully" $ do fromJSON petstoreExampleJSON `shouldSatisfy` (\x -> case x of Success (_ :: OpenApi) -> True; _ -> False) it "roundtrips: fmap toJSON . fromJSON" $ do (toJSON :: OpenApi -> Value) <$> fromJSON petstoreExampleJSON `shouldBe` Success petstoreExampleJSON + context "Security schemes" $ do + it "merged correctly" $ do + let merged = oAuth2SecurityDefinitionsReadOpenApi <> oAuth2SecurityDefinitionsWriteOpenApi <> oAuth2SecurityDefinitionsEmptyOpenApi + merged `shouldBe` oAuth2SecurityDefinitionsOpenApi main :: IO () main = hspec spec @@ -441,7 +449,7 @@ |] -- ======================================================================= --- Responses Definition object +-- Security Definition object -- ======================================================================= securityDefinitionsExample :: SecurityDefinitions @@ -504,10 +512,22 @@ , _securitySchemeDescription = Nothing }) ] +oAuth2SecurityDefinitionsEmptyExample :: SecurityDefinitions +oAuth2SecurityDefinitionsEmptyExample = SecurityDefinitions + [ ("petstore_auth", SecurityScheme + { _securitySchemeType = SecuritySchemeOAuth2 (mempty & implicit ?~ OAuth2Flow + { _oAuth2Params = OAuth2ImplicitFlow "http://swagger.io/api/oauth/dialog" + , _oAath2RefreshUrl = Nothing + , _oAuth2Scopes = [] + } ) + , _securitySchemeDescription = Nothing }) + ] + oAuth2SecurityDefinitionsExample :: SecurityDefinitions oAuth2SecurityDefinitionsExample = oAuth2SecurityDefinitionsWriteExample <> - oAuth2SecurityDefinitionsReadExample + oAuth2SecurityDefinitionsReadExample <> + oAuth2SecurityDefinitionsEmptyExample oAuth2SecurityDefinitionsExampleJSON :: Value oAuth2SecurityDefinitionsExampleJSON = [aesonQQ| @@ -527,6 +547,37 @@ } |] +oAuth2SecurityDefinitionsEmptyExampleJSON :: Value +oAuth2SecurityDefinitionsEmptyExampleJSON = [aesonQQ| +{ + "petstore_auth": { + "type": "oauth2", + "flows": { + "implicit": { + "scopes": {}, + "authorizationUrl": "http://swagger.io/api/oauth/dialog" + } + } + } +} +|] + +oAuth2SecurityDefinitionsReadOpenApi :: OpenApi +oAuth2SecurityDefinitionsReadOpenApi = + mempty & components . securitySchemes .~ oAuth2SecurityDefinitionsReadExample + +oAuth2SecurityDefinitionsWriteOpenApi :: OpenApi +oAuth2SecurityDefinitionsWriteOpenApi = + mempty & components . securitySchemes .~ oAuth2SecurityDefinitionsWriteExample + +oAuth2SecurityDefinitionsEmptyOpenApi :: OpenApi +oAuth2SecurityDefinitionsEmptyOpenApi = + mempty & components . securitySchemes .~ oAuth2SecurityDefinitionsEmptyExample + +oAuth2SecurityDefinitionsOpenApi :: OpenApi +oAuth2SecurityDefinitionsOpenApi = + mempty & components . securitySchemes .~ oAuth2SecurityDefinitionsExample + -- ======================================================================= -- Swagger object -- ======================================================================= @@ -534,6 +585,16 @@ emptyPathsFieldExample :: OpenApi emptyPathsFieldExample = mempty +wrongVersionExampleJSON :: Value +wrongVersionExampleJSON = [aesonQQ| +{ + "openapi": "3.0.4", + "info": {"version": "", "title": ""}, + "paths": {}, + "components": {} +} +|] + emptyPathsFieldExampleJSON :: Value emptyPathsFieldExampleJSON = [aesonQQ| { @@ -647,7 +708,7 @@ petstoreExampleJSON :: Value petstoreExampleJSON = [aesonQQ| { - "openapi": "3.0.0", + "openapi": "3.0.3", "info": { "version": "1.0.0", "title": "Swagger Petstore", @@ -917,7 +978,6 @@ compositionSchemaExample :: Schema compositionSchemaExample = mempty - & type_ ?~ OpenApiObject & Data.OpenApi.allOf ?~ [ Ref (Reference "Other") , Inline (mempty @@ -930,7 +990,6 @@ compositionSchemaExampleJSON :: Value compositionSchemaExampleJSON = [aesonQQ| { - "type": "object", "allOf": [ { "$ref": "#/components/schemas/Other" diff --git a/test/SpecCommon.hs b/test/SpecCommon.hs --- a/test/SpecCommon.hs +++ b/test/SpecCommon.hs @@ -8,14 +8,6 @@ import Test.Hspec -isSubJSON :: Value -> Value -> Bool -isSubJSON Null _ = True -isSubJSON (Object x) (Object y) = HashMap.keys x == HashMap.keys i && F.and i - where - i = HashMap.intersectionWith isSubJSON x y -isSubJSON (Array xs) (Array ys) = Vector.length xs == Vector.length ys && F.and (Vector.zipWith isSubJSON xs ys) -isSubJSON x y = x == y - (<=>) :: (Eq a, Show a, ToJSON a, FromJSON a, HasCallStack) => a -> Value -> Spec x <=> js = do it "encodes correctly" $ do