swagger2 2.4 → 2.9

raw patch · 24 files changed

Files

• CHANGELOG.md +99/−0
• include/overlapping-compat.h +0/−8
• src/Data/HashMap/Strict/InsOrd/Compat.hs +442/−0
• src/Data/Swagger.hs +14/−32
• src/Data/Swagger/Declare.hs +3/−8
• src/Data/Swagger/Internal.hs +108/−58
• src/Data/Swagger/Internal/AesonUtils.hs +22/−49
• src/Data/Swagger/Internal/ParamSchema.hs +15/−16
• src/Data/Swagger/Internal/Schema.hs +51/−50
• src/Data/Swagger/Internal/Schema/Validation.hs +104/−11
• src/Data/Swagger/Internal/TypeShape.hs +0/−10
• src/Data/Swagger/Internal/Utils.hs +2/−2
• src/Data/Swagger/Lens.hs +20/−22
• src/Data/Swagger/Operation.hs +23/−8
• src/Data/Swagger/Optics.hs +598/−0
• src/Data/Swagger/Schema/Generator.hs +3/−3
• src/Data/Swagger/Schema/Validation.hs +5/−3
• swagger2.cabal +44/−36
• test/Data/Swagger/CommonTestTypes.hs +56/−2
• test/Data/Swagger/ParamSchemaSpec.hs +6/−1
• test/Data/Swagger/Schema/ValidationSpec.hs +13/−5
• test/Data/Swagger/SchemaSpec.hs +7/−7
• test/Data/SwaggerSpec.hs +60/−3
• test/SpecCommon.hs +6/−4

@@ -1,3 +1,102 @@+2.9+---++- Support `insert-ordered-containers` by adding compatibility layer (see [#262](https://github.com/GetShopTV/swagger2/pull/262)).+- Relax upper bound for test dependencies (see [#259](https://github.com/GetShopTV/swagger2/pull/259)).++2.8.11+---++- Add DayOfWeek instance for GHC >= 8.8.4 (see [#250](https://github.com/GetShopTV/swagger2/pull/250));+2.8.10+---++- Support GHC 9.12 (see [#257](https://github.com/GetShopTV/swagger2/pull/257)).++2.8.9+---++- Support GHC 9.10 (see [#255](https://github.com/GetShopTV/swagger2/pull/255))++2.8.8+---++- Support GHC 9.8 (see [#249](https://github.com/GetShopTV/swagger2/pull/249));++2.8.7+---++- Support extensions on operations (see [#245](https://github.com/GetShopTV/swagger2/pull/245));+- Support GHC 9.6 (see [#246](https://github.com/GetShopTV/swagger2/pull/246));++2.8.6+---++- Support GHC 9.4 (see [#244](https://github.com/GetShopTV/swagger2/pull/244));++2.8.5+---++- Add newer dependencies (i.e. `aeson`, `lens`, etc.) (see [#242](https://github.com/GetShopTV/swagger2/pull/242));+++2.8.4+---++- Add GHC `9.2.3` to CI Matrix and bump stack resolver to `lts-19.11` (see [#237](https://github.com/GetShopTV/swagger2/pull/237));++2.8.3+---++- `mtl-2.3` and `transformers-0.6` support (see [#235](https://github.com/GetShopTV/swagger2/pull/235), [#236](https://github.com/GetShopTV/swagger2/pull/236));++2.8.2+---++- `text-2.0` support (see [#234](https://github.com/GetShopTV/swagger2/pull/234));++2.8.1+---++- Better error message in `validateSchemaType` (see [#221](https://github.com/GetShopTV/swagger2/pull/221));++2.8+---++- Support GHC 9.2 (see [#231](https://github.com/GetShopTV/swagger2/pull/231), [#232](https://github.com/GetShopTV/swagger2/pull/232), [#233](https://github.com/GetShopTV/swagger2/pull/233));+- Aeson `2.0.3.0` compatibility (see [#230]( https://github.com/GetShopTV/swagger2/pull/230 ));++2.7+---++- Upgrade `aeson` to `2.0.1.0` (see [#228]( https://github.com/GetShopTV/swagger2/pull/228 ));+- Switch from Travis CI to GitHub Actions (see [#228]( https://github.com/GetShopTV/swagger2/pull/228 ));+- GHC 9 support (see [#228]( https://github.com/GetShopTV/swagger2/pull/228 ));+- More GHC-8.10 related cleanup, tighten lower bound on some dependencies.+  (see [#216]( https://github.com/GetShopTV/swagger2/pull/216 ));+- Add "format" field for uint32 and uint64+  (see [#215]( https://github.com/GetShopTV/swagger2/pull/215 ));++2.6+---++- GHC 8.10 support (see [#210]( https://github.com/GetShopTV/swagger2/pull/210 ));+- Move `aeson-pretty` to other dependencies (see [#206]( https://github.com/GetShopTV/swagger2/pull/206 ));+- Merge OAuth2 scopes (see [#151]( https://github.com/GetShopTV/swagger2/pull/151 ));++2.5+---++Highlights:+- Add instance for `TimeOfDay` (see [#196]( https://github.com/GetShopTV/swagger2/pull/196 ));+- Add support for [`optics`](https://hackage.haskell.org/package/optics) (see [#200]( https://github.com/GetShopTV/swagger2/pull/200 ));+- Slightly better validation errors (see [#195]( https://github.com/GetShopTV/swagger2/pull/195 ));++Fixes and minor changes:+- Minor cleanup (see [#194]( https://github.com/GetShopTV/swagger2/pull/194 ));+- Allow base-4.13 and other GHC-8.8 related stuff (see [#198]( https://github.com/GetShopTV/swagger2/pull/198 ));+- Fix `stack.yaml` (see [#201]( https://github.com/GetShopTV/swagger2/pull/201 ));+ 2.4 --- 

@@ -1,8 +0,0 @@-#if __GLASGOW_HASKELL__ >= 710-#define OVERLAPPABLE_ {-# OVERLAPPABLE #-}-#define OVERLAPPING_  {-# OVERLAPPING #-}-#else-{-# LANGUAGE OverlappingInstances #-}-#define OVERLAPPABLE_-#define OVERLAPPING_-#endif

@@ -0,0 +1,442 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+-- |+-- 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 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

@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} -- | -- Module:      Data.Swagger -- Maintainer:  Nickolay Kudasov <nickolay@getshoptv.com>@@ -31,6 +30,7 @@    -- * Re-exports   module Data.Swagger.Lens,+  module Data.Swagger.Optics,   module Data.Swagger.Operation,   module Data.Swagger.ParamSchema,   module Data.Swagger.Schema,@@ -88,6 +88,7 @@   SecurityScheme(..),   SecuritySchemeType(..),   SecurityRequirement(..),+  SecurityDefinitions(..),    -- *** API key   ApiKeyParams(..),@@ -112,6 +113,7 @@ ) where  import Data.Swagger.Lens+import Data.Swagger.Optics () import Data.Swagger.Operation import Data.Swagger.ParamSchema import Data.Swagger.Schema@@ -122,12 +124,12 @@ -- $setup -- >>> import Control.Lens -- >>> import Data.Aeson+-- >>> import qualified Data.HashMap.Strict.InsOrd.Compat as IOHM -- >>> import Data.Monoid -- >>> import Data.Proxy -- >>> import GHC.Generics -- >>> :set -XDeriveGeneric -- >>> :set -XOverloadedStrings--- >>> :set -XOverloadedLists -- >>> :set -fno-warn-missing-methods  -- $howto@@ -142,7 +144,7 @@ -- In this library you can use @'mempty'@ for a default/empty value. For instance: -- -- >>> encode (mempty :: Swagger)--- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"}}"+-- "{\"swagger\":\"2.0\",\"info\":{\"title\":\"\",\"version\":\"\"}}" -- -- As you can see some spec properties (e.g. @"version"@) are there even when the spec is empty. -- That is because these properties are actually required ones.@@ -151,12 +153,12 @@ -- although it is not strictly necessary: -- -- >>> encode mempty { _infoTitle = "Todo API", _infoVersion = "1.0" }--- "{\"version\":\"1.0\",\"title\":\"Todo API\"}"+-- "{\"title\":\"Todo API\",\"version\":\"1.0\"}" -- -- You can merge two values using @'mappend'@ or its infix version @('<>')@: -- -- >>> encode $ mempty { _infoTitle = "Todo API" } <> mempty { _infoVersion = "1.0" }--- "{\"version\":\"1.0\",\"title\":\"Todo API\"}"+-- "{\"title\":\"Todo API\",\"version\":\"1.0\"}" -- -- This can be useful for combining specifications of endpoints into a whole API specification: --@@ -175,20 +177,22 @@  -- $lens --+-- Note: if you're working with the <https://hackage.haskell.org/package/optics optics> library, take a look at "Data.Swagger.Optics".+-- -- Since @'Swagger'@ has a fairly complex structure, lenses and prisms are used -- to work comfortably with it. In combination with @'Monoid'@ instances, lenses -- make it fairly simple to construct/modify any part of the specification: -- -- >>> :{ -- encode $ (mempty :: Swagger)---   & definitions .~ [ ("User", mempty & type_ ?~ SwaggerString) ]---   & paths .~+--   & definitions .~ IOHM.fromList [ ("User", mempty & type_ ?~ SwaggerString) ]+--   & paths .~ IOHM.fromList --     [ ("/user", mempty & get ?~ (mempty --         & produces ?~ MimeList ["application/json"] --         & at 200 ?~ ("OK" & _Inline.schema ?~ Ref (Reference "User")) --         & at 404 ?~ "User info not found")) ] -- :}--- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"paths\":{\"/user\":{\"get\":{\"produces\":[\"application/json\"],\"responses\":{\"404\":{\"description\":\"User info not found\"},\"200\":{\"schema\":{\"$ref\":\"#/definitions/User\"},\"description\":\"OK\"}}}}},\"definitions\":{\"User\":{\"type\":\"string\"}}}"+-- "{\"swagger\":\"2.0\",\"info\":{\"title\":\"\",\"version\":\"\"},\"paths\":{\"/user\":{\"get\":{\"produces\":[\"application/json\"],\"responses\":{\"200\":{\"description\":\"OK\",\"schema\":{\"$ref\":\"#/definitions/User\"}},\"404\":{\"description\":\"User info not found\"}}}}},\"definitions\":{\"User\":{\"type\":\"string\"}}}" -- -- In the snippet above we declare an API with a single path @/user@. This path provides method @GET@ -- which produces @application/json@ output. It should respond with code @200@ and body specified@@ -275,7 +279,7 @@ -- >>> encode $ toSchema (Proxy :: Proxy Person) -- "{\"required\":[\"name\",\"age\"],\"properties\":{\"name\":{\"type\":\"string\"},\"age\":{\"type\":\"integer\"}},\"type\":\"object\"}" ----- Please note that not all valid Haskell data types will have a proper swagger schema. For example while we can derive a +-- Please note that not all valid Haskell data types will have a proper swagger schema. For example while we can derive a -- schema for basic enums like -- -- >>> data SampleEnum = ChoiceOne | ChoiceTwo deriving Generic@@ -290,38 +294,16 @@ -- -- we can not derive a valid schema for a mix of the above. The following will result in a type error ---#if __GLASGOW_HASKELL__ < 800 -- >>> data BadMixedType = ChoiceBool Bool | JustTag deriving Generic -- >>> instance ToSchema BadMixedType -- ...--- ... error:--- ... • No instance for (Data.Swagger.Internal.TypeShape.CannotDeriveSchemaForMixedSumType--- ...                      BadMixedType)--- ...     arising from a use of ‘Data.Swagger.Internal.Schema.$dmdeclareNamedSchema’--- ... • In the expression:--- ...     Data.Swagger.Internal.Schema.$dmdeclareNamedSchema @BadMixedType--- ...   In an equation for ‘declareNamedSchema’:--- ...       declareNamedSchema--- ...         = Data.Swagger.Internal.Schema.$dmdeclareNamedSchema @BadMixedType--- ...   In the instance declaration for ‘ToSchema BadMixedType’-#else--- >>> data BadMixedType = ChoiceBool Bool | JustTag deriving Generic--- >>> instance ToSchema BadMixedType--- ...--- ... error: -- ... • Cannot derive Generic-based Swagger Schema for BadMixedType -- ...   BadMixedType is a mixed sum type (has both unit and non-unit constructors). -- ...   Swagger does not have a good representation for these types. -- ...   Use genericDeclareNamedSchemaUnrestricted if you want to derive schema -- ...   that matches aeson's Generic-based toJSON, -- ...   but that's not supported by some Swagger tools.--- ... • In the expression:--- ...     Data.Swagger.Internal.Schema.$dmdeclareNamedSchema @BadMixedType--- ...   In an equation for ‘declareNamedSchema’:--- ...       declareNamedSchema--- ...         = Data.Swagger.Internal.Schema.$dmdeclareNamedSchema @BadMixedType--- ...   In the instance declaration for ‘ToSchema BadMixedType’-#endif+-- ... -- -- We can use 'genericDeclareNamedSchemaUnrestricted' to try our best to represent this type as a Swagger Schema and match 'ToJSON': --

@@ -16,7 +16,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)@@ -60,7 +59,7 @@     return (mappend d' d'', y)  instance Monoid d => MonadTrans (DeclareT d) where-  lift m = DeclareT (\_ -> (,) mempty `liftM` m)+  lift m = DeclareT (\_ -> (,) mempty <$> m)  -- | -- Definitions of @declare@ and @look@ must satisfy the following laws:@@ -103,12 +102,12 @@ -- | Evaluate @'DeclareT' d m a@ computation, -- ignoring new output @d@. evalDeclareT :: Monad m => DeclareT d m a -> d -> m a-evalDeclareT (DeclareT f) d = snd `liftM` f d+evalDeclareT (DeclareT f) d = snd <$> f d  -- | Execute @'DeclateT' d m a@ computation, -- ignoring result and only producing new output @d@. execDeclareT :: Monad m => DeclareT d m a -> d -> m d-execDeclareT (DeclareT f) d = fst `liftM` f d+execDeclareT (DeclareT f) d = fst <$> f d  -- | Evaluate @'DeclareT' d m a@ computation, -- starting with empty output history.@@ -159,10 +158,6 @@   look = lift look  instance MonadDeclare d m => MonadDeclare d (IdentityT m) where-  declare = lift . declare-  look = lift look--instance MonadDeclare d m => MonadDeclare d (ListT m) where   declare = lift . declare   look = lift look 

@@ -1,5 +1,5 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-}+{-# LANGUAGE PolyKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-}@@ -13,12 +13,9 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-}-#if __GLASGOW_HASKELL__ <710-{-# LANGUAGE PolyKinds #-}-#endif-#include "overlapping-compat.h" module Data.Swagger.Internal where  import Prelude ()@@ -28,12 +25,14 @@ import           Control.Applicative import           Data.Aeson import qualified Data.Aeson.Types         as JSON+import           Data.Bifunctor           (first) import           Data.Data                (Data(..), Typeable, mkConstr, mkDataType, Fixity(..), Constr, DataType, constrIndex) import           Data.Hashable            (Hashable) import qualified Data.HashMap.Strict      as HashMap import           Data.HashSet.InsOrd      (InsOrdHashSet) import           Data.Map                 (Map) import qualified Data.Map                 as Map+import           Data.Maybe               (mapMaybe) import           Data.Monoid              (Monoid (..)) import           Data.Semigroup.Compat    (Semigroup (..)) import           Data.Scientific          (Scientific)@@ -45,8 +44,10 @@ import           Network.HTTP.Media       (MediaType) 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 qualified Data.Aeson.Key             as K+import qualified Data.Aeson.KeyMap          as KM  import Generics.SOP.TH                  (deriveGeneric) import Data.Swagger.Internal.AesonUtils (sopSwaggerGenericToJSON@@ -58,13 +59,7 @@                                         ,saoAdditionalPairs                                         ,saoSubObject) import Data.Swagger.Internal.Utils--#if MIN_VERSION_aeson(0,10,0) import Data.Swagger.Internal.AesonUtils (sopSwaggerGenericToEncoding)-#define DEFINE_TOENCODING toEncoding = sopSwaggerGenericToEncoding-#else-#define DEFINE_TOENCODING-#endif  -- $setup -- >>> :seti -XDataKinds@@ -117,7 +112,7 @@   , _swaggerResponses :: Definitions Response      -- | Security scheme definitions that can be used across the specification.-  , _swaggerSecurityDefinitions :: Definitions SecurityScheme+  , _swaggerSecurityDefinitions :: SecurityDefinitions      -- | A declaration of which security schemes are applied for the API as a whole.     -- The list of values describes alternative security schemes that can be used@@ -306,6 +301,10 @@     -- This definition overrides any declared top-level security.     -- To remove a top-level security declaration, @Just []@ can be used.   , _operationSecurity :: [SecurityRequirement]++    -- | Extensions to the Swagger schema's operations. These automatically get+    -- the @x-@ prefix required by the swagger specification.+  , _operationExtensions :: InsOrdHashMap Text Value   } deriving (Eq, Show, Generic, Data, Typeable)  newtype MimeList = MimeList { getMimeList :: [MediaType] }@@ -373,7 +372,7 @@ -- @'SwaggerItemsObject'@ should be used to specify homogenous array @'Schema'@s. -- -- @'SwaggerItemsArray'@ should be used to specify tuple @'Schema'@s.-data SwaggerItems t where+data SwaggerItems (t :: SwaggerKind *) where   SwaggerItemsPrimitive :: Maybe (CollectionFormat k) -> ParamSchema k-> SwaggerItems k   SwaggerItemsObject    :: Referenced Schema   -> SwaggerItems 'SwaggerKindSchema   SwaggerItemsArray     :: [Referenced Schema] -> SwaggerItems 'SwaggerKindSchema@@ -381,7 +380,6 @@  deriving instance Eq (SwaggerItems t) deriving instance Show (SwaggerItems t)---deriving instance Typeable (SwaggerItems t)  swaggerItemsPrimitiveConstr :: Constr swaggerItemsPrimitiveConstr = mkConstr swaggerItemsDataType "SwaggerItemsPrimitive" [] Prefix@@ -416,7 +414,7 @@   dataTypeOf _ = swaggerItemsDataType  instance Data (SwaggerItems 'SwaggerKindSchema) where-  gfoldl _ _ (SwaggerItemsPrimitive _ _) = error $ " Data.Data.gfoldl: Constructor SwaggerItemsPrimitive used to construct SwaggerItems SwaggerKindSchema"+  gfoldl _ _ (SwaggerItemsPrimitive _ _) = error " Data.Data.gfoldl: Constructor SwaggerItemsPrimitive used to construct SwaggerItems SwaggerKindSchema"   gfoldl k z (SwaggerItemsObject ref)    = z SwaggerItemsObject `k` ref   gfoldl k z (SwaggerItemsArray ref)     = z SwaggerItemsArray `k` ref @@ -432,22 +430,17 @@   dataTypeOf _ = swaggerItemsDataType  -- | Type used as a kind to avoid overlapping instances.-data SwaggerKind t+data SwaggerKind (t :: *)     = SwaggerKindNormal t     | SwaggerKindParamOtherSchema     | SwaggerKindSchema-    deriving (Typeable) -deriving instance Typeable 'SwaggerKindNormal-deriving instance Typeable 'SwaggerKindParamOtherSchema-deriving instance Typeable 'SwaggerKindSchema- type family SwaggerKindType (k :: SwaggerKind *) :: * type instance SwaggerKindType ('SwaggerKindNormal t) = t type instance SwaggerKindType 'SwaggerKindSchema = Schema type instance SwaggerKindType 'SwaggerKindParamOtherSchema = ParamOtherSchema -data SwaggerType t where+data SwaggerType (t :: SwaggerKind *) where   SwaggerString   :: SwaggerType t   SwaggerNumber   :: SwaggerType t   SwaggerInteger  :: SwaggerType t@@ -518,7 +511,7 @@ type Format = Text  -- | Determines the format of the array.-data CollectionFormat t where+data CollectionFormat (t :: SwaggerKind *) where   -- Comma separated values: @foo,bar@.   CollectionCSV :: CollectionFormat t   -- Space separated values: @foo bar@.@@ -755,6 +748,22 @@   , _securitySchemeDescription :: Maybe Text   } deriving (Eq, Show, Generic, Data, Typeable) ++-- | merge scopes of two OAuth2 security schemes when their flows are identical.+-- In other case returns first security scheme+mergeSecurityScheme :: SecurityScheme -> SecurityScheme -> SecurityScheme+mergeSecurityScheme s1@(SecurityScheme (SecuritySchemeOAuth2 (OAuth2Params flow1 scopes1)) desc)+                    s2@(SecurityScheme (SecuritySchemeOAuth2 (OAuth2Params flow2 scopes2)) _)+  = if flow1 == flow2 then+      SecurityScheme (SecuritySchemeOAuth2 (OAuth2Params flow1 (scopes1 <> scopes2))) desc+    else+      s1+mergeSecurityScheme s1 _ = s1++newtype SecurityDefinitions+  = SecurityDefinitions (Definitions SecurityScheme)+  deriving (Eq, Show, Generic, Data, Typeable)+ -- | Lists the required security schemes to execute this operation. -- The object can have multiple security schemes declared in it which are all required -- (that is, there is a logical AND between the schemes).@@ -816,6 +825,23 @@   | AdditionalPropertiesSchema (Referenced Schema)   deriving (Eq, Show, Data, Typeable) +-------------------------------------------------------------------------------+-- Generic instances+-------------------------------------------------------------------------------++deriveGeneric ''Header+deriveGeneric ''OAuth2Params+deriveGeneric ''Operation+deriveGeneric ''Param+deriveGeneric ''ParamOtherSchema+deriveGeneric ''PathItem+deriveGeneric ''Response+deriveGeneric ''Responses+deriveGeneric ''SecurityScheme+deriveGeneric ''Schema+deriveGeneric ''ParamSchema+deriveGeneric ''Swagger+ -- ======================================================================= -- Monoid instances -- =======================================================================@@ -904,6 +930,17 @@   mempty = genericMempty   mappend = (<>) +instance Semigroup SecurityScheme where+  (<>) = mergeSecurityScheme++instance Semigroup SecurityDefinitions where+  (SecurityDefinitions sd1) <> (SecurityDefinitions sd2) =+     SecurityDefinitions $ InsOrdHashMap.unionWith (<>) sd1 sd2++instance Monoid SecurityDefinitions where+  mempty = SecurityDefinitions InsOrdHashMap.empty+  mappend = (<>)+ -- ======================================================================= -- SwaggerMonoid helper instances -- =======================================================================@@ -918,6 +955,7 @@ instance SwaggerMonoid Response instance SwaggerMonoid ExternalDocs instance SwaggerMonoid Operation+instance SwaggerMonoid SecurityDefinitions instance (Eq a, Hashable a) => SwaggerMonoid (InsOrdHashSet a)  instance SwaggerMonoid MimeList@@ -931,7 +969,7 @@   swaggerMempty = ParamQuery   swaggerMappend _ y = y -instance OVERLAPPING_ SwaggerMonoid (InsOrdHashMap FilePath PathItem) where+instance {-# OVERLAPPING #-} SwaggerMonoid (InsOrdHashMap FilePath PathItem) where   swaggerMempty = InsOrdHashMap.empty   swaggerMappend = InsOrdHashMap.unionWith mappend @@ -1032,7 +1070,7 @@  instance ToJSON OAuth2Params where   toJSON = sopSwaggerGenericToJSON-  DEFINE_TOENCODING+  toEncoding = sopSwaggerGenericToEncoding  instance ToJSON SecuritySchemeType where   toJSON SecuritySchemeBasic@@ -1045,20 +1083,23 @@     <+> object [ "type" .= ("oauth2" :: Text) ]  instance ToJSON Swagger where-  toJSON = sopSwaggerGenericToJSON-  DEFINE_TOENCODING+  toJSON a = sopSwaggerGenericToJSON a &+    if InsOrdHashMap.null (_swaggerPaths a)+    then (<+> object ["paths" .= object []])+    else id+  toEncoding = sopSwaggerGenericToEncoding  instance ToJSON SecurityScheme where   toJSON = sopSwaggerGenericToJSON-  DEFINE_TOENCODING+  toEncoding = sopSwaggerGenericToEncoding  instance ToJSON Schema where   toJSON = sopSwaggerGenericToJSON-  DEFINE_TOENCODING+  toEncoding = sopSwaggerGenericToEncoding  instance ToJSON Header where   toJSON = sopSwaggerGenericToJSON-  DEFINE_TOENCODING+  toEncoding = sopSwaggerGenericToEncoding  -- | As for nullary schema for 0-arity type constructors, see -- <https://github.com/GetShopTV/swagger2/issues/167>.@@ -1089,7 +1130,7 @@  instance ToJSON Param where   toJSON = sopSwaggerGenericToJSON-  DEFINE_TOENCODING+  toEncoding = sopSwaggerGenericToEncoding  instance ToJSON ParamAnySchema where   toJSON (ParamBody s) = object [ "in" .= ("body" :: Text), "schema" .= s ]@@ -1097,27 +1138,34 @@  instance ToJSON ParamOtherSchema where   toJSON = sopSwaggerGenericToJSON-  DEFINE_TOENCODING+  toEncoding = sopSwaggerGenericToEncoding  instance ToJSON Responses where   toJSON = sopSwaggerGenericToJSON-  DEFINE_TOENCODING+  toEncoding = sopSwaggerGenericToEncoding  instance ToJSON Response where   toJSON = sopSwaggerGenericToJSON-  DEFINE_TOENCODING+  toEncoding = sopSwaggerGenericToEncoding  instance ToJSON Operation where-  toJSON = sopSwaggerGenericToJSON-  DEFINE_TOENCODING+  toJSON t =+    case sopSwaggerGenericToJSON t of+      Object obj -> Object $ obj+        & KM.delete "extensions"+        & KM.union (KM.fromList $ fmap (first $ K.fromText . mappend "x-") $ InsOrdHashMap.toList $ _operationExtensions t)+      _ -> error "impossible: bug in generic ToJSON for Operation"  instance ToJSON PathItem where   toJSON = sopSwaggerGenericToJSON-  DEFINE_TOENCODING+  toEncoding = sopSwaggerGenericToEncoding  instance ToJSON Example where   toJSON = toJSON . Map.mapKeys show . getExample +instance ToJSON SecurityDefinitions where+  toJSON (SecurityDefinitions sd) = toJSON sd+ instance ToJSON Reference where   toJSON (Reference ref) = object [ "$ref" .= ref ] @@ -1262,7 +1310,7 @@ instance FromJSON Responses where   parseJSON (Object o) = Responses     <$> o .:? "default"-    <*> (parseJSON (Object (HashMap.delete "default" o)))+    <*> parseJSON (Object (KM.delete "default" o))   parseJSON _ = empty  instance FromJSON Example where@@ -1274,11 +1322,29 @@   parseJSON = sopSwaggerGenericParseJSON  instance FromJSON Operation where-  parseJSON = sopSwaggerGenericParseJSON+  parseJSON v = do+    x <- sopSwaggerGenericParseJSON @Operation v+    flip (withObject "operation") v $ \obj -> pure $ x+      { _operationExtensions+          = InsOrdHashMap.fromList+          $ mapMaybe getExtension+          $ fmap (first $ K.toText)+          $ KM.toList obj+      }+    where+      getExtension :: (Text, Value) -> Maybe (Text, Value)+      getExtension (prop, val)+        | Text.isPrefixOf "x-" prop || Text.isPrefixOf "X-" prop+            = Just (Text.drop 2 prop, val)+        | otherwise = Nothing + instance FromJSON PathItem where   parseJSON = sopSwaggerGenericParseJSON +instance FromJSON SecurityDefinitions where+  parseJSON js = SecurityDefinitions <$> parseJSON js+ instance FromJSON Reference where   parseJSON (Object o) = Reference <$> o .: "$ref"   parseJSON _ = empty@@ -1333,23 +1399,6 @@   parseJSON (Bool b) = pure $ AdditionalPropertiesAllowed b   parseJSON js = AdditionalPropertiesSchema <$> parseJSON js ----------------------------------------------------------------------------------- TH splices----------------------------------------------------------------------------------deriveGeneric ''Header-deriveGeneric ''OAuth2Params-deriveGeneric ''Operation-deriveGeneric ''Param-deriveGeneric ''ParamOtherSchema-deriveGeneric ''PathItem-deriveGeneric ''Response-deriveGeneric ''Responses-deriveGeneric ''SecurityScheme-deriveGeneric ''Schema-deriveGeneric ''ParamSchema-deriveGeneric ''Swagger- instance HasSwaggerAesonOptions Header where   swaggerAesonOptions _ = mkSwaggerAesonOptions "header" & saoSubObject ?~ "paramSchema" instance HasSwaggerAesonOptions OAuth2Params where@@ -1390,3 +1439,4 @@ instance AesonDefaultValue MimeList where defaultValue = Just mempty instance AesonDefaultValue Info instance AesonDefaultValue ParamLocation+instance AesonDefaultValue SecurityDefinitions where defaultValue = Just $ SecurityDefinitions mempty

@@ -1,20 +1,15 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE TemplateHaskell #-}-#if __GLASGOW_HASKELL__ >= 800 {-# LANGUAGE UndecidableSuperClasses #-}-#endif module Data.Swagger.Internal.AesonUtils (     -- * Generic functions     AesonDefaultValue(..),     sopSwaggerGenericToJSON,-#if MIN_VERSION_aeson(0,10,0)     sopSwaggerGenericToEncoding,-#endif     sopSwaggerGenericToJSONWithOpts,     sopSwaggerGenericParseJSON,     -- * Options@@ -30,10 +25,17 @@ import Prelude.Compat  import Control.Applicative ((<|>))-import Control.Lens     (makeLenses, (^.))-import Control.Monad    (unless)-import Data.Aeson       (ToJSON(..), FromJSON(..), Value(..), Object, object, (.:), (.:?), (.!=), withObject)+import Control.Lens        (makeLenses, (^.))+import Control.Monad       (unless)+import Data.Aeson          ( Encoding, FromJSON (..), ToJSON (..)+                           , Object, Series, Value (..)+                           , object, pairs, withObject+                           , (.!=), (.:), (.:?), (.=)+                           )+import Data.Aeson.Key   (fromString, toString, fromText, toText)+import qualified Data.Aeson.KeyMap as KM import Data.Aeson.Types (Parser, Pair)+import Data.Bifunctor   (first) import Data.Char        (toLower, isUpper) import Data.Foldable    (traverse_) import Data.Text        (Text)@@ -43,13 +45,9 @@ 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 -#if MIN_VERSION_aeson(0,10,0)-import Data.Aeson (Encoding, pairs, (.=), Series)-#endif- ------------------------------------------------------------------------------- -- SwaggerAesonOptions -------------------------------------------------------------------------------@@ -112,7 +110,7 @@     -> Value sopSwaggerGenericToJSON x =     let ps = sopSwaggerGenericToJSON' opts (from x) (datatypeInfo proxy) (aesonDefaults proxy)-    in object (opts ^. saoAdditionalPairs ++ ps)+    in object $ (map $ first fromText) (opts ^. saoAdditionalPairs ++ (map $ first toText) ps)   where     proxy = Proxy :: Proxy a     opts  = swaggerAesonOptions proxy@@ -134,7 +132,7 @@     -> Value sopSwaggerGenericToJSONWithOpts opts x =     let ps = sopSwaggerGenericToJSON' opts (from x) (datatypeInfo proxy) defs-    in object (opts ^. saoAdditionalPairs ++ ps)+    in object $ (map $ first fromText) (opts ^. saoAdditionalPairs ++ (map $ first toText) ps)   where     proxy = Proxy :: Proxy a     defs = hcpure (Proxy :: Proxy AesonDefaultValue) defaultValue@@ -146,11 +144,7 @@     -> DatatypeInfo '[xs]     -> POP Maybe '[xs]     -> [Pair]-#if MIN_VERSION_generics_sop(0,5,0) sopSwaggerGenericToJSON' opts (SOP (Z fields)) (ADT _ _ (Record _ fieldsInfo :* Nil) _) (POP (defs :* Nil)) =-#else-sopSwaggerGenericToJSON' opts (SOP (Z fields)) (ADT _ _ (Record _ fieldsInfo :* Nil)) (POP (defs :* Nil)) =-#endif     sopSwaggerGenericToJSON'' opts fields fieldsInfo defs sopSwaggerGenericToJSON' _ _ _ _ = error "sopSwaggerGenericToJSON: unsupported type" @@ -167,21 +161,18 @@     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 -> KM.toList 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+            (fromString name', json) : rest       where         json  = toJSON x         name' = fieldNameModifier name         rest  = go xs names defs-#if __GLASGOW_HASKELL__ < 800-    go _ _ _ = error "not empty"-#endif      fieldNameModifier = modifier . drop 1     modifier = lowerFirstUppers . drop (length prefix)@@ -213,7 +204,7 @@      parseAdditionalField :: Object -> (Text, Value) -> Parser ()     parseAdditionalField obj (k, v) = do-        v' <- obj .: k+        v' <- obj .: fromText k         unless (v == v') $ fail $             "Additonal field don't match for key " ++ T.unpack k             ++ ": " ++ show v@@ -226,11 +217,7 @@     -> DatatypeInfo '[xs]     -> POP Maybe '[xs]     -> Parser (SOP I '[xs])-#if MIN_VERSION_generics_sop(0,5,0) sopSwaggerGenericParseJSON' opts obj (ADT _ _ (Record _ fieldsInfo :* Nil) _) (POP (defs :* Nil)) =-#else-sopSwaggerGenericParseJSON' opts obj (ADT _ _ (Record _ fieldsInfo :* Nil)) (POP (defs :* Nil)) =-#endif     SOP . Z <$> sopSwaggerGenericParseJSON'' opts obj fieldsInfo defs sopSwaggerGenericParseJSON' _ _ _ _ = error "sopSwaggerGenericParseJSON: unsupported type" @@ -248,10 +235,10 @@     go (FieldInfo name :* names) (def :* defs)         | Just name' == sub =             -- Note: we might strip fields of outer structure.-            cons <$> (withDef $ parseJSON $ Object obj) <*> rest+            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 .:? fromString name' .!= def' <*> rest+            Nothing   -> cons <$> obj .:  fromString name' <*> rest       where         cons h t = I h :* t         name' = fieldNameModifier name@@ -260,9 +247,6 @@         withDef = case def of             Just def' -> (<|> pure def')             Nothing   -> id-#if __GLASGOW_HASKELL__ < 800-    go _ _ = error "not empty"-#endif      fieldNameModifier = modifier . drop 1     modifier = lowerFirstUppers . drop (length prefix)@@ -273,8 +257,6 @@ -- ToEncoding ------------------------------------------------------------------------------- -#if MIN_VERSION_aeson(0,10,0)- sopSwaggerGenericToEncoding     :: forall a xs.         ( HasDatatypeInfo a@@ -287,7 +269,7 @@     -> Encoding sopSwaggerGenericToEncoding x =     let ps = sopSwaggerGenericToEncoding' opts (from x) (datatypeInfo proxy) (aesonDefaults proxy)-    in pairs (pairsToSeries (opts ^. saoAdditionalPairs) <> ps)+    in pairs (pairsToSeries ((map $ first fromText) (opts ^. saoAdditionalPairs)) <> ps)   where     proxy = Proxy :: Proxy a     opts  = swaggerAesonOptions proxy@@ -302,11 +284,7 @@     -> DatatypeInfo '[xs]     -> POP Maybe '[xs]     -> Series-#if MIN_VERSION_generics_sop(0,5,0) sopSwaggerGenericToEncoding' opts (SOP (Z fields)) (ADT _ _ (Record _ fieldsInfo :* Nil) _) (POP (defs :* Nil)) =-#else-sopSwaggerGenericToEncoding' opts (SOP (Z fields)) (ADT _ _ (Record _ fieldsInfo :* Nil)) (POP (defs :* Nil)) =-#endif     sopSwaggerGenericToEncoding'' opts fields fieldsInfo defs sopSwaggerGenericToEncoding' _ _ _ _ = error "sopSwaggerGenericToEncoding: unsupported type" @@ -323,24 +301,19 @@     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 (KM.toList 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+            (fromString name' .= x) <> rest       where         name' = fieldNameModifier name         rest  = go xs names defs-#if __GLASGOW_HASKELL__ < 800-    go _ _ _ = error "not empty"-#endif      fieldNameModifier = modifier . drop 1     modifier = lowerFirstUppers . drop (length prefix)     lowerFirstUppers s = map toLower x ++ y       where (x, y) = span isUpper s--#endif

@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-}@@ -12,13 +11,10 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE UndecidableInstances #-}-#if __GLASGOW_HASKELL__ >= 800 -- Generic a is redundant in  ToParamSchema a default imple {-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For TypeErrors {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}-#endif-#include "overlapping-compat.h" module Data.Swagger.Internal.ParamSchema where  import Control.Lens@@ -49,12 +45,9 @@ import Data.Swagger.Lens import Data.Swagger.SchemaOptions -#if __GLASGOW_HASKELL__ < 800-#else import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL import GHC.TypeLits (TypeError, ErrorMessage(..))-#endif  -- | Default schema for binary data (any sequence of octets). binaryParamSchema :: ParamSchema t@@ -119,7 +112,7 @@   default toParamSchema :: (Generic a, GToParamSchema (Rep a)) => Proxy a -> ParamSchema t   toParamSchema = genericToParamSchema defaultSchemaOptions -instance OVERLAPPING_ ToParamSchema String where+instance {-# OVERLAPPING #-} ToParamSchema String where   toParamSchema _ = mempty & type_ ?~ SwaggerString  instance ToParamSchema Bool where@@ -147,9 +140,13 @@ instance ToParamSchema Word   where toParamSchema = toParamSchemaBoundedIntegral instance ToParamSchema Word8  where toParamSchema = toParamSchemaBoundedIntegral instance ToParamSchema Word16 where toParamSchema = toParamSchemaBoundedIntegral-instance ToParamSchema Word32 where toParamSchema = toParamSchemaBoundedIntegral-instance ToParamSchema Word64 where toParamSchema = toParamSchemaBoundedIntegral +instance ToParamSchema Word32 where+  toParamSchema proxy = toParamSchemaBoundedIntegral proxy & format ?~ "int32"++instance ToParamSchema Word64 where+  toParamSchema proxy = toParamSchemaBoundedIntegral proxy & format ?~ "int64"+ -- | Default plain schema for @'Bounded'@, @'Integral'@ types. -- -- >>> encode $ toParamSchemaBoundedIntegral (Proxy :: Proxy Int8)@@ -194,6 +191,12 @@   toParamSchema _ = timeParamSchema "date"  -- |+-- >>> toParamSchema (Proxy :: Proxy TimeOfDay) ^. format+-- Just "hh:MM:ss"+instance ToParamSchema TimeOfDay where+  toParamSchema _ = timeParamSchema "hh:MM:ss"++-- | -- >>> toParamSchema (Proxy :: Proxy LocalTime) ^. format -- Just "yyyy-mm-ddThh:MM:ss" instance ToParamSchema LocalTime where@@ -229,9 +232,6 @@   toParamSchema _ = mempty     & type_ ?~ SwaggerString --#if __GLASGOW_HASKELL__ < 800-#else type family ToParamSchemaByteStringError bs where   ToParamSchemaByteStringError bs = TypeError       ( 'Text "Impossible to have an instance " :<>: ShowType (ToParamSchema bs) :<>: Text "."@@ -240,7 +240,6 @@  instance ToParamSchemaByteStringError BS.ByteString  => ToParamSchema BS.ByteString  where toParamSchema = error "impossible" instance ToParamSchemaByteStringError BSL.ByteString => ToParamSchema BSL.ByteString where toParamSchema = error "impossible"-#endif  instance ToParamSchema All where toParamSchema _ = toParamSchema (Proxy :: Proxy Bool) instance ToParamSchema Any where toParamSchema _ = toParamSchema (Proxy :: Proxy Bool)@@ -271,7 +270,7 @@  -- | -- >>> encode $ toParamSchema (Proxy :: Proxy ())--- "{\"type\":\"string\",\"enum\":[\"_\"]}"+-- "{\"enum\":[\"_\"],\"type\":\"string\"}" instance ToParamSchema () where   toParamSchema _ = mempty     & type_ ?~ SwaggerString@@ -287,7 +286,7 @@ -- >>> :set -XDeriveGeneric -- >>> data Color = Red | Blue deriving Generic -- >>> encode $ genericToParamSchema defaultSchemaOptions (Proxy :: Proxy Color)--- "{\"type\":\"string\",\"enum\":[\"Red\",\"Blue\"]}"+-- "{\"enum\":[\"Red\",\"Blue\"],\"type\":\"string\"}" genericToParamSchema :: forall a t. (Generic a, GToParamSchema (Rep a)) => SchemaOptions -> Proxy a -> ParamSchema t genericToParamSchema opts _ = gtoParamSchema opts (Proxy :: Proxy (Rep a)) mempty 

@@ -15,13 +15,9 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE UndecidableInstances #-}-#if __GLASGOW_HASKELL__ >= 800--- Few generics related redundant constraints {-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For TypeErrors {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}-#endif-#include "overlapping-compat.h" module Data.Swagger.Internal.Schema where  import Prelude ()@@ -31,7 +27,7 @@ import Data.Data.Lens (template)  import Control.Monad-import Control.Monad.Writer+import Control.Monad.Writer hiding (First, Last) import Data.Aeson (ToJSON (..), ToJSONKey (..), ToJSONKeyFunction (..), Value (..), Object(..)) import Data.Char import Data.Data (Data)@@ -40,16 +36,18 @@ 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)+import qualified Data.List as L import Data.List.NonEmpty.Compat (NonEmpty) import Data.Map (Map) import Data.Proxy 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@@ -71,11 +69,13 @@ import Data.Swagger.SchemaOptions import Data.Swagger.Internal.TypeShape -#if __GLASGOW_HASKELL__ < 800-#else import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL import GHC.TypeLits (TypeError, ErrorMessage(..))+import qualified Data.Aeson.KeyMap as KM+import Data.Aeson.Key (toText)+#if ( __GLASGOW_HASKELL__ > 884 )+import Data.Time (DayOfWeek(Monday, Sunday)) #endif  unnamed :: Schema -> NamedSchema@@ -324,8 +324,13 @@ -- -- >>> data Person = Person { name :: String, age :: Int } deriving (Generic) -- >>> instance ToJSON Person+#if MIN_VERSION_text(2,0,0) -- >>> encode $ sketchSchema (Person "Jack" 25)--- "{\"required\":[\"age\",\"name\"],\"properties\":{\"age\":{\"type\":\"number\"},\"name\":{\"type\":\"string\"}},\"example\":{\"age\":25,\"name\":\"Jack\"},\"type\":\"object\"}"+-- "{\"required\":[\"age\",\"name\"],\"properties\":{\"name\":{\"type\":\"string\"},\"age\":{\"type\":\"number\"}},\"example\":{\"age\":25,\"name\":\"Jack\"},\"type\":\"object\"}"+#else+-- >>> encode $ sketchSchema (Person "Jack" 25)+-- "{\"required\":[\"name\",\"age\"],\"properties\":{\"name\":{\"type\":\"string\"},\"age\":{\"type\":\"number\"}},\"example\":{\"age\":25,\"name\":\"Jack\"},\"type\":\"object\"}"+#endif sketchSchema :: ToJSON a => a -> Schema sketchSchema = sketch . toJSON   where@@ -349,7 +354,7 @@         ischema = case ys of           (z:_) | allSame -> Just z           _               -> Nothing-    go (Object o) = mempty+    go (Object o') = let o = KM.toHashMapText o' in mempty       & type_         ?~ SwaggerObject       & required      .~ HashMap.keys o       & properties    .~ fmap (Inline . go) (InsOrdHashMap.fromHashMap o)@@ -358,18 +363,23 @@ -- Produced schema uses as much constraints as possible. -- -- >>> encode $ sketchStrictSchema "hello"--- "{\"maxLength\":5,\"pattern\":\"hello\",\"minLength\":5,\"type\":\"string\",\"enum\":[\"hello\"]}"+-- "{\"enum\":[\"hello\"],\"maxLength\":5,\"minLength\":5,\"pattern\":\"hello\",\"type\":\"string\"}" -- -- >>> encode $ sketchStrictSchema (1, 2, 3)--- "{\"minItems\":3,\"uniqueItems\":true,\"items\":[{\"maximum\":1,\"minimum\":1,\"multipleOf\":1,\"type\":\"number\",\"enum\":[1]},{\"maximum\":2,\"minimum\":2,\"multipleOf\":2,\"type\":\"number\",\"enum\":[2]},{\"maximum\":3,\"minimum\":3,\"multipleOf\":3,\"type\":\"number\",\"enum\":[3]}],\"maxItems\":3,\"type\":\"array\",\"enum\":[[1,2,3]]}"+-- "{\"enum\":[[1,2,3]],\"items\":[{\"enum\":[1],\"maximum\":1,\"minimum\":1,\"multipleOf\":1,\"type\":\"number\"},{\"enum\":[2],\"maximum\":2,\"minimum\":2,\"multipleOf\":2,\"type\":\"number\"},{\"enum\":[3],\"maximum\":3,\"minimum\":3,\"multipleOf\":3,\"type\":\"number\"}],\"maxItems\":3,\"minItems\":3,\"type\":\"array\",\"uniqueItems\":true}" -- -- >>> encode $ sketchStrictSchema ("Jack", 25)--- "{\"minItems\":2,\"uniqueItems\":true,\"items\":[{\"maxLength\":4,\"pattern\":\"Jack\",\"minLength\":4,\"type\":\"string\",\"enum\":[\"Jack\"]},{\"maximum\":25,\"minimum\":25,\"multipleOf\":25,\"type\":\"number\",\"enum\":[25]}],\"maxItems\":2,\"type\":\"array\",\"enum\":[[\"Jack\",25]]}"+-- "{\"enum\":[[\"Jack\",25]],\"items\":[{\"enum\":[\"Jack\"],\"maxLength\":4,\"minLength\":4,\"pattern\":\"Jack\",\"type\":\"string\"},{\"enum\":[25],\"maximum\":25,\"minimum\":25,\"multipleOf\":25,\"type\":\"number\"}],\"maxItems\":2,\"minItems\":2,\"type\":\"array\",\"uniqueItems\":true}" -- -- >>> data Person = Person { name :: String, age :: Int } deriving (Generic) -- >>> instance ToJSON Person+#if MIN_VERSION_text(2,0,0) -- >>> encode $ sketchStrictSchema (Person "Jack" 25)--- "{\"required\":[\"age\",\"name\"],\"properties\":{\"age\":{\"maximum\":25,\"minimum\":25,\"multipleOf\":25,\"type\":\"number\",\"enum\":[25]},\"name\":{\"maxLength\":4,\"pattern\":\"Jack\",\"minLength\":4,\"type\":\"string\",\"enum\":[\"Jack\"]}},\"maxProperties\":2,\"minProperties\":2,\"type\":\"object\",\"enum\":[{\"age\":25,\"name\":\"Jack\"}]}"+-- "{\"required\":[\"age\",\"name\"],\"properties\":{\"name\":{\"enum\":[\"Jack\"],\"maxLength\":4,\"minLength\":4,\"pattern\":\"Jack\",\"type\":\"string\"},\"age\":{\"enum\":[25],\"maximum\":25,\"minimum\":25,\"multipleOf\":25,\"type\":\"number\"}},\"maxProperties\":2,\"minProperties\":2,\"enum\":[{\"age\":25,\"name\":\"Jack\"}],\"type\":\"object\"}"+#else+-- >>> encode $ sketchStrictSchema (Person "Jack" 25)+-- "{\"required\":[\"name\",\"age\"],\"properties\":{\"name\":{\"enum\":[\"Jack\"],\"maxLength\":4,\"minLength\":4,\"pattern\":\"Jack\",\"type\":\"string\"},\"age\":{\"enum\":[25],\"maximum\":25,\"minimum\":25,\"multipleOf\":25,\"type\":\"number\"}},\"maxProperties\":2,\"minProperties\":2,\"enum\":[{\"age\":25,\"name\":\"Jack\"}],\"type\":\"object\"}"+#endif sketchStrictSchema :: ToJSON a => a -> Schema sketchStrictSchema = go . toJSON   where@@ -399,7 +409,7 @@       where         sz = length xs         allUnique = sz == HashSet.size (HashSet.fromList (V.toList xs))-    go js@(Object o) = mempty+    go js@(Object o') = let o = KM.toHashMapText o' in mempty       & type_         ?~ SwaggerObject       & required      .~ names       & properties    .~ fmap (Inline . go) (InsOrdHashMap.fromHashMap o)@@ -407,19 +417,19 @@       & minProperties ?~ fromIntegral (length names)       & enum_         ?~ [js]       where-        names = HashMap.keys o+        names = HashMap.keys (KM.toHashMapText o')  class GToSchema (f :: * -> *) where   gdeclareNamedSchema :: SchemaOptions -> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema -instance OVERLAPPABLE_ ToSchema a => ToSchema [a] where+instance {-# OVERLAPPABLE #-} ToSchema a => ToSchema [a] where   declareNamedSchema _ = do     ref <- declareSchemaRef (Proxy :: Proxy a)     return $ unnamed $ mempty       & type_ ?~ SwaggerArray       & items ?~ SwaggerItemsObject ref -instance OVERLAPPING_ ToSchema String where declareNamedSchema = plain . paramSchemaToSchema+instance {-# OVERLAPPING #-} ToSchema String where declareNamedSchema = plain . paramSchemaToSchema instance ToSchema Bool    where declareNamedSchema = plain . paramSchemaToSchema instance ToSchema Integer where declareNamedSchema = plain . paramSchemaToSchema instance ToSchema Natural where declareNamedSchema = plain . paramSchemaToSchema@@ -486,6 +496,18 @@   declareNamedSchema _ = pure $ named "ZonedTime" $ timeSchema "date-time"     & example ?~ toJSON (ZonedTime (LocalTime (fromGregorian 2016 7 22) (TimeOfDay 7 40 0)) (hoursToTimeZone 3)) +instance ToSchema TimeOfDay where+  declareNamedSchema _ = pure $ named "TimeOfDay" $ timeSchema "hh:MM:ss"+    & example ?~ toJSON (TimeOfDay 12 33 15)++#if ( __GLASGOW_HASKELL__ > 884 )+instance ToSchema DayOfWeek where+  declareNamedSchema _ = pure $ named "DayOfWeek" $ +    mempty+    & type_ ?~ SwaggerString+    & enum_ ?~ map toJSON [Monday .. Sunday]+#endif+ instance ToSchema NominalDiffTime where   declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy Pico) @@ -501,8 +523,6 @@  instance ToSchema Version where declareNamedSchema = plain . paramSchemaToSchema -#if __GLASGOW_HASKELL__ < 800-#else type family ToSchemaByteStringError bs where   ToSchemaByteStringError bs = TypeError       ( Text "Impossible to have an instance " :<>: ShowType (ToSchema bs) :<>: Text "."@@ -511,7 +531,6 @@  instance ToSchemaByteStringError BS.ByteString  => ToSchema BS.ByteString  where declareNamedSchema = error "impossible" instance ToSchemaByteStringError BSL.ByteString => ToSchema BSL.ByteString where declareNamedSchema = error "impossible"-#endif  instance ToSchema IntSet where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Set Int)) @@ -519,7 +538,6 @@ instance ToSchema a => ToSchema (IntMap a) where   declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [(Int, a)]) -#if MIN_VERSION_aeson(1,0,0) instance (ToJSONKey k, ToSchema k, ToSchema v) => ToSchema (Map k v) where   declareNamedSchema _ = case toJSONKey :: ToJSONKeyFunction k of       ToJSONKeyText  _ _ -> declareObjectMapSchema@@ -534,25 +552,7 @@ instance (ToJSONKey k, ToSchema k, ToSchema v) => ToSchema (HashMap k v) where   declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map k v)) -#else--instance ToSchema a => ToSchema (Map String a) where-  declareNamedSchema _ = do-    schema <- declareSchemaRef (Proxy :: Proxy a)-    return $ unnamed $ mempty-      & type_ ?~ SwaggerObject-      & additionalProperties ?~ schema--instance ToSchema a => ToSchema (Map T.Text  a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map String a))-instance ToSchema a => ToSchema (Map TL.Text a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map String a))--instance ToSchema a => ToSchema (HashMap String  a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map String a))-instance ToSchema a => ToSchema (HashMap T.Text  a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map String a))-instance ToSchema a => ToSchema (HashMap TL.Text a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map String a))--#endif--instance OVERLAPPING_ ToSchema Object where+instance {-# OVERLAPPING #-} ToSchema Object where   declareNamedSchema _ = pure $ NamedSchema (Just "Object") $ mempty     & type_ ?~ SwaggerObject     & description ?~ "Arbitrary JSON object."@@ -639,9 +639,9 @@     objectSchema keyToText = do       valueRef <- declareSchemaRef (Proxy :: Proxy value)       let allKeys   = [minBound..maxBound :: key]-          mkPair k  =  (keyToText k, valueRef)+          mkPair k  = (toText $ keyToText k, valueRef)       return $ mempty-        & type_ ?~ SwaggerObject+        & type_      ?~ SwaggerObject         & properties .~ InsOrdHashMap.fromList (map mkPair allKeys)  -- | A 'Schema' for a mapping with 'Bounded' 'Enum' keys.@@ -698,6 +698,7 @@  gdatatypeSchemaName :: forall d. Datatype d => SchemaOptions -> Proxy d -> Maybe T.Text gdatatypeSchemaName opts _ = case orig of+  dtn   | L.isPrefixOf "Tuple" dtn -> Nothing -- special case for new TupleNNN types in GHC 9.8   (c:_) | isAlpha c && isUpper c -> Just (T.pack name)   _ -> Nothing   where@@ -734,10 +735,10 @@     where       name = gdatatypeSchemaName opts (Proxy :: Proxy d) -instance OVERLAPPABLE_ GToSchema f => GToSchema (C1 c f) where+instance {-# OVERLAPPABLE #-} GToSchema f => GToSchema (C1 c f) where   gdeclareNamedSchema opts _ = gdeclareNamedSchema opts (Proxy :: Proxy f) -instance OVERLAPPING_ Constructor c => GToSchema (C1 c U1) where+instance {-# OVERLAPPING #-} Constructor c => GToSchema (C1 c U1) where   gdeclareNamedSchema = gdeclareNamedSumSchema  -- | Single field constructor.@@ -800,17 +801,17 @@     fname = T.pack (fieldLabelModifier opts (selName (Proxy3 :: Proxy3 s f p)))  -- | Optional record fields.-instance OVERLAPPING_ (Selector s, ToSchema c) => GToSchema (S1 s (K1 i (Maybe c))) where+instance {-# OVERLAPPING #-} (Selector s, ToSchema c) => GToSchema (S1 s (K1 i (Maybe c))) where   gdeclareNamedSchema opts _ = fmap unnamed . withFieldSchema opts (Proxy2 :: Proxy2 s (K1 i (Maybe c))) False  -- | Record fields.-instance OVERLAPPABLE_ (Selector s, GToSchema f) => GToSchema (S1 s f) where+instance {-# OVERLAPPABLE #-} (Selector s, GToSchema f) => GToSchema (S1 s f) where   gdeclareNamedSchema opts _ = fmap unnamed . withFieldSchema opts (Proxy2 :: Proxy2 s f) True -instance OVERLAPPING_ ToSchema c => GToSchema (K1 i (Maybe c)) where+instance {-# OVERLAPPING #-} ToSchema c => GToSchema (K1 i (Maybe c)) where   gdeclareNamedSchema _ _ _ = declareNamedSchema (Proxy :: Proxy c) -instance OVERLAPPABLE_ ToSchema c => GToSchema (K1 i c) where+instance {-# OVERLAPPABLE #-} ToSchema c => GToSchema (K1 i c) where   gdeclareNamedSchema _ _ _ = declareNamedSchema (Proxy :: Proxy c)  instance ( GSumToSchema f@@ -855,7 +856,7 @@   ref <- gdeclareSchemaRef opts proxy   return $ gsumConToSchemaWith ref opts proxy schema -instance OVERLAPPABLE_ (Constructor c, GToSchema f) => GSumToSchema (C1 c f) where+instance {-# OVERLAPPABLE #-} (Constructor c, GToSchema f) => GSumToSchema (C1 c f) where   gsumToSchema opts proxy schema = do     tell (All False)     lift $ gsumConToSchema opts proxy schema

@@ -22,23 +22,27 @@ -- Validate JSON values with Swagger Schema. module Data.Swagger.Internal.Schema.Validation where +import           Prelude                             ()+import           Prelude.Compat+ import           Control.Applicative import           Control.Lens import           Control.Monad                       (when)  import           Data.Aeson                          hiding (Result)+import           Data.Aeson.Encode.Pretty            (encodePretty) import           Data.Foldable                       (for_, sequenceA_,                                                       traverse_) import           Data.HashMap.Strict                 (HashMap) import qualified Data.HashMap.Strict                 as HashMap-import qualified Data.HashMap.Strict.InsOrd          as InsOrdHashMap+import qualified Data.HashMap.Strict.InsOrd.Compat   as InsOrdHashMap import qualified "unordered-containers" Data.HashSet as HashSet-import           Data.List                           (intercalate)-import           Data.Monoid import           Data.Proxy import           Data.Scientific                     (Scientific, isInteger) import           Data.Text                           (Text) import qualified Data.Text                           as Text+import qualified Data.Text.Lazy                      as TL+import qualified Data.Text.Lazy.Encoding             as TL import           Data.Vector                         (Vector) import qualified Data.Vector                         as Vector @@ -46,6 +50,7 @@ import           Data.Swagger.Internal import           Data.Swagger.Internal.Schema import           Data.Swagger.Lens+import qualified Data.Aeson.KeyMap                   as KM  -- | Validate @'ToJSON'@ instance matches @'ToSchema'@ for a given value. -- This can be used with QuickCheck to ensure those instances are coherent:@@ -54,18 +59,101 @@ -- -- /NOTE:/ @'validateToJSON'@ does not perform string pattern validation. -- See @'validateToJSONWithPatternChecker'@.+--+-- See 'renderValidationErrors' on how the output is structured.+validatePrettyToJSON :: forall a. (ToJSON a, ToSchema a) => a -> Maybe String+validatePrettyToJSON = renderValidationErrors validateToJSON++-- | Variant of 'validatePrettyToJSON' with typed output. validateToJSON :: forall a. (ToJSON a, ToSchema a) => a -> [ValidationError] validateToJSON = validateToJSONWithPatternChecker (\_pattern _str -> True)  -- | Validate @'ToJSON'@ instance matches @'ToSchema'@ for a given value and pattern checker. -- This can be used with QuickCheck to ensure those instances are coherent. ----- For validation without patterns see @'validateToJSON'@.+-- For validation without patterns see @'validateToJSON'@.  See also:+-- 'renderValidationErrors'. validateToJSONWithPatternChecker :: forall a. (ToJSON a, ToSchema a) => (Pattern -> Text -> Bool) -> a -> [ValidationError] validateToJSONWithPatternChecker checker = validateJSONWithPatternChecker checker defs sch . toJSON   where     (defs, sch) = runDeclare (declareSchema (Proxy :: Proxy a)) mempty +-- | Pretty print validation errors+-- together with actual JSON and Swagger Schema+-- (using 'encodePretty').+--+-- >>> import Data.Aeson as Aeson+-- >>> import Data.Foldable (traverse_)+-- >>> import GHC.Generics+-- >>> data Phone = Phone { value :: String } deriving (Generic)+-- >>> data Person = Person { name :: String, phone :: Phone } deriving (Generic)+-- >>> instance ToJSON Person where toJSON p = object [ "name" Aeson..= name p ]+-- >>> instance ToSchema Phone+-- >>> instance ToSchema Person+-- >>> let person = Person { name = "John", phone = Phone "123456" }+-- >>> traverse_ putStrLn $ renderValidationErrors validateToJSON person+-- Validation against the schema fails:+--   * property "phone" is required, but not found in "{\"name\":\"John\"}"+-- <BLANKLINE>+-- JSON value:+-- {+--     "name": "John"+-- }+-- <BLANKLINE>+-- Swagger Schema:+-- {+--     "properties": {+--         "name": {+--             "type": "string"+--         },+--         "phone": {+--             "$ref": "#/definitions/Phone"+--         }+--     },+--     "required": [+--         "name",+--         "phone"+--     ],+--     "type": "object"+-- }+-- <BLANKLINE>+-- Swagger Description Context:+-- {+--     "Phone": {+--         "properties": {+--             "value": {+--                 "type": "string"+--             }+--         },+--         "required": [+--             "value"+--         ],+--         "type": "object"+--     }+-- }+-- <BLANKLINE>+renderValidationErrors+  :: forall a. (ToJSON a, ToSchema a)+  => (a -> [ValidationError]) -> a -> Maybe String+renderValidationErrors f x =+  case f x of+    []      -> Nothing+    errors  -> Just $ unlines+      [ "Validation against the schema fails:"+      , unlines (map ("  * " ++) errors)+      , "JSON value:"+      , ppJSONString (toJSON x)+      , ""+      , "Swagger Schema:"+      , ppJSONString (toJSON schema_)+      , ""+      , "Swagger Description Context:"+      , ppJSONString (toJSON refs_)+      ]+  where+    ppJSONString = TL.unpack . TL.decodeUtf8 . encodePretty+    (refs_, schema_) = runDeclare (declareSchema (Proxy :: Proxy a)) mempty+ -- | Validate JSON @'Value'@ against Swagger @'Schema'@. -- -- prop> validateJSON mempty (toSchema (Proxy :: Proxy Int)) (toJSON (x :: Int)) == []@@ -288,7 +376,7 @@ validateObject o = withSchema $ \sch ->   case sch ^. discriminator of     Just pname -> case fromJSON <$> HashMap.lookup pname o of-      Just (Success ref) -> validateWithSchemaRef ref (Object o)+      Just (Success ref) -> validateWithSchemaRef ref (Object $ KM.fromHashMapText o)       Just (Error msg)   -> invalid ("failed to parse discriminator property " ++ show pname ++ ": " ++ show msg)       Nothing            -> invalid ("discriminator property " ++ show pname ++ "is missing")     Nothing -> do@@ -389,15 +477,21 @@     (Just SwaggerNumber,  Number n)   -> sub_ paramSchema (validateNumber n)     (Just SwaggerString,  String s)   -> sub_ paramSchema (validateString s)     (Just SwaggerArray,   Array xs)   -> sub_ paramSchema (validateArray xs)-    (Just SwaggerObject,  Object o)   -> validateObject o+    (Just SwaggerObject,  Object o)   -> validateObject $ KM.toHashMapText o     (Nothing, Null)                   -> valid     (Nothing, Bool _)                 -> valid     -- Number by default     (Nothing, Number n)               -> sub_ paramSchema (validateNumber n)     (Nothing, String s)               -> sub_ paramSchema (validateString s)     (Nothing, Array xs)               -> sub_ paramSchema (validateArray xs)-    (Nothing, Object o)               -> validateObject o-    param@(t, _) -> invalid $ "expected JSON value of type " ++ showType param+    (Nothing, Object o)               -> validateObject $ KM.toHashMapText o+    bad -> invalid $ unlines+      [ unwords ["expected JSON value of type", showType bad]+      , "  with context:"+      , "    " <> unwords ["SwaggerType:", show $ fst bad]+      , "    " <> unwords ["Aeson Value:", show $ snd bad]+      , "    " <> unwords ["Schema title:", show $ sch ^. title]+      ]  validateParamSchemaType :: Value -> Validation (ParamSchema t) () validateParamSchemaType value = withSchema $ \sch ->@@ -412,11 +506,10 @@     (Nothing, Number n)               -> validateNumber n     (Nothing, String s)               -> validateString s     (Nothing, Array xs)               -> validateArray xs-    (t, _) -> invalid $ "expected JSON value of type " ++ show t-    param@(t, _) -> invalid $ "expected JSON value of type " ++ showType param+    bad -> invalid $ "expected JSON value of type " ++ showType bad  showType :: (Maybe (SwaggerType t), Value) -> String-showType (Just type_, _)     = show type_+showType (Just ty, _)        = show ty showType (Nothing, Null)     = "SwaggerNull" showType (Nothing, Bool _)   = "SwaggerBoolean" showType (Nothing, Number _) = "SwaggerNumber"

@@ -1,7 +1,5 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-}-{-# LANGUAGE KindSignatures #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}@@ -37,11 +35,6 @@ type family GenericHasSimpleShape t (f :: Symbol) (s :: TypeShape) :: Constraint where   GenericHasSimpleShape t f Enumeration   = ()   GenericHasSimpleShape t f SumOfProducts = ()-#if __GLASGOW_HASKELL__ < 800-  GenericHasSimpleShape t f Mixed = CannotDeriveSchemaForMixedSumType t--class CannotDeriveSchemaForMixedSumType t where-#else   GenericHasSimpleShape t f Mixed =     TypeError       (     Text "Cannot derive Generic-based Swagger Schema for " :<>: ShowType t@@ -51,7 +44,6 @@       :$$:  Text "that matches aeson's Generic-based toJSON,"       :$$:  Text "but that's not supported by some Swagger tools."       )-#endif  -- | Infer a 'TypeShape' for a generic representation of a type. type family GenericShape (g :: * -> *) :: TypeShape@@ -62,5 +54,3 @@ type instance GenericShape (C1 c U1)        = Enumeration type instance GenericShape (C1 c (S1 s f))  = SumOfProducts type instance GenericShape (C1 c (f :*: g)) = SumOfProducts--

@@ -18,8 +18,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)

@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-}@@ -10,7 +9,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-}-#include "overlapping-compat.h" -- | -- Module:      Data.Swagger.Lens -- Maintainer:  Nickolay Kudasov <nickolay@getshoptv.com>@@ -96,6 +94,12 @@ instance Ixed Operation where ix n = responses . ix n instance At   Operation where at n = responses . at n +type instance Index SecurityDefinitions = Text+type instance IxValue SecurityDefinitions = SecurityScheme++instance Ixed SecurityDefinitions where ix n = (coerced :: Lens' SecurityDefinitions (Definitions SecurityScheme)). ix n+instance At   SecurityDefinitions where at n = (coerced :: Lens' SecurityDefinitions (Definitions SecurityScheme)). at n+ instance HasParamSchema NamedSchema (ParamSchema 'SwaggerKindSchema) where paramSchema = schema.paramSchema  -- HasType instances@@ -112,69 +116,63 @@ -- OVERLAPPABLE instances  instance-#if __GLASGOW_HASKELL__ >= 710-  OVERLAPPABLE_-#endif+  {-# OVERLAPPABLE #-}   HasParamSchema s (ParamSchema t)   => HasFormat s (Maybe Format) where   format = paramSchema.format  instance-#if __GLASGOW_HASKELL__ >= 710-  OVERLAPPABLE_-#endif+  {-# OVERLAPPABLE #-}   HasParamSchema s (ParamSchema t)   => HasItems s (Maybe (SwaggerItems t)) where   items = paramSchema.items  instance-#if __GLASGOW_HASKELL__ >= 710-  OVERLAPPABLE_-#endif+  {-# OVERLAPPABLE #-}   HasParamSchema s (ParamSchema t)   => HasMaximum s (Maybe Scientific) where   maximum_ = paramSchema.maximum_ -instance OVERLAPPABLE_ HasParamSchema s (ParamSchema t)+instance {-# OVERLAPPABLE #-} HasParamSchema s (ParamSchema t)   => HasExclusiveMaximum s (Maybe Bool) where   exclusiveMaximum = paramSchema.exclusiveMaximum -instance OVERLAPPABLE_ HasParamSchema s (ParamSchema t)+instance {-# OVERLAPPABLE #-} HasParamSchema s (ParamSchema t)   => HasMinimum s (Maybe Scientific) where   minimum_ = paramSchema.minimum_ -instance OVERLAPPABLE_ HasParamSchema s (ParamSchema t)+instance {-# OVERLAPPABLE #-} HasParamSchema s (ParamSchema t)   => HasExclusiveMinimum s (Maybe Bool) where   exclusiveMinimum = paramSchema.exclusiveMinimum -instance OVERLAPPABLE_ HasParamSchema s (ParamSchema t)+instance {-# OVERLAPPABLE #-} HasParamSchema s (ParamSchema t)   => HasMaxLength s (Maybe Integer) where   maxLength = paramSchema.maxLength -instance OVERLAPPABLE_ HasParamSchema s (ParamSchema t)+instance {-# OVERLAPPABLE #-} HasParamSchema s (ParamSchema t)   => HasMinLength s (Maybe Integer) where   minLength = paramSchema.minLength -instance OVERLAPPABLE_ HasParamSchema s (ParamSchema t)+instance {-# OVERLAPPABLE #-} HasParamSchema s (ParamSchema t)   => HasPattern s (Maybe Text) where   pattern = paramSchema.pattern -instance OVERLAPPABLE_ HasParamSchema s (ParamSchema t)+instance {-# OVERLAPPABLE #-} HasParamSchema s (ParamSchema t)   => HasMaxItems s (Maybe Integer) where   maxItems = paramSchema.maxItems -instance OVERLAPPABLE_ HasParamSchema s (ParamSchema t)+instance {-# OVERLAPPABLE #-} HasParamSchema s (ParamSchema t)   => HasMinItems s (Maybe Integer) where   minItems = paramSchema.minItems -instance OVERLAPPABLE_ HasParamSchema s (ParamSchema t)+instance {-# OVERLAPPABLE #-} HasParamSchema s (ParamSchema t)   => HasUniqueItems s (Maybe Bool) where   uniqueItems = paramSchema.uniqueItems -instance OVERLAPPABLE_ HasParamSchema s (ParamSchema t)+instance {-# OVERLAPPABLE #-} HasParamSchema s (ParamSchema t)   => HasEnum s (Maybe [Value]) where   enum_ = paramSchema.enum_ -instance OVERLAPPABLE_ HasParamSchema s (ParamSchema t)+instance {-# OVERLAPPABLE #-} HasParamSchema s (ParamSchema t)   => HasMultipleOf s (Maybe Scientific) where   multipleOf = paramSchema.multipleOf

@@ -17,6 +17,10 @@   applyTags,   applyTagsFor, +  -- ** Extensions+  addExtensions,+  addExtensionsFor,+   -- ** Responses   setResponse,   setResponseWith,@@ -34,29 +38,33 @@ import Prelude.Compat  import Control.Lens+import Data.Aeson (Value) import Data.Data.Lens import Data.List.Compat import Data.Maybe (mapMaybe) import Data.Proxy import qualified Data.Set as Set+import Data.Text (Text)  import Data.Swagger.Declare import Data.Swagger.Internal import Data.Swagger.Lens import Data.Swagger.Schema -import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap+import qualified Data.HashMap.Strict.InsOrd.Compat as InsOrdHashMap+import Data.HashMap.Strict.InsOrd.Compat (InsOrdHashMap) import qualified Data.HashSet.InsOrd as InsOrdHS  -- $setup -- >>> import Data.Aeson+-- >>> import qualified Data.HashMap.Strict.InsOrd.Compat as IOHM -- >>> import Data.Proxy -- >>> import Data.Time  -- | Prepend path piece to all operations of the spec. -- Leading and trailing slashes are trimmed/added automatically. ----- >>> let api = (mempty :: Swagger) & paths .~ [("/info", mempty)]+-- >>> let api = (mempty :: Swagger) & paths .~ IOHM.fromList [("/info", mempty)] -- >>> encode $ prependPath "user/{user_id}" api ^. paths -- "{\"/user/{user_id}/info\":{}}" prependPath :: FilePath -> Swagger -> Swagger@@ -77,12 +85,12 @@ -- by both path and method. -- -- >>> let ok = (mempty :: Operation) & at 200 ?~ "OK"--- >>> let api = (mempty :: Swagger) & paths .~ [("/user", mempty & get ?~ ok & post ?~ ok)]--- >>> let sub = (mempty :: Swagger) & paths .~ [("/user", mempty & get ?~ mempty)]+-- >>> let api = (mempty :: Swagger) & paths .~ IOHM.fromList [("/user", mempty & get ?~ ok & post ?~ ok)]+-- >>> let sub = (mempty :: Swagger) & paths .~ IOHM.fromList [("/user", mempty & get ?~ mempty)] -- >>> encode api--- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"paths\":{\"/user\":{\"get\":{\"responses\":{\"200\":{\"description\":\"OK\"}}},\"post\":{\"responses\":{\"200\":{\"description\":\"OK\"}}}}}}"+-- "{\"swagger\":\"2.0\",\"info\":{\"title\":\"\",\"version\":\"\"},\"paths\":{\"/user\":{\"get\":{\"responses\":{\"200\":{\"description\":\"OK\"}}},\"post\":{\"responses\":{\"200\":{\"description\":\"OK\"}}}}}}" -- >>> encode $ api & operationsOf sub . at 404 ?~ "Not found"--- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"paths\":{\"/user\":{\"get\":{\"responses\":{\"404\":{\"description\":\"Not found\"},\"200\":{\"description\":\"OK\"}}},\"post\":{\"responses\":{\"200\":{\"description\":\"OK\"}}}}}}"+-- "{\"swagger\":\"2.0\",\"info\":{\"title\":\"\",\"version\":\"\"},\"paths\":{\"/user\":{\"get\":{\"responses\":{\"200\":{\"description\":\"OK\"},\"404\":{\"description\":\"Not found\"}}},\"post\":{\"responses\":{\"200\":{\"description\":\"OK\"}}}}}}" operationsOf :: Swagger -> Traversal' Swagger Operation operationsOf sub = paths.itraversed.withIndex.subops   where@@ -108,6 +116,13 @@ applyTags :: [Tag] -> Swagger -> Swagger applyTags = applyTagsFor allOperations +addExtensions :: (Value -> Value -> Value) -> InsOrdHashMap Text Value -> Swagger -> Swagger+addExtensions = addExtensionsFor allOperations++addExtensionsFor :: Traversal' Swagger Operation -> (Value -> Value -> Value) -> InsOrdHashMap Text Value -> Swagger -> Swagger+addExtensionsFor ops merge add swag = swag+  & ops . extensions %~ InsOrdHashMap.unionWith merge add+ -- | Apply tags to a part of Swagger spec and update the global -- list of tags. applyTagsFor :: Traversal' Swagger Operation -> [Tag] -> Swagger -> Swagger@@ -136,10 +151,10 @@ -- -- Example: ----- >>> let api = (mempty :: Swagger) & paths .~ [("/user", mempty & get ?~ mempty)]+-- >>> let api = (mempty :: Swagger) & paths .~ IOHM.fromList [("/user", mempty & get ?~ mempty)] -- >>> let res = declareResponse (Proxy :: Proxy Day) -- >>> encode $ api & setResponse 200 res--- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"paths\":{\"/user\":{\"get\":{\"responses\":{\"200\":{\"schema\":{\"$ref\":\"#/definitions/Day\"},\"description\":\"\"}}}}},\"definitions\":{\"Day\":{\"example\":\"2016-07-22\",\"format\":\"date\",\"type\":\"string\"}}}"+-- "{\"swagger\":\"2.0\",\"info\":{\"title\":\"\",\"version\":\"\"},\"paths\":{\"/user\":{\"get\":{\"responses\":{\"200\":{\"description\":\"\",\"schema\":{\"$ref\":\"#/definitions/Day\"}}}}}},\"definitions\":{\"Day\":{\"example\":\"2016-07-22\",\"format\":\"date\",\"type\":\"string\"}}}" -- -- See also @'setResponseWith'@. setResponse :: HttpStatusCode -> Declare (Definitions Schema) Response -> Swagger -> Swagger

@@ -0,0 +1,598 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- |+-- Module:      Data.Swagger.Optics+-- Maintainer:  Andrzej Rybczak <andrzej@rybczak.net>+-- Stability:   experimental+--+-- Lenses and prisms for the <https://hackage.haskell.org/package/optics optics>+-- library.+--+-- >>> import Data.Aeson+-- >>> import qualified Data.HashMap.Strict.InsOrd.Compat as IOHM+-- >>> import Optics.Core+-- >>> :set -XOverloadedLabels+--+-- Example from the "Data.Swagger" module using @optics@:+--+-- >>> :{+-- encode $ (mempty :: Swagger)+--   & #definitions .~ IOHM.fromList [ ("User", mempty & #type ?~ SwaggerString) ]+--   & #paths .~ IOHM.fromList+--     [ ("/user", mempty & #get ?~ (mempty+--         & #produces ?~ MimeList ["application/json"]+--         & at 200 ?~ ("OK" & #_Inline % #schema ?~ Ref (Reference "User"))+--         & at 404 ?~ "User info not found")) ]+-- :}+-- "{\"swagger\":\"2.0\",\"info\":{\"title\":\"\",\"version\":\"\"},\"paths\":{\"/user\":{\"get\":{\"produces\":[\"application/json\"],\"responses\":{\"200\":{\"description\":\"OK\",\"schema\":{\"$ref\":\"#/definitions/User\"}},\"404\":{\"description\":\"User info not found\"}}}}},\"definitions\":{\"User\":{\"type\":\"string\"}}}"+--+-- For convenience optics are defined as /labels/. It means that field accessor+-- names can be overloaded for different types. One such common field is+-- @#description@. Many components of a Swagger specification can have+-- descriptions, and you can use the same name for them:+--+-- >>> encode $ (mempty :: Response) & #description .~ "No content"+-- "{\"description\":\"No content\"}"+-- >>> :{+-- encode $ (mempty :: Schema)+--   & #type        ?~ SwaggerBoolean+--   & #description ?~ "To be or not to be"+-- :}+-- "{\"description\":\"To be or not to be\",\"type\":\"boolean\"}"+--+-- @'ParamSchema'@ is basically the /base schema specification/ and many types+-- contain it. So for convenience, all @'ParamSchema'@ fields are transitively+-- made fields of the type that has it. For example, you can use @#type@ to+-- access @'SwaggerType'@ of @'Header'@ schema without having to use+-- @#paramSchema@:+--+-- >>> encode $ (mempty :: Header) & #type ?~ SwaggerNumber+-- "{\"type\":\"number\"}"+--+-- Additionally, to simplify working with @'Response'@, both @'Operation'@ and+-- @'Responses'@ have direct access to it via @'Optics.Core.At.at'@. Example:+--+-- >>> :{+-- encode $ (mempty :: Operation)+--   & at 404 ?~ "Not found"+-- :}+-- "{\"responses\":{\"404\":{\"description\":\"Not found\"}}}"+--+module Data.Swagger.Optics () where++import Data.Aeson (Value)+import Data.Scientific (Scientific)+import Data.Swagger.Internal+import Data.Text (Text)+import Optics.Core+import Optics.TH++-- Lenses++makeFieldLabels ''Swagger+makeFieldLabels ''Host+makeFieldLabels ''Info+makeFieldLabels ''Contact+makeFieldLabels ''License+makeFieldLabels ''PathItem+makeFieldLabels ''Tag+makeFieldLabels ''Operation+makeFieldLabels ''Param+makeFieldLabels ''ParamOtherSchema+makeFieldLabels ''Header+makeFieldLabels ''Schema+makeFieldLabels ''NamedSchema+makeFieldLabels ''ParamSchema+makeFieldLabels ''Xml+makeFieldLabels ''Responses+makeFieldLabels ''Response+makeFieldLabels ''SecurityScheme+makeFieldLabels ''ApiKeyParams+makeFieldLabels ''OAuth2Params+makeFieldLabels ''ExternalDocs++-- Prisms++makePrismLabels ''ParamAnySchema+makePrismLabels ''SecuritySchemeType+makePrismLabels ''Referenced++-- SwaggerItems prisms++instance+  ( a ~ [Referenced Schema]+  , b ~ [Referenced Schema]+  ) => LabelOptic "_SwaggerItemsArray"+         A_Review+         (SwaggerItems 'SwaggerKindSchema)+         (SwaggerItems 'SwaggerKindSchema)+         a+         b where+  labelOptic = unto (\x -> SwaggerItemsArray x)+  {-# INLINE labelOptic #-}++instance+  ( a ~ Referenced Schema+  , b ~ Referenced Schema+  ) => LabelOptic "_SwaggerItemsObject"+         A_Review+         (SwaggerItems 'SwaggerKindSchema)+         (SwaggerItems 'SwaggerKindSchema)+         a+         b where+  labelOptic = unto (\x -> SwaggerItemsObject x)+  {-# INLINE labelOptic #-}++instance+  ( a ~ (Maybe (CollectionFormat t), ParamSchema t)+  , b ~ (Maybe (CollectionFormat t), ParamSchema t)+  ) => LabelOptic "_SwaggerItemsPrimitive"+         A_Review+         (SwaggerItems t)+         (SwaggerItems t)+         a+         b where+  labelOptic = unto (\(c, p) -> SwaggerItemsPrimitive c p)+  {-# INLINE labelOptic #-}++-- =============================================================+-- More helpful instances for easier access to schema properties++type instance Index Responses = HttpStatusCode+type instance Index Operation = HttpStatusCode++type instance IxValue Responses = Referenced Response+type instance IxValue Operation = Referenced Response++instance Ixed Responses where+  ix n = #responses % ix n+  {-# INLINE ix #-}+instance At   Responses where+  at n = #responses % at n+  {-# INLINE at #-}++instance Ixed Operation where+  ix n = #responses % ix n+  {-# INLINE ix #-}+instance At   Operation where+  at n = #responses % at n+  {-# INLINE at #-}++-- #paramSchema++instance+  ( a ~ ParamSchema 'SwaggerKindSchema+  , b ~ ParamSchema 'SwaggerKindSchema+  ) => LabelOptic "paramSchema" A_Lens NamedSchema NamedSchema a b where+  labelOptic = #schema % #paramSchema+  {-# INLINE labelOptic #-}++-- #type++instance+  ( a ~ Maybe (SwaggerType ('SwaggerKindNormal Header))+  , b ~ Maybe (SwaggerType ('SwaggerKindNormal Header))+  ) => LabelOptic "type" A_Lens Header Header a b where+  labelOptic = #paramSchema % #type+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe (SwaggerType 'SwaggerKindSchema)+  , b ~ Maybe (SwaggerType 'SwaggerKindSchema)+  ) => LabelOptic "type" A_Lens Schema Schema a b where+  labelOptic = #paramSchema % #type+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe (SwaggerType 'SwaggerKindSchema)+  , b ~ Maybe (SwaggerType 'SwaggerKindSchema)+  ) => LabelOptic "type" A_Lens NamedSchema NamedSchema a b where+  labelOptic = #paramSchema % #type+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe (SwaggerType 'SwaggerKindParamOtherSchema)+  , b ~ Maybe (SwaggerType 'SwaggerKindParamOtherSchema)+  ) => LabelOptic "type" A_Lens ParamOtherSchema ParamOtherSchema a b where+  labelOptic = #paramSchema % #type+  {-# INLINE labelOptic #-}++-- #default++instance+  ( a ~ Maybe Value, b ~ Maybe Value+  ) => LabelOptic "default" A_Lens Header Header a b where+  labelOptic = #paramSchema % #default+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe Value, b ~ Maybe Value+  ) => LabelOptic "default" A_Lens Schema Schema a b where+  labelOptic = #paramSchema % #default+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe Value, b ~ Maybe Value+  ) => LabelOptic "default" A_Lens NamedSchema NamedSchema a b where+  labelOptic = #paramSchema % #default+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe Value, b ~ Maybe Value+  ) => LabelOptic "default" A_Lens ParamOtherSchema ParamOtherSchema a b where+  labelOptic = #paramSchema % #default+  {-# INLINE labelOptic #-}++-- #format++instance+  ( a ~ Maybe Format, b ~ Maybe Format+  ) => LabelOptic "format" A_Lens Header Header a b where+  labelOptic = #paramSchema % #format+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe Format, b ~ Maybe Format+  ) => LabelOptic "format" A_Lens Schema Schema a b where+  labelOptic = #paramSchema % #format+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe Format, b ~ Maybe Format+  ) => LabelOptic "format" A_Lens NamedSchema NamedSchema a b where+  labelOptic = #paramSchema % #format+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe Format, b ~ Maybe Format+  ) => LabelOptic "format" A_Lens ParamOtherSchema ParamOtherSchema a b where+  labelOptic = #paramSchema % #format+  {-# INLINE labelOptic #-}++-- #items++instance+  ( a ~ Maybe (SwaggerItems ('SwaggerKindNormal Header))+  , b ~ Maybe (SwaggerItems ('SwaggerKindNormal Header))+  ) => LabelOptic "items" A_Lens Header Header a b where+  labelOptic = #paramSchema % #items+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe (SwaggerItems 'SwaggerKindSchema)+  , b ~ Maybe (SwaggerItems 'SwaggerKindSchema)+  ) => LabelOptic "items" A_Lens Schema Schema a b where+  labelOptic = #paramSchema % #items+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe (SwaggerItems 'SwaggerKindSchema)+  , b ~ Maybe (SwaggerItems 'SwaggerKindSchema)+  ) => LabelOptic "items" A_Lens NamedSchema NamedSchema a b where+  labelOptic = #paramSchema % #items+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe (SwaggerItems 'SwaggerKindParamOtherSchema)+  , b ~ Maybe (SwaggerItems 'SwaggerKindParamOtherSchema)+  ) => LabelOptic "items" A_Lens ParamOtherSchema ParamOtherSchema a b where+  labelOptic = #paramSchema % #items+  {-# INLINE labelOptic #-}++-- #maximum++instance+  ( a ~ Maybe Scientific, b ~ Maybe Scientific+  ) => LabelOptic "maximum" A_Lens Header Header a b where+  labelOptic = #paramSchema % #maximum+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe Scientific, b ~ Maybe Scientific+  ) => LabelOptic "maximum" A_Lens Schema Schema a b where+  labelOptic = #paramSchema % #maximum+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe Scientific, b ~ Maybe Scientific+  ) => LabelOptic "maximum" A_Lens NamedSchema NamedSchema a b where+  labelOptic = #paramSchema % #maximum+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe Scientific, b ~ Maybe Scientific+  ) => LabelOptic "maximum" A_Lens ParamOtherSchema ParamOtherSchema a b where+  labelOptic = #paramSchema % #maximum+  {-# INLINE labelOptic #-}++-- #exclusiveMaximum++instance+  ( a ~ Maybe Bool, b ~ Maybe Bool+  ) => LabelOptic "exclusiveMaximum" A_Lens Header Header a b where+  labelOptic = #paramSchema % #exclusiveMaximum+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe Bool, b ~ Maybe Bool+  ) => LabelOptic "exclusiveMaximum" A_Lens Schema Schema a b where+  labelOptic = #paramSchema % #exclusiveMaximum+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe Bool, b ~ Maybe Bool+  ) => LabelOptic "exclusiveMaximum" A_Lens NamedSchema NamedSchema a b where+  labelOptic = #paramSchema % #exclusiveMaximum+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe Bool, b ~ Maybe Bool+  ) => LabelOptic "exclusiveMaximum" A_Lens ParamOtherSchema ParamOtherSchema a b where+  labelOptic = #paramSchema % #exclusiveMaximum+  {-# INLINE labelOptic #-}++-- #minimum++instance+  ( a ~ Maybe Scientific, b ~ Maybe Scientific+  ) => LabelOptic "minimum" A_Lens Header Header a b where+  labelOptic = #paramSchema % #minimum+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe Scientific, b ~ Maybe Scientific+  ) => LabelOptic "minimum" A_Lens Schema Schema a b where+  labelOptic = #paramSchema % #minimum+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe Scientific, b ~ Maybe Scientific+  ) => LabelOptic "minimum" A_Lens NamedSchema NamedSchema a b where+  labelOptic = #paramSchema % #minimum+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe Scientific, b ~ Maybe Scientific+  ) => LabelOptic "minimum" A_Lens ParamOtherSchema ParamOtherSchema a b where+  labelOptic = #paramSchema % #minimum+  {-# INLINE labelOptic #-}++-- #exclusiveMinimum++instance+  ( a ~ Maybe Bool, b ~ Maybe Bool+  ) => LabelOptic "exclusiveMinimum" A_Lens Header Header a b where+  labelOptic = #paramSchema % #exclusiveMinimum+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe Bool, b ~ Maybe Bool+  ) => LabelOptic "exclusiveMinimum" A_Lens Schema Schema a b where+  labelOptic = #paramSchema % #exclusiveMinimum+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe Bool, b ~ Maybe Bool+  ) => LabelOptic "exclusiveMinimum" A_Lens NamedSchema NamedSchema a b where+  labelOptic = #paramSchema % #exclusiveMinimum+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe Bool, b ~ Maybe Bool+  ) => LabelOptic "exclusiveMinimum" A_Lens ParamOtherSchema ParamOtherSchema a b where+  labelOptic = #paramSchema % #exclusiveMinimum+  {-# INLINE labelOptic #-}++-- #maxLength++instance+  ( a ~ Maybe Integer, b ~ Maybe Integer+  ) => LabelOptic "maxLength" A_Lens Header Header a b where+  labelOptic = #paramSchema % #maxLength+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe Integer, b ~ Maybe Integer+  ) => LabelOptic "maxLength" A_Lens Schema Schema a b where+  labelOptic = #paramSchema % #maxLength+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe Integer, b ~ Maybe Integer+  ) => LabelOptic "maxLength" A_Lens NamedSchema NamedSchema a b where+  labelOptic = #paramSchema % #maxLength+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe Integer, b ~ Maybe Integer+  ) => LabelOptic "maxLength" A_Lens ParamOtherSchema ParamOtherSchema a b where+  labelOptic = #paramSchema % #maxLength+  {-# INLINE labelOptic #-}++-- #minLength++instance+  ( a ~ Maybe Integer, b ~ Maybe Integer+  ) => LabelOptic "minLength" A_Lens Header Header a b where+  labelOptic = #paramSchema % #minLength+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe Integer, b ~ Maybe Integer+  ) => LabelOptic "minLength" A_Lens Schema Schema a b where+  labelOptic = #paramSchema % #minLength+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe Integer, b ~ Maybe Integer+  ) => LabelOptic "minLength" A_Lens NamedSchema NamedSchema a b where+  labelOptic = #paramSchema % #minLength+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe Integer, b ~ Maybe Integer+  ) => LabelOptic "minLength" A_Lens ParamOtherSchema ParamOtherSchema a b where+  labelOptic = #paramSchema % #minLength+  {-# INLINE labelOptic #-}++-- #pattern++instance+  ( a ~ Maybe Text, b ~ Maybe Text+  ) => LabelOptic "pattern" A_Lens Header Header a b where+  labelOptic = #paramSchema % #pattern+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe Text, b ~ Maybe Text+  ) => LabelOptic "pattern" A_Lens Schema Schema a b where+  labelOptic = #paramSchema % #pattern+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe Text, b ~ Maybe Text+  ) => LabelOptic "pattern" A_Lens NamedSchema NamedSchema a b where+  labelOptic = #paramSchema % #pattern+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe Text, b ~ Maybe Text+  ) => LabelOptic "pattern" A_Lens ParamOtherSchema ParamOtherSchema a b where+  labelOptic = #paramSchema % #pattern+  {-# INLINE labelOptic #-}++-- #maxItems++instance+  ( a ~ Maybe Integer, b ~ Maybe Integer+  ) => LabelOptic "maxItems" A_Lens Header Header a b where+  labelOptic = #paramSchema % #maxItems+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe Integer, b ~ Maybe Integer+  ) => LabelOptic "maxItems" A_Lens Schema Schema a b where+  labelOptic = #paramSchema % #maxItems+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe Integer, b ~ Maybe Integer+  ) => LabelOptic "maxItems" A_Lens NamedSchema NamedSchema a b where+  labelOptic = #paramSchema % #maxItems+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe Integer, b ~ Maybe Integer+  ) => LabelOptic "maxItems" A_Lens ParamOtherSchema ParamOtherSchema a b where+  labelOptic = #paramSchema % #maxItems+  {-# INLINE labelOptic #-}++-- #minItems++instance+  ( a ~ Maybe Integer, b ~ Maybe Integer+  ) => LabelOptic "minItems" A_Lens Header Header a b where+  labelOptic = #paramSchema % #minItems+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe Integer, b ~ Maybe Integer+  ) => LabelOptic "minItems" A_Lens Schema Schema a b where+  labelOptic = #paramSchema % #minItems+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe Integer, b ~ Maybe Integer+  ) => LabelOptic "minItems" A_Lens NamedSchema NamedSchema a b where+  labelOptic = #paramSchema % #minItems+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe Integer, b ~ Maybe Integer+  ) => LabelOptic "minItems" A_Lens ParamOtherSchema ParamOtherSchema a b where+  labelOptic = #paramSchema % #minItems+  {-# INLINE labelOptic #-}++-- #uniqueItems++instance+  ( a ~ Maybe Bool, b ~ Maybe Bool+  ) => LabelOptic "uniqueItems" A_Lens Header Header a b where+  labelOptic = #paramSchema % #uniqueItems+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe Bool, b ~ Maybe Bool+  ) => LabelOptic "uniqueItems" A_Lens Schema Schema a b where+  labelOptic = #paramSchema % #uniqueItems+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe Bool, b ~ Maybe Bool+  ) => LabelOptic "uniqueItems" A_Lens NamedSchema NamedSchema a b where+  labelOptic = #paramSchema % #uniqueItems+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe Bool, b ~ Maybe Bool+  ) => LabelOptic "uniqueItems" A_Lens ParamOtherSchema ParamOtherSchema a b where+  labelOptic = #paramSchema % #uniqueItems+  {-# INLINE labelOptic #-}++-- #enum++instance+  ( a ~ Maybe [Value], b ~ Maybe [Value]+  ) => LabelOptic "enum" A_Lens Header Header a b where+  labelOptic = #paramSchema % #enum+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe [Value], b ~ Maybe [Value]+  ) => LabelOptic "enum" A_Lens Schema Schema a b where+  labelOptic = #paramSchema % #enum+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe [Value], b ~ Maybe [Value]+  ) => LabelOptic "enum" A_Lens NamedSchema NamedSchema a b where+  labelOptic = #paramSchema % #enum+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe [Value], b ~ Maybe [Value]+  ) => LabelOptic "enum" A_Lens ParamOtherSchema ParamOtherSchema a b where+  labelOptic = #paramSchema % #enum+  {-# INLINE labelOptic #-}++-- #multipleOf++instance+  ( a ~ Maybe Scientific, b ~ Maybe Scientific+  ) => LabelOptic "multipleOf" A_Lens Header Header a b where+  labelOptic = #paramSchema % #multipleOf+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe Scientific, b ~ Maybe Scientific+  ) => LabelOptic "multipleOf" A_Lens Schema Schema a b where+  labelOptic = #paramSchema % #multipleOf+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe Scientific, b ~ Maybe Scientific+  ) => LabelOptic "multipleOf" A_Lens NamedSchema NamedSchema a b where+  labelOptic = #paramSchema % #multipleOf+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe Scientific, b ~ Maybe Scientific+  ) => LabelOptic "multipleOf" A_Lens ParamOtherSchema ParamOtherSchema a b where+  labelOptic = #paramSchema % #multipleOf+  {-# INLINE labelOptic #-}

@@ -10,9 +10,9 @@ import           Control.Lens.Operators import           Control.Monad                           (filterM) import           Data.Aeson+import qualified Data.Aeson.KeyMap                       as KM import           Data.Aeson.Types-import qualified Data.HashMap.Strict.InsOrd              as M-import           Data.Maybe+import qualified Data.HashMap.Strict.InsOrd.Compat       as M import           Data.Maybe import           Data.Proxy import           Data.Scientific@@ -94,7 +94,7 @@               return . M.fromList $ zip additionalKeys (repeat . schemaGen defns $ dereference defns addlSchema)             _                                      -> return []           x <- sequence $ gens <> additionalGens-          return . Object $ M.toHashMap x+          return . Object . KM.fromHashMapText $ M.toHashMap x   where     dereference :: Definitions a -> Referenced a -> a     dereference _ (Inline a)               = a

@@ -19,8 +19,10 @@   ValidationError,    -- ** Using 'ToJSON' and 'ToSchema'+  validatePrettyToJSON,   validateToJSON,   validateToJSONWithPatternChecker,+  renderValidationErrors,    -- ** Using 'Value' and 'Schema'   validateJSON,@@ -69,11 +71,11 @@ -- generally fails for @null@ JSON: -- -- >>> validateToJSON (Nothing :: Maybe String)--- ["expected JSON value of type SwaggerString"]+-- ["expected JSON value of type SwaggerString\n  with context:\n    SwaggerType: Just SwaggerString\n    Aeson Value: Null\n    Schema title: Nothing\n"] -- >>> validateToJSON ([Just "hello", Nothing] :: [Maybe String])--- ["expected JSON value of type SwaggerString"]+-- ["expected JSON value of type SwaggerString\n  with context:\n    SwaggerType: Just SwaggerString\n    Aeson Value: Null\n    Schema title: Nothing\n"] -- >>> validateToJSON (123, Nothing :: Maybe String)--- ["expected JSON value of type SwaggerString"]+-- ["expected JSON value of type SwaggerString\n  with context:\n    SwaggerType: Just SwaggerString\n    Aeson Value: Null\n    Schema title: Nothing\n"] -- -- However, when @'Maybe' a@ is a type of a record field, -- validation takes @'required'@ property of the @'Schema'@

@@ -1,6 +1,6 @@ cabal-version:       >=1.10 name:                swagger2-version:             2.4+version:             2.9  synopsis:            Swagger 2.0 data model category:            Web, Swagger@@ -22,28 +22,31 @@     README.md   , CHANGELOG.md   , examples/*.hs-  , include/overlapping-compat.h tested-with:-  GHC ==7.8.4-   || ==7.10.3-   || ==8.0.2-   || ==8.2.2-   || ==8.4.4-   || ==8.6.5-   || ==8.8.1+  GHC ==8.6.5+   || ==8.8.4+   || ==8.10.7+   || ==9.0.2+   || ==9.2.8+   || ==9.6.4+   || ==9.8.1+   || ==9.12.1  custom-setup   setup-depends:-    base, Cabal, cabal-doctest >=1.0.6 && <1.1+                base          >=4.9   &&< 4.22+              , Cabal < 3.15+              , cabal-doctest >=1.0.6 && <1.1  library   hs-source-dirs:      src-  include-dirs:        include   exposed-modules:+    Data.HashMap.Strict.InsOrd.Compat     Data.Swagger     Data.Swagger.Declare     Data.Swagger.Lens     Data.Swagger.Operation+    Data.Swagger.Optics     Data.Swagger.ParamSchema     Data.Swagger.Schema     Data.Swagger.Schema.Generator@@ -61,35 +64,37 @@    -- GHC boot libraries   build-depends:-      base             >=4.7      && <4.13-    , bytestring       >=0.10.4.0 && <0.11-    , containers       >=0.5.5.1  && <0.7-    , template-haskell >=2.9.0.0  && <2.15-    , time             >=1.4.2    && <1.10-    , transformers     >=0.3.0.0  && <0.6+      base             >=4.9       && <4.22+    , bytestring       >=0.10.8.1  && <0.13+    , containers       >=0.5.7.1   && <0.9+    , template-haskell >=2.11.1.0  && <2.24+    , time             >=1.6.0.1   && <1.15+    , transformers     >=0.5.2.0   && <0.7    build-depends:-      mtl              >=2.1     && <2.3-    , text             >=1.2.3.0 && <1.3+      mtl              >=2.2.2   && <2.4+    , text             >=1.2.3.0 && <2.2    -- other dependencies   build-depends:-      base-compat-batteries     >=0.10.4   && <0.11-    , aeson                     >=1.4.2.0  && <1.5+      base-compat-batteries     >=0.11.1   && <0.15+    , aeson                     >=2.0.0.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-    , generics-sop              >=0.3.2.0  && <0.6-    , hashable                  >=1.2.7.0  && <1.4-    , http-media                >=0.7.1.2  && <0.9-    , insert-ordered-containers >=0.2.2    && <0.3-    , lens                      >=4.16.1   && <4.18-    , network                   >=2.6.3.5  && <3.2+    , cookie                    >=0.4.3    && <0.6+    , generics-sop              >=0.5.1.0  && <0.6+    , hashable                  >=1.2.7.0  && <1.6+    , http-media                >=0.8.0.0  && <0.9+    , insert-ordered-containers >=0.2.3    && <0.4+    , lens                      >=4.16.1   && <5.4+    , network                   >=2.6.3.5  && <3.3+    , optics-core               >=0.2      && <0.5+    , optics-th                 >=0.2      && <0.5     , scientific                >=0.3.6.2  && <0.4-    , transformers-compat       >=0.3      && <0.7     , 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.14+    , vector                    >=0.12.0.1 && <0.14+    , QuickCheck                >=2.10.1   && <2.17    default-language:    Haskell2010 @@ -101,7 +106,7 @@   -- From library parat  -- We need aeson's toEncoding for doctests too   build-depends:-      base+      base                      >=4.9       && <4.22     , swagger2     , aeson     , base-compat-batteries@@ -120,14 +125,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+    , quickcheck-instances >=0.3.19  && <0.4     , 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@@ -141,7 +146,10 @@  test-suite doctests   -- See QuickCheck note in https://github.com/phadej/cabal-doctest#notes-  build-depends:    base, doctest, Glob, QuickCheck+  build-depends:    base                 >=4.9       && <4.22+                  , doctest+                  , Glob+                  , QuickCheck   default-language: Haskell2010   hs-source-dirs:   test   main-is:          doctests.hs

@@ -15,11 +15,10 @@ import           Data.Proxy import           Data.Set              (Set) import qualified Data.Text             as Text+import           Data.Word import           GHC.Generics  import           Data.Swagger-import           Data.Swagger.Declare-import           Data.Swagger.Internal (SwaggerKind (..))  -- ======================================================================== -- Unit type@@ -648,5 +647,60 @@     {       "singleMaybeField": { "type": "string" }     }+}+|]+++-- ========================================================================+-- TimeOfDay+-- ========================================================================+data TimeOfDay+  = Int+  | Pico+  deriving (Generic)+instance ToSchema TimeOfDay+instance ToParamSchema TimeOfDay+++timeOfDaySchemaJSON :: Value+timeOfDaySchemaJSON = [aesonQQ|+{+  "example": "12:33:15",+  "type": "string",+  "format": "hh:MM:ss"+}+|]++timeOfDayParamSchemaJSON :: Value+timeOfDayParamSchemaJSON = [aesonQQ|+{+  "type": "string",+  "format": "hh:MM:ss"+}+|]+++-- ========================================================================+-- UnsignedInts+-- ========================================================================+data UnsignedInts = UnsignedInts+  { unsignedIntsUint32 :: Word32+  , unsignedIntsUint64 :: Word64+  } deriving (Generic)++instance ToSchema UnsignedInts where+  declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions+    { fieldLabelModifier = map toLower . drop (length "unsignedInts") }++unsignedIntsSchemaJSON :: Value+unsignedIntsSchemaJSON = [aesonQQ|+{+  "type": "object",+  "properties":+    {+      "uint32": { "type": "integer", "format": "int32", "minimum": 0, "maximum": 4294967295 },+      "uint64": { "type": "integer", "format": "int64", "minimum": 0, "maximum": 18446744073709551615 }+    },+  "required": ["uint32", "uint64"] } |]

@@ -3,9 +3,10 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE OverloadedStrings #-} module Data.Swagger.ParamSchemaSpec where -import Data.Aeson (Value)+import Data.Aeson import Data.Aeson.QQ.Simple import Data.Char import Data.Proxy@@ -17,7 +18,10 @@ import Data.Swagger.CommonTestTypes import SpecCommon import Test.Hspec+import Data.Time.LocalTime +import qualified Data.HashMap.Strict as HM+ checkToParamSchema :: ToParamSchema a => Proxy a -> Value -> Spec checkToParamSchema proxy js = (toParamSchema proxy :: ParamSchema ('SwaggerKindNormal Param)) <=> js @@ -30,6 +34,7 @@     context "Unary records" $ do       context "Email (unary record)"  $ checkToParamSchema (Proxy :: Proxy Email)  emailSchemaJSON       context "UserId (non-record newtype)" $ checkToParamSchema (Proxy :: Proxy UserId) userIdSchemaJSON+    context "TimeOfDay" $ checkToParamSchema (Proxy :: Proxy Data.Time.LocalTime.TimeOfDay) timeOfDayParamSchemaJSON  main :: IO () main = hspec spec

@@ -3,6 +3,7 @@ {-# LANGUAGE PackageImports      #-} {-# LANGUAGE RecordWildCards     #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleInstances   #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Data.Swagger.Schema.ValidationSpec where @@ -10,6 +11,8 @@ import           Control.Lens                        ((&), (.~), (?~)) import           Data.Aeson import           Data.Aeson.Types+import           Data.Aeson.Key+import qualified Data.Aeson.KeyMap                   as KM import           Data.Hashable                       (Hashable) import           Data.HashMap.Strict                 (HashMap) import qualified Data.HashMap.Strict                 as HashMap@@ -123,9 +126,9 @@  invalidPersonToJSON :: Person -> Value invalidPersonToJSON Person{..} = object-  [ T.pack "personName"  .= toJSON name-  , T.pack "personPhone" .= toJSON phone-  , T.pack "personEmail" .= toJSON email+  [ fromString "personName"  .= toJSON name+  , fromString "personPhone" .= toJSON phone+  , fromString "personEmail" .= toJSON email   ]  -- ========================================================================@@ -252,7 +255,7 @@     & additionalProperties ?~ AdditionalPropertiesAllowed True  instance Arbitrary FreeForm where-  arbitrary = (FreeForm . fromList) <$> genObj+  arbitrary = FreeForm . fromList <$> genObj     where       genObj = listOf $ do         k <- arbitrary@@ -266,13 +269,18 @@ -- Arbitrary instance for Data.Aeson.Value -- ======================================================================== +#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.   arbitrary = resize 4 $ frequency-    [ (3, Object <$> arbitrary)+    [ (3, Object . KM.fromHashMapText <$> arbitrary)     , (3, Array  <$> arbitrary)     , (3, String <$> arbitrary)     , (3, Number <$> arbitrary)     , (3, Bool   <$> arbitrary)     , (1, return Null) ]++instance Arbitrary (KM.KeyMap Value) where+  arbitrary = KM.fromHashMapText <$> arbitrary+#endif

@@ -8,16 +8,11 @@ import Prelude.Compat  import Control.Lens ((^.))-import Data.Aeson (Value, ToJSON(..), ToJSONKey(..))-import Data.Aeson.Types (toJSONKeyText)-import Data.Aeson.QQ.Simple-import Data.Char-import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap+import Data.Aeson (Value)+import qualified Data.HashMap.Strict.InsOrd.Compat as InsOrdHashMap import Data.Proxy import Data.Set (Set)-import Data.Map (Map) import qualified Data.Text as Text-import GHC.Generics  import Data.Swagger import Data.Swagger.Declare@@ -26,6 +21,9 @@ import SpecCommon import Test.Hspec +import qualified Data.HashMap.Strict as HM+import Data.Time.LocalTime+ checkToSchema :: ToSchema a => Proxy a -> Value -> Spec checkToSchema proxy js = toSchema proxy <=> js @@ -87,6 +85,7 @@       context "Status (sum of unary constructors)" $ checkToSchema (Proxy :: Proxy Status) statusSchemaJSON       context "Character (ref and record sum)" $ checkToSchema (Proxy :: Proxy Character) characterSchemaJSON       context "Light (sum with unwrapUnaryRecords)" $ checkToSchema (Proxy :: Proxy Light) lightSchemaJSON+    context "UnsignedInts" $ checkToSchema (Proxy :: Proxy UnsignedInts) unsignedIntsSchemaJSON     context "Schema name" $ do       context "String" $ checkSchemaName Nothing (Proxy :: Proxy String)       context "(Int, Float)" $ checkSchemaName Nothing (Proxy :: Proxy (Int, Float))@@ -110,6 +109,7 @@     context "MyRoseTree' (inlineNonRecursiveSchemas)" $ checkInlinedRecSchema (Proxy :: Proxy MyRoseTree') myRoseTreeSchemaJSON'   describe "Bounded Enum key mapping" $ do     context "ButtonImages" $ checkToSchema (Proxy :: Proxy ButtonImages) buttonImagesSchemaJSON+    context "TimeOfDay" $ checkToSchema (Proxy :: Proxy Data.Time.LocalTime.TimeOfDay) timeOfDaySchemaJSON  main :: IO () main = hspec spec

@@ -12,6 +12,7 @@ import Data.Aeson import Data.Aeson.QQ.Simple import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict.InsOrd.Compat as InsOrdHashMap import qualified Data.HashSet.InsOrd as InsOrdHS import Data.Text (Text) @@ -43,8 +44,10 @@   describe "Parameters Definition Object" $ paramsDefinitionExample <=> paramsDefinitionExampleJSON   describe "Responses Definition Object" $ responsesDefinitionExample <=> responsesDefinitionExampleJSON   describe "Security Definitions Object" $ securityDefinitionsExample <=> securityDefinitionsExampleJSON+  describe "OAuth2 Security Definitions with merged Scope" $ oAuth2SecurityDefinitionsExample <=> oAuth2SecurityDefinitionsExampleJSON   describe "Composition Schema Example" $ compositionSchemaExample <=> compositionSchemaExampleJSON   describe "Swagger Object" $ do+    context "Example with no paths" $ emptyPathsFieldExample <=> emptyPathsFieldExampleJSON     context "Todo Example" $ swaggerExample <=> swaggerExampleJSON     context "PetStore Example" $       it "decodes successfully" $ do@@ -154,6 +157,7 @@   & at 200 ?~ "Pet updated."   & at 405 ?~ "Invalid input"   & security .~ [SecurityRequirement [("petstore_auth", ["write:pets", "read:pets"])]]+  & extensions .~ InsOrdHashMap.fromList [("age", Number 42)]   where     stringSchema :: ParamLocation -> ParamOtherSchema     stringSchema loc = mempty@@ -214,7 +218,8 @@         "read:pets"       ]     }-  ]+  ],+  "x-age": 42 } |] @@ -459,8 +464,8 @@ -- Responses Definition object -- ======================================================================= -securityDefinitionsExample :: HashMap Text SecurityScheme-securityDefinitionsExample =+securityDefinitionsExample :: SecurityDefinitions+securityDefinitionsExample = SecurityDefinitions   [ ("api_key", SecurityScheme       { _securitySchemeType = SecuritySchemeApiKey (ApiKeyParams "api_key" ApiKeyHeader)       , _securitySchemeDescription = Nothing })@@ -492,9 +497,61 @@ } |] +oAuth2SecurityDefinitionsReadExample :: SecurityDefinitions+oAuth2SecurityDefinitionsReadExample = SecurityDefinitions+  [ ("petstore_auth", SecurityScheme+      { _securitySchemeType = SecuritySchemeOAuth2 (OAuth2Params+          { _oauth2Flow = OAuth2Implicit "http://swagger.io/api/oauth/dialog"+          , _oauth2Scopes =+              [ ("read:pets", "read your pets") ] } )+      , _securitySchemeDescription = Nothing })+  ]++oAuth2SecurityDefinitionsWriteExample :: SecurityDefinitions+oAuth2SecurityDefinitionsWriteExample = SecurityDefinitions+  [ ("petstore_auth", SecurityScheme+      { _securitySchemeType = SecuritySchemeOAuth2 (OAuth2Params+          { _oauth2Flow = OAuth2Implicit "http://swagger.io/api/oauth/dialog"+          , _oauth2Scopes =+              [ ("write:pets", "modify pets in your account") ] } )+      , _securitySchemeDescription = Nothing })+  ]++oAuth2SecurityDefinitionsExample :: SecurityDefinitions+oAuth2SecurityDefinitionsExample =+  oAuth2SecurityDefinitionsWriteExample <>+  oAuth2SecurityDefinitionsReadExample++oAuth2SecurityDefinitionsExampleJSON :: Value+oAuth2SecurityDefinitionsExampleJSON = [aesonQQ|+{+  "petstore_auth": {+    "type": "oauth2",+    "authorizationUrl": "http://swagger.io/api/oauth/dialog",+    "flow": "implicit",+    "scopes": {+      "write:pets": "modify pets in your account",+      "read:pets": "read your pets"+    }+  }+}+|]+ -- ======================================================================= -- Swagger object -- =======================================================================++emptyPathsFieldExample :: Swagger+emptyPathsFieldExample = mempty++emptyPathsFieldExampleJSON :: Value+emptyPathsFieldExampleJSON = [aesonQQ|+{+  "swagger": "2.0",+  "info": {"version": "", "title": ""},+  "paths": {}+}+|]  swaggerExample :: Swagger swaggerExample = mempty

@@ -1,18 +1,20 @@ module SpecCommon where  import Data.Aeson+import Data.Aeson.Key import Data.ByteString.Builder (toLazyByteString)-import qualified Data.Foldable as F+import qualified Data.Foldable       as F import qualified Data.HashMap.Strict as HashMap-import qualified Data.Vector as Vector+import qualified Data.Aeson.KeyMap   as KM+import qualified Data.Vector         as Vector  import Test.Hspec  isSubJSON :: Value -> Value -> Bool isSubJSON Null _ = True-isSubJSON (Object x) (Object y) = HashMap.keys x == HashMap.keys i && F.and i+isSubJSON (Object x) (Object y) = map toText (KM.keys x) == HashMap.keys i && F.and i   where-    i = HashMap.intersectionWith isSubJSON x y+    i = HashMap.intersectionWith isSubJSON (KM.toHashMapText x) (KM.toHashMapText y) isSubJSON (Array xs) (Array ys) = Vector.length xs == Vector.length ys && F.and (Vector.zipWith isSubJSON xs ys) isSubJSON x y = x == y