swagger2 2.6 → 2.9
raw patch · 23 files changed
Files
- CHANGELOG.md +79/−0
- include/overlapping-compat.h +0/−8
- src/Data/HashMap/Strict/InsOrd/Compat.hs +442/−0
- src/Data/Swagger.hs +8/−31
- src/Data/Swagger/Declare.hs +3/−4
- src/Data/Swagger/Internal.hs +73/−58
- src/Data/Swagger/Internal/AesonUtils.hs +22/−49
- src/Data/Swagger/Internal/ParamSchema.hs +9/−16
- src/Data/Swagger/Internal/Schema.hs +51/−54
- src/Data/Swagger/Internal/Schema/Validation.hs +26/−19
- src/Data/Swagger/Internal/TypeShape.hs +0/−10
- src/Data/Swagger/Internal/Utils.hs +2/−2
- src/Data/Swagger/Lens.hs +14/−22
- src/Data/Swagger/Operation.hs +23/−8
- src/Data/Swagger/Optics.hs +4/−3
- src/Data/Swagger/Schema/Generator.hs +3/−3
- src/Data/Swagger/Schema/Validation.hs +3/−3
- swagger2.cabal +42/−37
- test/Data/Swagger/CommonTestTypes.hs +27/−0
- test/Data/Swagger/Schema/ValidationSpec.hs +13/−5
- test/Data/Swagger/SchemaSpec.hs +2/−1
- test/Data/SwaggerSpec.hs +17/−1
- test/SpecCommon.hs +6/−4
CHANGELOG.md view
@@ -1,3 +1,82 @@+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 ---
− include/overlapping-compat.h
@@ -1,8 +0,0 @@-#if __GLASGOW_HASKELL__ >= 710-#define OVERLAPPABLE_ {-# OVERLAPPABLE #-}-#define OVERLAPPING_ {-# OVERLAPPING #-}-#else-{-# LANGUAGE OverlappingInstances #-}-#define OVERLAPPABLE_-#define OVERLAPPING_-#endif
+ src/Data/HashMap/Strict/InsOrd/Compat.hs view
@@ -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
src/Data/Swagger.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} -- | -- Module: Data.Swagger -- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>@@ -125,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@@ -145,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.@@ -154,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: --@@ -186,14 +185,14 @@ -- -- >>> :{ -- 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@@ -295,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': --
src/Data/Swagger/Declare.hs view
@@ -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.
src/Data/Swagger/Internal.hs view
@@ -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@@ -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@.@@ -832,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 -- =======================================================================@@ -928,7 +938,7 @@ SecurityDefinitions $ InsOrdHashMap.unionWith (<>) sd1 sd2 instance Monoid SecurityDefinitions where- mempty = SecurityDefinitions $ InsOrdHashMap.empty+ mempty = SecurityDefinitions InsOrdHashMap.empty mappend = (<>) -- =======================================================================@@ -959,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 @@ -1060,7 +1070,7 @@ instance ToJSON OAuth2Params where toJSON = sopSwaggerGenericToJSON- DEFINE_TOENCODING+ toEncoding = sopSwaggerGenericToEncoding instance ToJSON SecuritySchemeType where toJSON SecuritySchemeBasic@@ -1073,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>.@@ -1117,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 ]@@ -1125,23 +1138,27 @@ 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@@ -1293,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@@ -1305,8 +1322,23 @@ 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 @@ -1366,23 +1398,6 @@ instance FromJSON AdditionalProperties where 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"
src/Data/Swagger/Internal/AesonUtils.hs view
@@ -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
src/Data/Swagger/Internal/ParamSchema.hs view
@@ -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)@@ -235,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 "."@@ -246,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)@@ -277,7 +270,7 @@ -- | -- >>> encode $ toParamSchema (Proxy :: Proxy ())--- "{\"type\":\"string\",\"enum\":[\"_\"]}"+-- "{\"enum\":[\"_\"],\"type\":\"string\"}" instance ToParamSchema () where toParamSchema _ = mempty & type_ ?~ SwaggerString@@ -293,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
src/Data/Swagger/Internal/Schema.hs view
@@ -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@@ -147,10 +147,6 @@ Proxy a -> Declare (Definitions Schema) NamedSchema declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions -instance ToSchema TimeOfDay where- declareNamedSchema _ = pure $ named "TimeOfDay" $ timeSchema "hh:MM:ss"- & example ?~ toJSON (TimeOfDay 12 33 15)- -- | Convert a type into a schema and declare all used schema definitions. declareSchema :: ToSchema a => Proxy a -> Declare (Definitions Schema) Schema declareSchema = fmap _namedSchemaSchema . declareNamedSchema@@ -328,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@@ -353,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)@@ -362,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@@ -403,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)@@ -411,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@@ -490,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) @@ -505,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 "."@@ -515,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)) @@ -523,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@@ -538,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."@@ -643,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.@@ -702,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@@ -738,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.@@ -804,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@@ -859,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
src/Data/Swagger/Internal/Schema/Validation.hs view
@@ -35,7 +35,7 @@ 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.Proxy import Data.Scientific (Scientific, isInteger)@@ -50,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:@@ -101,33 +102,33 @@ -- <BLANKLINE> -- Swagger Schema: -- {--- "required": [--- "name",--- "phone"--- ],--- "type": "object", -- "properties": {--- "phone": {--- "$ref": "#/definitions/Phone"--- }, -- "name": { -- "type": "string"+-- },+-- "phone": {+-- "$ref": "#/definitions/Phone" -- }--- }+-- },+-- "required": [+-- "name",+-- "phone"+-- ],+-- "type": "object" -- } -- <BLANKLINE> -- Swagger Description Context: -- { -- "Phone": {--- "required": [--- "value"--- ],--- "type": "object", -- "properties": { -- "value": { -- "type": "string" -- }--- }+-- },+-- "required": [+-- "value"+-- ],+-- "type": "object" -- } -- } -- <BLANKLINE>@@ -375,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@@ -476,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- bad -> invalid $ "expected JSON value of type " ++ showType bad+ (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 ->
src/Data/Swagger/Internal/TypeShape.hs view
@@ -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--
src/Data/Swagger/Internal/Utils.hs view
@@ -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)
src/Data/Swagger/Lens.hs view
@@ -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>@@ -118,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
src/Data/Swagger/Operation.hs view
@@ -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
src/Data/Swagger/Optics.hs view
@@ -15,6 +15,7 @@ -- library. -- -- >>> import Data.Aeson+-- >>> import qualified Data.HashMap.Strict.InsOrd.Compat as IOHM -- >>> import Optics.Core -- >>> :set -XOverloadedLabels --@@ -22,14 +23,14 @@ -- -- >>> :{ -- 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\"}}}" -- -- For convenience optics are defined as /labels/. It means that field accessor -- names can be overloaded for different types. One such common field is
src/Data/Swagger/Schema/Generator.hs view
@@ -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
src/Data/Swagger/Schema/Validation.hs view
@@ -71,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'@
swagger2.cabal view
@@ -1,6 +1,6 @@ cabal-version: >=1.10 name: swagger2-version: 2.6+version: 2.9 synopsis: Swagger 2.0 data model category: Web, Swagger@@ -22,23 +22,26 @@ README.md , CHANGELOG.md , examples/*.hs- , include/overlapping-compat.h tested-with:- GHC ==8.0.2- || ==8.2.2- || ==8.4.4- || ==8.6.5- || ==8.8.1- || ==8.10.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@@ -61,38 +64,37 @@ -- GHC boot libraries build-depends:- base >=4.9 && <4.15- , bytestring >=0.10.4.0 && <0.11- , containers >=0.5.5.1 && <0.7- , template-haskell >=2.9.0.0 && <2.17- , 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.12- , 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.3 && <0.3- , lens >=4.16.1 && <4.20- , network >=2.6.3.5 && <3.2- , optics-core >=0.2 && <0.4- , optics-th >=0.2 && <0.4+ , 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 @@ -104,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@@ -123,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@@ -144,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
test/Data/Swagger/CommonTestTypes.hs view
@@ -15,6 +15,7 @@ import Data.Proxy import Data.Set (Set) import qualified Data.Text as Text+import Data.Word import GHC.Generics import Data.Swagger@@ -675,5 +676,31 @@ { "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"] } |]
test/Data/Swagger/Schema/ValidationSpec.hs view
@@ -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
test/Data/Swagger/SchemaSpec.hs view
@@ -9,7 +9,7 @@ import Control.Lens ((^.)) import Data.Aeson (Value)-import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap+import qualified Data.HashMap.Strict.InsOrd.Compat as InsOrdHashMap import Data.Proxy import Data.Set (Set) import qualified Data.Text as Text@@ -85,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))
test/Data/SwaggerSpec.hs view
@@ -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) @@ -46,6 +47,7 @@ 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@@ -155,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@@ -215,7 +218,8 @@ "read:pets" ] }- ]+ ],+ "x-age": 42 } |] @@ -536,6 +540,18 @@ -- ======================================================================= -- Swagger object -- =======================================================================++emptyPathsFieldExample :: Swagger+emptyPathsFieldExample = mempty++emptyPathsFieldExampleJSON :: Value+emptyPathsFieldExampleJSON = [aesonQQ|+{+ "swagger": "2.0",+ "info": {"version": "", "title": ""},+ "paths": {}+}+|] swaggerExample :: Swagger swaggerExample = mempty
test/SpecCommon.hs view
@@ -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