packages feed

openapi3 3.1.0 → 3.2.5

raw patch · 23 files changed

Files

CHANGELOG.md view
@@ -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 -----
openapi3.cabal view
@@ -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
+ src/Data/HashMap/Strict/InsOrd/Compat.hs view
@@ -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 <nickolay@getshoptv.com>+-- Stability:   experimental+--+-- Compatibility wrapper around @insert-ordered-containers@ to mitigate the+-- breaking changes introduced in @insert-ordered-containers-0.3.0@:+-- <https://github.com/erikd/insert-ordered-containers/pull/8>.+--+-- 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
src/Data/OpenApi.hs view
@@ -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
+ src/Data/OpenApi/Aeson/Compat.hs view
@@ -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
src/Data/OpenApi/Declare.hs view
@@ -1,8 +1,3 @@-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE UndecidableInstances #-} -- | -- Module:      Data.OpenApi.Declare -- Maintainer:  Nickolay Kudasov <nickolay@getshoptv.com>@@ -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')
src/Data/OpenApi/Internal.hs view
@@ -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
src/Data/OpenApi/Internal/AesonUtils.hs view
@@ -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
src/Data/OpenApi/Internal/ParamSchema.hs view
@@ -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
src/Data/OpenApi/Internal/Schema.hs view
@@ -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
src/Data/OpenApi/Internal/Schema/Validation.hs view
@@ -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           _ ->
src/Data/OpenApi/Internal/TypeShape.hs view
@@ -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)
src/Data/OpenApi/Internal/Utils.hs view
@@ -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)
src/Data/OpenApi/Lens.hs view
@@ -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
src/Data/OpenApi/Operation.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE RankNTypes #-} -- | -- Module:      Data.OpenApi.Operation -- Maintainer:  Nickolay Kudasov <nickolay@getshoptv.com>@@ -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 -- {
src/Data/OpenApi/Optics.hs view
@@ -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")) ] -- :}
src/Data/OpenApi/Schema/Generator.hs view
@@ -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
src/Data/OpenApi/SchemaOptions.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE RecordWildCards #-} -- | -- Module:      Data.OpenApi.SchemaOptions -- Maintainer:  Nickolay Kudasov <nickolay@getshoptv.com>
test/Data/OpenApi/CommonTestTypes.hs view
@@ -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
test/Data/OpenApi/Schema/ValidationSpec.hs view
@@ -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
test/Data/OpenApi/SchemaSpec.hs view
@@ -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'
test/Data/OpenApiSpec.hs view
@@ -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"
test/SpecCommon.hs view
@@ -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