swagger2 2.1.6 → 2.9
raw patch · 28 files changed
Files
- CHANGELOG.md +174/−0
- examples/hackage.hs +1/−1
- include/overlapping-compat.h +0/−8
- src/Data/HashMap/Strict/InsOrd/Compat.hs +442/−0
- src/Data/Swagger.hs +17/−34
- src/Data/Swagger/Declare.hs +7/−13
- src/Data/Swagger/Internal.hs +217/−85
- src/Data/Swagger/Internal/AesonUtils.hs +29/−43
- src/Data/Swagger/Internal/ParamSchema.hs +52/−41
- src/Data/Swagger/Internal/Schema.hs +193/−113
- src/Data/Swagger/Internal/Schema/Validation.hs +248/−55
- src/Data/Swagger/Internal/TypeShape.hs +0/−10
- src/Data/Swagger/Internal/Utils.hs +2/−3
- src/Data/Swagger/Lens.hs +24/−26
- src/Data/Swagger/Operation.hs +28/−13
- src/Data/Swagger/Optics.hs +598/−0
- src/Data/Swagger/Schema.hs +11/−0
- src/Data/Swagger/Schema/Generator.hs +114/−0
- src/Data/Swagger/Schema/Validation.hs +13/−4
- src/Data/Swagger/SchemaOptions.hs +29/−0
- swagger2.cabal +93/−53
- test/Data/Swagger/CommonTestTypes.hs +706/−0
- test/Data/Swagger/ParamSchemaSpec.hs +8/−84
- test/Data/Swagger/Schema/GeneratorSpec.hs +168/−0
- test/Data/Swagger/Schema/ValidationSpec.hs +135/−45
- test/Data/Swagger/SchemaSpec.hs +13/−547
- test/Data/SwaggerSpec.hs +103/−32
- test/SpecCommon.hs +6/−4
CHANGELOG.md view
@@ -1,3 +1,177 @@+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+---++- Allow hashable-1.3, semigroups-0.19, network-3.1, time-1.9, generics-sop-0.5+- Tags aren't sorted+ (see [#165](https://github.com/GetShopTV/swagger2/issues/165))+- Schema type is optional+ (see [#138](https://github.com/GetShopTV/swagger2/issues/138), [#164](https://github.com/GetShopTV/swagger2/pull/164))+- Take concrete 'Proxy' as argument+ (see [#180](https://github.com/GetShopTV/swagger2/pull/180))+- GHC-8.8 preparations++2.3.1.1+-------++- Allow `network-3.0`++2.3.1+-----++- Add a quickcheck generator for aeson Values that match a swagger schema+ (see [#162](https://github.com/GetShopTV/swagger2/pull/162))+- Add `ToParamSchema` instance for `SetCookie`+ (see [#173](https://github.com/GetShopTV/swagger2/pull/173))+- Make nullary schemas valid+ (see [#168](https://github.com/GetShopTV/swagger2/pull/168))++2.3.0.1+-------++- Support GHC-8.6++2.3+---++Major changes:++- Add support for `additionalProperties` with `Bool` value (see [#159](https://github.com/GetShopTV/swagger2/pull/159));+- Add `ToSchema` `Object` instance (for aeson's `Object`) (see [`d72466a`](https://github.com/GetShopTV/swagger2/commit/d72466a));++Dependencies and CI:++- Aeson 1.4 (see [#158](https://github.com/GetShopTV/swagger2/pull/158));+- Update .travis.yml (see [#160](https://github.com/GetShopTV/swagger2/pull/160));+- Allow network 2.7 (see [#155](https://github.com/GetShopTV/swagger2/pull/155));+- Allow lens-4.17 (see [#161](https://github.com/GetShopTV/swagger2/pull/161));++2.2.2+-----++* Add `ToSchema Version` instance+* Use base-compat-batteries (0.10)+* PVP bounds++2.2.1+-----++* Add `Semigroup` instances+* GHC-8.4 compatibility+* `Schema (NonEmpty a) instance (see [#141](https://github.com/GetShopTV/swagger2/pull/141))+* Fix optional property for unary records (see [#142](https://github.com/GetShopTV/swagger2/issues/142))+* Add `fromAesonOptions` helper (see [#146](https://github.com/GetShopTV/swagger2/issues/139))+* Fix non-termination when using `datatypeNameModifier` with recursive data types (see [#132](https://github.com/GetShopTV/swagger2/issues/132))++2.2+---++* Treat unknown properties as validation errors in `validateToJSON` (see [#126](https://github.com/GetShopTV/swagger2/pull/126));+* Add `validateJSON` and `validateJSONWithPatternChecker` to validate JSON `Value` against `Schema` without classes (see [#126](https://github.com/GetShopTV/swagger2/pull/126));+* Add more `Schema` helpers (see [#126](https://github.com/GetShopTV/swagger2/pull/126)):+ * `genericNameSchema` — to give a custom schema `Generic`-based name;+ * `genericDeclareNamedSchemaNewtype` — to derive `NamedSchema` for `newtype`s;+ * `declareSchemaBoundedEnumKeyMapping` — to derive more specific `Schema` for maps with `Bounded` `Enum` keys;+* Add a few tests with invalid `Schema`.+ 2.1.6 -----
examples/hackage.hs view
@@ -27,7 +27,7 @@ usernameSchema <- declareSchemaRef (Proxy :: Proxy Username) useridSchema <- declareSchemaRef (Proxy :: Proxy Int) return $ NamedSchema (Just "UserSummary") $ mempty- & type_ .~ SwaggerObject+ & type_ ?~ SwaggerObject & properties .~ [ ("summaryUsername", usernameSchema ) , ("summaryUserid" , useridSchema )
− 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>@@ -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,@@ -77,6 +77,7 @@ SwaggerItems(..), Xml(..), Pattern,+ AdditionalProperties(..), -- ** Responses Responses(..),@@ -87,6 +88,7 @@ SecurityScheme(..), SecuritySchemeType(..), SecurityRequirement(..),+ SecurityDefinitions(..), -- *** API key ApiKeyParams(..),@@ -111,6 +113,7 @@ ) where import Data.Swagger.Lens+import Data.Swagger.Optics () import Data.Swagger.Operation import Data.Swagger.ParamSchema import Data.Swagger.Schema@@ -121,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@@ -141,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.@@ -150,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: --@@ -174,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@@ -203,7 +208,7 @@ -- "{\"description\":\"No content\"}" -- >>> :{ -- encode $ (mempty :: Schema)--- & type_ .~ SwaggerBoolean+-- & type_ ?~ SwaggerBoolean -- & description ?~ "To be or not to be" -- :} -- "{\"description\":\"To be or not to be\",\"type\":\"boolean\"}"@@ -212,7 +217,7 @@ -- 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+-- >>> encode $ (mempty :: Header) & type_ ?~ SwaggerNumber -- "{\"type\":\"number\"}" -- -- Additionally, to simplify working with @'Response'@, both @'Operation'@ and @'Responses'@@@ -274,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@@ -289,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)@@ -29,7 +28,6 @@ import Control.Monad.Trans.Writer.Lazy as Lazy import Control.Monad.Trans.Writer.Strict as Strict import Data.Functor.Identity-import Data.Monoid -- | A declare monad transformer parametrized by: --@@ -50,18 +48,18 @@ pure x = DeclareT (\_ -> pure (mempty, x)) DeclareT df <*> DeclareT dx = DeclareT $ \d -> do ~(d', f) <- df d- ~(d'', x) <- dx (d <> d')- return (d' <> d'', f x)+ ~(d'', x) <- dx (mappend d d')+ return (mappend d' d'', f x) instance (Applicative m, Monad m, Monoid d) => Monad (DeclareT d m) where return x = DeclareT (\_ -> pure (mempty, x)) DeclareT dx >>= f = DeclareT $ \d -> do ~(d', x) <- dx d- ~(d'', y) <- runDeclareT (f x) (d <> d')- return (d' <> d'', y)+ ~(d'', y) <- runDeclareT (f x) (mappend d d')+ 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:@@ -104,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.@@ -160,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
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,23 +25,29 @@ 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.Monoid+import Data.Maybe (mapMaybe)+import Data.Monoid (Monoid (..))+import Data.Semigroup.Compat (Semigroup (..)) import Data.Scientific (Scientific)-import Data.Set (Set) import Data.String (IsString(..)) import Data.Text (Text) import qualified Data.Text as Text import GHC.Generics (Generic)-import Network (HostName, PortNumber)+import Network.Socket (HostName, PortNumber) 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@@ -56,14 +59,12 @@ ,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+-- >>> import Data.Aeson+ -- | A list of definitions that can be used in references. type Definitions = InsOrdHashMap Text @@ -111,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@@ -124,7 +125,7 @@ -- Not all tags that are used by the Operation Object must be declared. -- The tags that are not declared may be organized randomly or based on the tools' logic. -- Each tag name in the list MUST be unique.- , _swaggerTags :: Set Tag+ , _swaggerTags :: InsOrdHashSet Tag -- | Additional external documentation. , _swaggerExternalDocs :: Maybe ExternalDocs@@ -246,7 +247,7 @@ data Operation = Operation { -- | A list of tags for API documentation control. -- Tags can be used for logical grouping of operations by resources or any other qualifier.- _operationTags :: Set TagName+ _operationTags :: InsOrdHashSet TagName -- | A short summary of what the operation does. -- For maximum readability in the swagger-ui, this field SHOULD be less than 120 characters.@@ -300,10 +301,14 @@ -- 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] }- deriving (Eq, Show, Monoid, Typeable)+ deriving (Eq, Show, Semigroup, Monoid, Typeable) mimeListConstr :: Constr mimeListConstr = mkConstr mimeListDataType "MimeList" ["getMimeList"] Prefix@@ -367,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@@ -375,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@@ -410,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 @@ -426,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@@ -512,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@.@@ -556,7 +555,7 @@ , _schemaAllOf :: Maybe [Referenced Schema] , _schemaProperties :: InsOrdHashMap Text (Referenced Schema)- , _schemaAdditionalProperties :: Maybe (Referenced Schema)+ , _schemaAdditionalProperties :: Maybe AdditionalProperties , _schemaDiscriminator :: Maybe Text , _schemaReadOnly :: Maybe Bool@@ -588,7 +587,7 @@ -- Unlike JSON Schema this value MUST conform to the defined type for this parameter. _paramSchemaDefault :: Maybe Value - , _paramSchemaType :: SwaggerType t+ , _paramSchemaType :: Maybe (SwaggerType t) , _paramSchemaFormat :: Maybe Format , _paramSchemaItems :: Maybe (SwaggerItems t) , _paramSchemaMaximum :: Maybe Scientific@@ -605,7 +604,7 @@ , _paramSchemaMultipleOf :: Maybe Scientific } deriving (Eq, Show, Generic, Typeable) -deriving instance (Typeable k, Data (SwaggerType k), Data (SwaggerItems k)) => Data (ParamSchema k)+deriving instance (Typeable k, Data (Maybe (SwaggerType k)), Data (SwaggerItems k)) => Data (ParamSchema k) data Xml = Xml { -- | Replaces the name of the element/attribute used for the described schema property.@@ -749,12 +748,28 @@ , _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). newtype SecurityRequirement = SecurityRequirement { getSecurityRequirement :: InsOrdHashMap Text [Text]- } deriving (Eq, Read, Show, Monoid, ToJSON, FromJSON, Data, Typeable)+ } deriving (Eq, Read, Show, Semigroup, Monoid, ToJSON, FromJSON, Data, Typeable) -- | Tag name. type TagName = Text@@ -773,6 +788,8 @@ , _tagExternalDocs :: Maybe ExternalDocs } deriving (Eq, Ord, Show, Generic, Data, Typeable) +instance Hashable Tag+ instance IsString Tag where fromString s = Tag (fromString s) Nothing Nothing @@ -786,6 +803,8 @@ , _externalDocsUrl :: URL } deriving (Eq, Ord, Show, Generic, Data, Typeable) +instance Hashable ExternalDocs+ -- | A simple object to allow referencing other definitions in the specification. -- It can be used to reference parameters and responses that are defined at the top level for reuse. newtype Reference = Reference { getReference :: Text }@@ -799,68 +818,129 @@ instance IsString a => IsString (Referenced a) where fromString = Inline . fromString -newtype URL = URL { getUrl :: Text } deriving (Eq, Ord, Show, ToJSON, FromJSON, Data, Typeable)+newtype URL = URL { getUrl :: Text } deriving (Eq, Ord, Show, Hashable, ToJSON, FromJSON, Data, Typeable) +data AdditionalProperties+ = AdditionalPropertiesAllowed Bool+ | 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 -- ======================================================================= +instance Semigroup Swagger where+ (<>) = genericMappend instance Monoid Swagger where mempty = genericMempty- mappend = genericMappend+ mappend = (<>) +instance Semigroup Info where+ (<>) = genericMappend instance Monoid Info where mempty = genericMempty- mappend = genericMappend+ mappend = (<>) +instance Semigroup Contact where+ (<>) = genericMappend instance Monoid Contact where mempty = genericMempty- mappend = genericMappend+ mappend = (<>) +instance Semigroup PathItem where+ (<>) = genericMappend instance Monoid PathItem where mempty = genericMempty- mappend = genericMappend+ mappend = (<>) +instance Semigroup Schema where+ (<>) = genericMappend instance Monoid Schema where mempty = genericMempty- mappend = genericMappend+ mappend = (<>) +instance Semigroup (ParamSchema t) where+ (<>) = genericMappend instance Monoid (ParamSchema t) where mempty = genericMempty- mappend = genericMappend+ mappend = (<>) +instance Semigroup Param where+ (<>) = genericMappend instance Monoid Param where mempty = genericMempty- mappend = genericMappend+ mappend = (<>) +instance Semigroup ParamOtherSchema where+ (<>) = genericMappend instance Monoid ParamOtherSchema where mempty = genericMempty- mappend = genericMappend+ mappend = (<>) +instance Semigroup Header where+ (<>) = genericMappend instance Monoid Header where mempty = genericMempty- mappend = genericMappend+ mappend = (<>) +instance Semigroup Responses where+ (<>) = genericMappend instance Monoid Responses where mempty = genericMempty- mappend = genericMappend+ mappend = (<>) +instance Semigroup Response where+ (<>) = genericMappend instance Monoid Response where mempty = genericMempty- mappend = genericMappend+ mappend = (<>) +instance Semigroup ExternalDocs where+ (<>) = genericMappend instance Monoid ExternalDocs where mempty = genericMempty- mappend = genericMappend+ mappend = (<>) +instance Semigroup Operation where+ (<>) = genericMappend instance Monoid Operation where mempty = genericMempty- mappend = genericMappend+ mappend = (<>) +instance Semigroup Example where+ (<>) = genericMappend instance Monoid Example where mempty = genericMempty- mappend = genericMappend+ 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 -- =======================================================================@@ -875,6 +955,8 @@ instance SwaggerMonoid Response instance SwaggerMonoid ExternalDocs instance SwaggerMonoid Operation+instance SwaggerMonoid SecurityDefinitions+instance (Eq a, Hashable a) => SwaggerMonoid (InsOrdHashSet a) instance SwaggerMonoid MimeList deriving instance SwaggerMonoid URL@@ -887,13 +969,13 @@ 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 instance Monoid a => SwaggerMonoid (Referenced a) where swaggerMempty = Inline mempty- swaggerMappend (Inline x) (Inline y) = Inline (x <> y)+ swaggerMappend (Inline x) (Inline y) = Inline (mappend x y) swaggerMappend _ y = y instance SwaggerMonoid ParamAnySchema where@@ -988,7 +1070,7 @@ instance ToJSON OAuth2Params where toJSON = sopSwaggerGenericToJSON- DEFINE_TOENCODING+ toEncoding = sopSwaggerGenericToEncoding instance ToJSON SecuritySchemeType where toJSON SecuritySchemeBasic@@ -1001,26 +1083,40 @@ <+> 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>.+--+-- >>> encode (SwaggerItemsArray [])+-- "{\"example\":[],\"items\":{},\"maxItems\":0}"+-- instance ToJSON (ParamSchema t) => ToJSON (SwaggerItems t) where toJSON (SwaggerItemsPrimitive fmt schema) = object [ "collectionFormat" .= fmt , "items" .= schema ] toJSON (SwaggerItemsObject x) = object [ "items" .= x ]+ toJSON (SwaggerItemsArray []) = object+ [ "items" .= object []+ , "maxItems" .= (0 :: Int)+ , "example" .= Array mempty+ ] toJSON (SwaggerItemsArray x) = object [ "items" .= x ] instance ToJSON Host where@@ -1034,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 ]@@ -1042,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 ] @@ -1096,6 +1199,10 @@ toJSON = sopSwaggerGenericToJSONWithOpts $ mkSwaggerAesonOptions "paramSchema" & saoSubObject ?~ "items" +instance ToJSON AdditionalProperties where+ toJSON (AdditionalPropertiesAllowed b) = toJSON b+ toJSON (AdditionalPropertiesSchema s) = toJSON s+ -- ======================================================================= -- Manual FromJSON instances -- =======================================================================@@ -1133,7 +1240,13 @@ parseJSON = sopSwaggerGenericParseJSON instance FromJSON Schema where- parseJSON = sopSwaggerGenericParseJSON+ parseJSON = fmap nullaryCleanup . sopSwaggerGenericParseJSON+ where nullaryCleanup :: Schema -> Schema+ nullaryCleanup s@Schema{_schemaParamSchema=ps} =+ if _paramSchemaItems ps == Just (SwaggerItemsArray [])+ then s { _schemaExample = Nothing+ , _schemaParamSchema = ps { _paramSchemaMaxItems = Nothing } }+ else s instance FromJSON Header where parseJSON = sopSwaggerGenericParseJSON@@ -1148,8 +1261,21 @@ <$> o .:? "collectionFormat" <*> ((o .: "items" >>= parseJSON) <|> fail ("foo" ++ show o)) +-- |+--+-- >>> decode "{}" :: Maybe (SwaggerItems 'SwaggerKindSchema)+-- Just (SwaggerItemsArray [])+--+-- >>> eitherDecode "{\"$ref\":\"#/definitions/example\"}" :: Either String (SwaggerItems 'SwaggerKindSchema)+-- Right (SwaggerItemsObject (Ref (Reference {getReference = "example"})))+--+-- >>> eitherDecode "[{\"$ref\":\"#/definitions/example\"}]" :: Either String (SwaggerItems 'SwaggerKindSchema)+-- Right (SwaggerItemsArray [Ref (Reference {getReference = "example"})])+-- instance FromJSON (SwaggerItems 'SwaggerKindSchema) where- parseJSON js@(Object _) = SwaggerItemsObject <$> parseJSON js+ parseJSON js@(Object obj)+ | null obj = pure $ SwaggerItemsArray [] -- Nullary schema.+ | otherwise = SwaggerItemsObject <$> parseJSON js parseJSON js@(Array _) = SwaggerItemsArray <$> parseJSON js parseJSON _ = empty @@ -1184,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@@ -1196,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@@ -1251,22 +1395,9 @@ instance FromJSON (ParamSchema 'SwaggerKindSchema) where parseJSON = sopSwaggerGenericParseJSON ----------------------------------------------------------------------------------- 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 FromJSON AdditionalProperties where+ parseJSON (Bool b) = pure $ AdditionalPropertiesAllowed b+ parseJSON js = AdditionalPropertiesSchema <$> parseJSON js instance HasSwaggerAesonOptions Header where swaggerAesonOptions _ = mkSwaggerAesonOptions "header" & saoSubObject ?~ "paramSchema"@@ -1308,3 +1439,4 @@ instance AesonDefaultValue MimeList where defaultValue = Just mempty instance AesonDefaultValue Info instance AesonDefaultValue ParamLocation+instance AesonDefaultValue SecurityDefinitions where defaultValue = Just $ SecurityDefinitions mempty
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,12 +45,8 @@ 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--#if MIN_VERSION_aeson(0,10,0)-import Data.Aeson (Encoding, pairs, (.=), Series)-import Data.Monoid ((<>))-#endif+import qualified Data.HashMap.Strict.InsOrd.Compat as InsOrd+import qualified Data.HashSet.InsOrd as InsOrdHS ------------------------------------------------------------------------------- -- SwaggerAesonOptions@@ -68,10 +66,10 @@ makeLenses ''SwaggerAesonOptions class (Generic a, All2 AesonDefaultValue (Code a)) => HasSwaggerAesonOptions a where- swaggerAesonOptions :: proxy a -> SwaggerAesonOptions+ swaggerAesonOptions :: Proxy a -> SwaggerAesonOptions -- So far we use only default definitions- aesonDefaults :: proxy a -> POP Maybe (Code a)+ aesonDefaults :: Proxy a -> POP Maybe (Code a) aesonDefaults _ = hcpure (Proxy :: Proxy AesonDefaultValue) defaultValue -------------------------------------------------------------------------------@@ -86,6 +84,7 @@ instance AesonDefaultValue (Maybe a) where defaultValue = Just Nothing instance AesonDefaultValue [a] where defaultValue = Just [] instance AesonDefaultValue (Set.Set a) where defaultValue = Just Set.empty+instance AesonDefaultValue (InsOrdHS.InsOrdHashSet k) where defaultValue = Just InsOrdHS.empty instance AesonDefaultValue (InsOrd.InsOrdHashMap k v) where defaultValue = Just InsOrd.empty -------------------------------------------------------------------------------@@ -111,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@@ -133,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@@ -145,7 +144,7 @@ -> DatatypeInfo '[xs] -> POP Maybe '[xs] -> [Pair]-sopSwaggerGenericToJSON' opts (SOP (Z fields)) (ADT _ _ (Record _ fieldsInfo :* Nil)) (POP (defs :* Nil)) =+sopSwaggerGenericToJSON' opts (SOP (Z fields)) (ADT _ _ (Record _ fieldsInfo :* Nil) _) (POP (defs :* Nil)) = sopSwaggerGenericToJSON'' opts fields fieldsInfo defs sopSwaggerGenericToJSON' _ _ _ _ = error "sopSwaggerGenericToJSON: unsupported type" @@ -162,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)@@ -208,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@@ -221,7 +217,7 @@ -> DatatypeInfo '[xs] -> POP Maybe '[xs] -> Parser (SOP I '[xs])-sopSwaggerGenericParseJSON' opts obj (ADT _ _ (Record _ fieldsInfo :* Nil)) (POP (defs :* Nil)) =+sopSwaggerGenericParseJSON' opts obj (ADT _ _ (Record _ fieldsInfo :* Nil) _) (POP (defs :* Nil)) = SOP . Z <$> sopSwaggerGenericParseJSON'' opts obj fieldsInfo defs sopSwaggerGenericParseJSON' _ _ _ _ = error "sopSwaggerGenericParseJSON: unsupported type" @@ -239,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@@ -251,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)@@ -264,8 +257,6 @@ -- ToEncoding ------------------------------------------------------------------------------- -#if MIN_VERSION_aeson(0,10,0)- sopSwaggerGenericToEncoding :: forall a xs. ( HasDatatypeInfo a@@ -278,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@@ -293,7 +284,7 @@ -> DatatypeInfo '[xs] -> POP Maybe '[xs] -> Series-sopSwaggerGenericToEncoding' opts (SOP (Z fields)) (ADT _ _ (Record _ fieldsInfo :* Nil)) (POP (defs :* Nil)) =+sopSwaggerGenericToEncoding' opts (SOP (Z fields)) (ADT _ _ (Record _ fieldsInfo :* Nil) _) (POP (defs :* Nil)) = sopSwaggerGenericToEncoding'' opts fields fieldsInfo defs sopSwaggerGenericToEncoding' _ _ _ _ = error "sopSwaggerGenericToEncoding: unsupported type" @@ -310,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@@ -39,38 +35,37 @@ import qualified Data.Vector.Primitive as VP import qualified Data.Vector.Storable as VS import qualified Data.Vector.Unboxed as VU-import Numeric.Natural+import Data.Version (Version)+import Numeric.Natural.Compat (Natural) import Data.Word import Data.UUID.Types (UUID)+import Web.Cookie (SetCookie) import Data.Swagger.Internal 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 binaryParamSchema = mempty- & type_ .~ SwaggerString+ & type_ ?~ SwaggerString & format ?~ "binary" -- | Default schema for binary data (base64 encoded). byteParamSchema :: ParamSchema t byteParamSchema = mempty- & type_ .~ SwaggerString+ & type_ ?~ SwaggerString & format ?~ "byte" -- | Default schema for password string. -- @"password"@ format is used to hint UIs the input needs to be obscured. passwordParamSchema :: ParamSchema t passwordParamSchema = mempty- & type_ .~ SwaggerString+ & type_ ?~ SwaggerString & format ?~ "password" -- | Convert a type into a plain @'ParamSchema'@.@@ -86,7 +81,7 @@ -- -- instance ToParamSchema Direction where -- toParamSchema _ = mempty--- & type_ .~ SwaggerString+-- & type_ ?~ SwaggerString -- & enum_ ?~ [ \"Up\", \"Down\" ] -- @ --@@ -113,22 +108,22 @@ -- -- >>> encode $ toParamSchema (Proxy :: Proxy Integer) -- "{\"type\":\"integer\"}"- toParamSchema :: proxy a -> ParamSchema t- default toParamSchema :: (Generic a, GToParamSchema (Rep a)) => proxy a -> ParamSchema t+ toParamSchema :: Proxy a -> ParamSchema t+ default toParamSchema :: (Generic a, GToParamSchema (Rep a)) => Proxy a -> ParamSchema t toParamSchema = genericToParamSchema defaultSchemaOptions -instance OVERLAPPING_ ToParamSchema String where- toParamSchema _ = mempty & type_ .~ SwaggerString+instance {-# OVERLAPPING #-} ToParamSchema String where+ toParamSchema _ = mempty & type_ ?~ SwaggerString instance ToParamSchema Bool where- toParamSchema _ = mempty & type_ .~ SwaggerBoolean+ toParamSchema _ = mempty & type_ ?~ SwaggerBoolean instance ToParamSchema Integer where- toParamSchema _ = mempty & type_ .~ SwaggerInteger+ toParamSchema _ = mempty & type_ ?~ SwaggerInteger instance ToParamSchema Natural where toParamSchema _ = mempty- & type_ .~ SwaggerInteger+ & type_ ?~ SwaggerInteger & minimum_ ?~ 0 & exclusiveMinimum ?~ False @@ -145,46 +140,50 @@ 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) -- "{\"maximum\":127,\"minimum\":-128,\"type\":\"integer\"}"-toParamSchemaBoundedIntegral :: forall proxy a t. (Bounded a, Integral a) => proxy a -> ParamSchema t+toParamSchemaBoundedIntegral :: forall a t. (Bounded a, Integral a) => Proxy a -> ParamSchema t toParamSchemaBoundedIntegral _ = mempty- & type_ .~ SwaggerInteger+ & type_ ?~ SwaggerInteger & minimum_ ?~ fromInteger (toInteger (minBound :: a)) & maximum_ ?~ fromInteger (toInteger (maxBound :: a)) instance ToParamSchema Char where toParamSchema _ = mempty- & type_ .~ SwaggerString+ & type_ ?~ SwaggerString & maxLength ?~ 1 & minLength ?~ 1 instance ToParamSchema Scientific where- toParamSchema _ = mempty & type_ .~ SwaggerNumber+ toParamSchema _ = mempty & type_ ?~ SwaggerNumber instance HasResolution a => ToParamSchema (Fixed a) where toParamSchema _ = mempty- & type_ .~ SwaggerNumber+ & type_ ?~ SwaggerNumber & multipleOf ?~ (recip . fromInteger $ resolution (Proxy :: Proxy a)) instance ToParamSchema Double where toParamSchema _ = mempty- & type_ .~ SwaggerNumber+ & type_ ?~ SwaggerNumber & format ?~ "double" instance ToParamSchema Float where toParamSchema _ = mempty- & type_ .~ SwaggerNumber+ & type_ ?~ SwaggerNumber & format ?~ "float" timeParamSchema :: String -> ParamSchema t timeParamSchema fmt = mempty- & type_ .~ SwaggerString+ & type_ ?~ SwaggerString & format ?~ T.pack fmt -- | Format @"date"@ corresponds to @yyyy-mm-dd@ format.@@ -192,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@@ -218,8 +223,15 @@ instance ToParamSchema TL.Text where toParamSchema _ = toParamSchema (Proxy :: Proxy String) -#if __GLASGOW_HASKELL__ < 800-#else+instance ToParamSchema Version where+ toParamSchema _ = mempty+ & type_ ?~ SwaggerString+ & pattern ?~ "^\\d+(\\.\\d+)*$"++instance ToParamSchema SetCookie where+ toParamSchema _ = mempty+ & type_ ?~ SwaggerString+ type family ToParamSchemaByteStringError bs where ToParamSchemaByteStringError bs = TypeError ( 'Text "Impossible to have an instance " :<>: ShowType (ToParamSchema bs) :<>: Text "."@@ -228,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)@@ -242,7 +253,7 @@ instance ToParamSchema a => ToParamSchema [a] where toParamSchema _ = mempty- & type_ .~ SwaggerArray+ & type_ ?~ SwaggerArray & items ?~ SwaggerItemsPrimitive Nothing (toParamSchema (Proxy :: Proxy a)) instance ToParamSchema a => ToParamSchema (V.Vector a) where toParamSchema _ = toParamSchema (Proxy :: Proxy [a])@@ -259,15 +270,15 @@ -- | -- >>> encode $ toParamSchema (Proxy :: Proxy ())--- "{\"type\":\"string\",\"enum\":[\"_\"]}"+-- "{\"enum\":[\"_\"],\"type\":\"string\"}" instance ToParamSchema () where toParamSchema _ = mempty- & type_ .~ SwaggerString+ & type_ ?~ SwaggerString & enum_ ?~ ["_"] instance ToParamSchema UUID where toParamSchema _ = mempty- & type_ .~ SwaggerString+ & type_ ?~ SwaggerString & format ?~ "uuid" -- | A configurable generic @'ParamSchema'@ creator.@@ -275,12 +286,12 @@ -- >>> :set -XDeriveGeneric -- >>> data Color = Red | Blue deriving Generic -- >>> encode $ genericToParamSchema defaultSchemaOptions (Proxy :: Proxy Color)--- "{\"type\":\"string\",\"enum\":[\"Red\",\"Blue\"]}"-genericToParamSchema :: forall proxy a t. (Generic a, GToParamSchema (Rep a)) => SchemaOptions -> proxy a -> ParamSchema t+-- "{\"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 class GToParamSchema (f :: * -> *) where- gtoParamSchema :: SchemaOptions -> proxy f -> ParamSchema t -> ParamSchema t+ gtoParamSchema :: SchemaOptions -> Proxy f -> ParamSchema t -> ParamSchema t instance GToParamSchema f => GToParamSchema (D1 d f) where gtoParamSchema opts _ = gtoParamSchema opts (Proxy :: Proxy f)@@ -298,14 +309,14 @@ gtoParamSchema opts _ = genumParamSchema opts (Proxy :: Proxy (f :+: g)) class GEnumParamSchema (f :: * -> *) where- genumParamSchema :: SchemaOptions -> proxy f -> ParamSchema t -> ParamSchema t+ genumParamSchema :: SchemaOptions -> Proxy f -> ParamSchema t -> ParamSchema t instance (GEnumParamSchema f, GEnumParamSchema g) => GEnumParamSchema (f :+: g) where genumParamSchema opts _ = genumParamSchema opts (Proxy :: Proxy f) . genumParamSchema opts (Proxy :: Proxy g) instance Constructor c => GEnumParamSchema (C1 c U1) where genumParamSchema opts _ s = s- & type_ .~ SwaggerString+ & type_ ?~ SwaggerString & enum_ %~ addEnumValue tag where tag = toJSON (constructorTagModifier opts (conName (Proxy3 :: Proxy3 c f p)))
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,8 +27,8 @@ import Data.Data.Lens (template) import Control.Monad-import Control.Monad.Writer-import Data.Aeson (ToJSON (..), ToJSONKey (..), ToJSONKeyFunction (..), Value (..))+import Control.Monad.Writer hiding (First, Last)+import Data.Aeson (ToJSON (..), ToJSONKey (..), ToJSONKeyFunction (..), Value (..), Object(..)) import Data.Char import Data.Data (Data) import Data.Foldable (traverse_)@@ -40,15 +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@@ -56,7 +55,8 @@ import qualified Data.Vector.Primitive as VP import qualified Data.Vector.Storable as VS import qualified Data.Vector.Unboxed as VU-import Numeric.Natural+import Data.Version (Version)+import Numeric.Natural.Compat (Natural) import Data.Word import GHC.Generics import qualified Data.UUID.Types as UUID@@ -69,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@@ -109,7 +111,7 @@ -- declareNamedSchema _ = do -- doubleSchema <- declareSchemaRef (Proxy :: Proxy Double) -- return $ NamedSchema (Just \"Coord\") $ mempty--- & type_ .~ SwaggerObject+-- & type_ ?~ SwaggerObject -- & properties .~ -- [ (\"x\", doubleSchema) -- , (\"y\", doubleSchema)@@ -140,13 +142,13 @@ -- together with all used definitions. -- Note that the schema itself is included in definitions -- only if it is recursive (and thus needs its definition in scope).- declareNamedSchema :: proxy a -> Declare (Definitions Schema) NamedSchema+ declareNamedSchema :: Proxy a -> Declare (Definitions Schema) NamedSchema default declareNamedSchema :: (Generic a, GToSchema (Rep a), TypeHasSimpleShape a "genericDeclareNamedSchemaUnrestricted") =>- proxy a -> Declare (Definitions Schema) NamedSchema+ Proxy a -> Declare (Definitions Schema) NamedSchema declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions -- | Convert a type into a schema and declare all used schema definitions.-declareSchema :: ToSchema a => proxy a -> Declare (Definitions Schema) Schema+declareSchema :: ToSchema a => Proxy a -> Declare (Definitions Schema) Schema declareSchema = fmap _namedSchemaSchema . declareNamedSchema -- | Convert a type into an optionally named schema.@@ -160,7 +162,7 @@ -- Just "Day" -- >>> encode (toNamedSchema (Proxy :: Proxy Day) ^. schema) -- "{\"example\":\"2016-07-22\",\"format\":\"date\",\"type\":\"string\"}"-toNamedSchema :: ToSchema a => proxy a -> NamedSchema+toNamedSchema :: ToSchema a => Proxy a -> NamedSchema toNamedSchema = undeclare . declareNamedSchema -- | Get type's schema name according to its @'ToSchema'@ instance.@@ -170,7 +172,7 @@ -- -- >>> schemaName (Proxy :: Proxy UTCTime) -- Just "UTCTime"-schemaName :: ToSchema a => proxy a -> Maybe T.Text+schemaName :: ToSchema a => Proxy a -> Maybe T.Text schemaName = _namedSchemaName . toNamedSchema -- | Convert a type into a schema.@@ -180,7 +182,7 @@ -- -- >>> encode $ toSchema (Proxy :: Proxy [Day]) -- "{\"items\":{\"$ref\":\"#/definitions/Day\"},\"type\":\"array\"}"-toSchema :: ToSchema a => proxy a -> Schema+toSchema :: ToSchema a => Proxy a -> Schema toSchema = _namedSchemaSchema . toNamedSchema -- | Convert a type into a referenced schema if possible.@@ -191,7 +193,7 @@ -- -- >>> encode $ toSchemaRef (Proxy :: Proxy Day) -- "{\"$ref\":\"#/definitions/Day\"}"-toSchemaRef :: ToSchema a => proxy a -> Referenced Schema+toSchemaRef :: ToSchema a => Proxy a -> Referenced Schema toSchemaRef = undeclare . declareSchemaRef -- | Convert a type into a referenced schema if possible@@ -201,7 +203,7 @@ -- Schema definitions are typically declared for every referenced schema. -- If @'declareSchemaRef'@ returns a reference, a corresponding schema -- will be declared (regardless of whether it is recusive or not).-declareSchemaRef :: ToSchema a => proxy a -> Declare (Definitions Schema) (Referenced Schema)+declareSchemaRef :: ToSchema a => Proxy a -> Declare (Definitions Schema) (Referenced Schema) declareSchemaRef proxy = do case toNamedSchema proxy of NamedSchema (Just name) schema -> do@@ -263,7 +265,7 @@ -- -- __WARNING:__ @'toInlinedSchema'@ will produce infinite schema -- when inlining recursive schemas.-toInlinedSchema :: ToSchema a => proxy a -> Schema+toInlinedSchema :: ToSchema a => Proxy a -> Schema toInlinedSchema proxy = inlineAllSchemas defs schema where (defs, schema) = runDeclare (declareSchema proxy) mempty@@ -292,20 +294,20 @@ -- | Default schema for binary data (any sequence of octets). binarySchema :: Schema binarySchema = mempty- & type_ .~ SwaggerString+ & type_ ?~ SwaggerString & format ?~ "binary" -- | Default schema for binary data (base64 encoded). byteSchema :: Schema byteSchema = mempty- & type_ .~ SwaggerString+ & type_ ?~ SwaggerString & format ?~ "byte" -- | Default schema for password string. -- @"password"@ format is used to hint UIs the input needs to be obscured. passwordSchema :: Schema passwordSchema = mempty- & type_ .~ SwaggerString+ & type_ ?~ SwaggerString & format ?~ "password" -- | Make an unrestrictive sketch of a @'Schema'@ based on a @'ToJSON'@ instance.@@ -322,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@@ -331,12 +338,12 @@ sketch js@(Bool _) = go js sketch js = go js & example ?~ js - go Null = mempty & type_ .~ SwaggerNull- go (Bool _) = mempty & type_ .~ SwaggerBoolean- go (String _) = mempty & type_ .~ SwaggerString- go (Number _) = mempty & type_ .~ SwaggerNumber+ go Null = mempty & type_ ?~ SwaggerNull+ go (Bool _) = mempty & type_ ?~ SwaggerBoolean+ go (String _) = mempty & type_ ?~ SwaggerString+ go (Number _) = mempty & type_ ?~ SwaggerNumber go (Array xs) = mempty- & type_ .~ SwaggerArray+ & type_ ?~ SwaggerArray & items ?~ case ischema of Just s -> SwaggerItemsObject (Inline s) _ -> SwaggerItemsArray (map Inline ys)@@ -347,8 +354,8 @@ ischema = case ys of (z:_) | allSame -> Just z _ -> Nothing- go (Object o) = mempty- & type_ .~ SwaggerObject+ go (Object o') = let o = KM.toHashMapText o' in mempty+ & type_ ?~ SwaggerObject & required .~ HashMap.keys o & properties .~ fmap (Inline . go) (InsOrdHashMap.fromHashMap o) @@ -356,39 +363,44 @@ -- 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- go Null = mempty & type_ .~ SwaggerNull+ go Null = mempty & type_ ?~ SwaggerNull go js@(Bool _) = mempty- & type_ .~ SwaggerBoolean+ & type_ ?~ SwaggerBoolean & enum_ ?~ [js] go js@(String s) = mempty- & type_ .~ SwaggerString+ & type_ ?~ SwaggerString & maxLength ?~ fromIntegral (T.length s) & minLength ?~ fromIntegral (T.length s) & pattern ?~ s & enum_ ?~ [js] go js@(Number n) = mempty- & type_ .~ SwaggerNumber+ & type_ ?~ SwaggerNumber & maximum_ ?~ n & minimum_ ?~ n & multipleOf ?~ n & enum_ ?~ [js] go js@(Array xs) = mempty- & type_ .~ SwaggerArray+ & type_ ?~ SwaggerArray & maxItems ?~ fromIntegral sz & minItems ?~ fromIntegral sz & items ?~ SwaggerItemsArray (map (Inline . go) (V.toList xs))@@ -397,27 +409,27 @@ where sz = length xs allUnique = sz == HashSet.size (HashSet.fromList (V.toList xs))- go js@(Object o) = mempty- & type_ .~ SwaggerObject+ go js@(Object o') = let o = KM.toHashMapText o' in mempty+ & type_ ?~ SwaggerObject & required .~ names & properties .~ fmap (Inline . go) (InsOrdHashMap.fromHashMap o) & maxProperties ?~ fromIntegral (length names) & 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+ 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+ & 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@@ -464,7 +476,7 @@ timeSchema :: T.Text -> Schema timeSchema fmt = mempty- & type_ .~ SwaggerString+ & type_ ?~ SwaggerString & format ?~ fmt -- | Format @"date"@ corresponds to @yyyy-mm-dd@ format.@@ -484,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) @@ -497,8 +521,8 @@ instance ToSchema T.Text where declareNamedSchema = plain . paramSchemaToSchema instance ToSchema TL.Text where declareNamedSchema = plain . paramSchemaToSchema -#if __GLASGOW_HASKELL__ < 800-#else+instance ToSchema Version where declareNamedSchema = plain . paramSchemaToSchema+ type family ToSchemaByteStringError bs where ToSchemaByteStringError bs = TypeError ( Text "Impossible to have an instance " :<>: ShowType (ToSchema bs) :<>: Text "."@@ -507,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)) @@ -515,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@@ -524,29 +546,17 @@ declareObjectMapSchema = do schema <- declareSchemaRef (Proxy :: Proxy v) return $ unnamed $ mempty- & type_ .~ SwaggerObject- & additionalProperties ?~ schema+ & type_ ?~ SwaggerObject+ & additionalProperties ?~ AdditionalPropertiesSchema schema 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+ declareNamedSchema _ = pure $ NamedSchema (Just "Object") $ mempty+ & type_ ?~ SwaggerObject+ & description ?~ "Arbitrary JSON object."+ & additionalProperties ?~ AdditionalPropertiesAllowed True instance ToSchema a => ToSchema (V.Vector a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a]) instance ToSchema a => ToSchema (VU.Vector a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a])@@ -561,6 +571,13 @@ instance ToSchema a => ToSchema (HashSet a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Set a)) +-- | @since 2.2.1+instance ToSchema a => ToSchema (NonEmpty a) where+ declareNamedSchema _ = do+ schema <- declareSchema (Proxy :: Proxy [a])+ return $ unnamed $ schema+ & minItems .~ Just 1+ instance ToSchema All where declareNamedSchema = plain . paramSchemaToSchema instance ToSchema Any where declareNamedSchema = plain . paramSchemaToSchema @@ -576,74 +593,136 @@ -- -- >>> encode $ toSchemaBoundedIntegral (Proxy :: Proxy Int16) -- "{\"maximum\":32767,\"minimum\":-32768,\"type\":\"integer\"}"-toSchemaBoundedIntegral :: forall a proxy. (Bounded a, Integral a) => proxy a -> Schema+toSchemaBoundedIntegral :: forall a. (Bounded a, Integral a) => Proxy a -> Schema toSchemaBoundedIntegral _ = mempty- & type_ .~ SwaggerInteger+ & type_ ?~ SwaggerInteger & minimum_ ?~ fromInteger (toInteger (minBound :: a)) & maximum_ ?~ fromInteger (toInteger (maxBound :: a)) -- | Default generic named schema for @'Bounded'@, @'Integral'@ types.-genericToNamedSchemaBoundedIntegral :: forall a d f proxy.+genericToNamedSchemaBoundedIntegral :: forall a d f. ( Bounded a, Integral a , Generic a, Rep a ~ D1 d f, Datatype d)- => SchemaOptions -> proxy a -> NamedSchema+ => SchemaOptions -> Proxy a -> NamedSchema genericToNamedSchemaBoundedIntegral opts proxy- = NamedSchema (gdatatypeSchemaName opts (Proxy :: Proxy d)) (toSchemaBoundedIntegral proxy)+ = genericNameSchema opts proxy (toSchemaBoundedIntegral proxy) +-- | Declare a named schema for a @newtype@ wrapper.+genericDeclareNamedSchemaNewtype :: forall a d c s i inner.+ (Generic a, Datatype d, Rep a ~ D1 d (C1 c (S1 s (K1 i inner))))+ => SchemaOptions -- ^ How to derive the name.+ -> (Proxy inner -> Declare (Definitions Schema) Schema) -- ^ How to create a schema for the wrapped type.+ -> Proxy a+ -> Declare (Definitions Schema) NamedSchema+genericDeclareNamedSchemaNewtype opts f proxy = genericNameSchema opts proxy <$> f (Proxy :: Proxy inner)++-- | Declare 'Schema' for a mapping with 'Bounded' 'Enum' keys.+-- This makes a much more useful schema when there aren't many options for key values.+--+-- >>> data ButtonState = Neutral | Focus | Active | Hover | Disabled deriving (Show, Bounded, Enum, Generic)+-- >>> instance ToJSON ButtonState+-- >>> instance ToSchema ButtonState+-- >>> instance ToJSONKey ButtonState where toJSONKey = toJSONKeyText (T.pack . show)+-- >>> type ImageUrl = T.Text+-- >>> encode $ toSchemaBoundedEnumKeyMapping (Proxy :: Proxy (Map ButtonState ImageUrl))+-- "{\"properties\":{\"Neutral\":{\"type\":\"string\"},\"Focus\":{\"type\":\"string\"},\"Active\":{\"type\":\"string\"},\"Hover\":{\"type\":\"string\"},\"Disabled\":{\"type\":\"string\"}},\"type\":\"object\"}"+--+-- Note: this is only useful when @key@ is encoded with 'ToJSONKeyText'.+-- If it is encoded with 'ToJSONKeyValue' then a regular schema for @[(key, value)]@ is used.+declareSchemaBoundedEnumKeyMapping :: forall map key value.+ (Bounded key, Enum key, ToJSONKey key, ToSchema key, ToSchema value)+ => Proxy (map key value) -> Declare (Definitions Schema) Schema+declareSchemaBoundedEnumKeyMapping _ = case toJSONKey :: ToJSONKeyFunction key of+ ToJSONKeyText keyToText _ -> objectSchema keyToText+ ToJSONKeyValue _ _ -> declareSchema (Proxy :: Proxy [(key, value)])+ where+ objectSchema keyToText = do+ valueRef <- declareSchemaRef (Proxy :: Proxy value)+ let allKeys = [minBound..maxBound :: key]+ mkPair k = (toText $ keyToText k, valueRef)+ return $ mempty+ & type_ ?~ SwaggerObject+ & properties .~ InsOrdHashMap.fromList (map mkPair allKeys)++-- | A 'Schema' for a mapping with 'Bounded' 'Enum' keys.+-- This makes a much more useful schema when there aren't many options for key values.+--+-- >>> data ButtonState = Neutral | Focus | Active | Hover | Disabled deriving (Show, Bounded, Enum, Generic)+-- >>> instance ToJSON ButtonState+-- >>> instance ToSchema ButtonState+-- >>> instance ToJSONKey ButtonState where toJSONKey = toJSONKeyText (T.pack . show)+-- >>> type ImageUrl = T.Text+-- >>> encode $ toSchemaBoundedEnumKeyMapping (Proxy :: Proxy (Map ButtonState ImageUrl))+-- "{\"properties\":{\"Neutral\":{\"type\":\"string\"},\"Focus\":{\"type\":\"string\"},\"Active\":{\"type\":\"string\"},\"Hover\":{\"type\":\"string\"},\"Disabled\":{\"type\":\"string\"}},\"type\":\"object\"}"+--+-- Note: this is only useful when @key@ is encoded with 'ToJSONKeyText'.+-- If it is encoded with 'ToJSONKeyValue' then a regular schema for @[(key, value)]@ is used.+toSchemaBoundedEnumKeyMapping :: forall map key value.+ (Bounded key, Enum key, ToJSONKey key, ToSchema key, ToSchema value)+ => Proxy (map key value) -> Schema+toSchemaBoundedEnumKeyMapping = flip evalDeclare mempty . declareSchemaBoundedEnumKeyMapping+ -- | A configurable generic @'Schema'@ creator. genericDeclareSchema :: (Generic a, GToSchema (Rep a), TypeHasSimpleShape a "genericDeclareSchemaUnrestricted") =>- SchemaOptions -> proxy a -> Declare (Definitions Schema) Schema+ SchemaOptions -> Proxy a -> Declare (Definitions Schema) Schema genericDeclareSchema = genericDeclareSchemaUnrestricted -- | A configurable generic @'NamedSchema'@ creator. -- This function applied to @'defaultSchemaOptions'@ -- is used as the default for @'declareNamedSchema'@ -- when the type is an instance of @'Generic'@.-genericDeclareNamedSchema :: forall a proxy. (Generic a, GToSchema (Rep a), TypeHasSimpleShape a "genericDeclareNamedSchemaUnrestricted") =>- SchemaOptions -> proxy a -> Declare (Definitions Schema) NamedSchema+genericDeclareNamedSchema :: (Generic a, GToSchema (Rep a), TypeHasSimpleShape a "genericDeclareNamedSchemaUnrestricted") =>+ SchemaOptions -> Proxy a -> Declare (Definitions Schema) NamedSchema genericDeclareNamedSchema = genericDeclareNamedSchemaUnrestricted -- | A configurable generic @'Schema'@ creator. -- -- Unlike 'genericDeclareSchema' also works for mixed sum types. -- Use with care since some Swagger tools do not support well schemas for mixed sum types.-genericDeclareSchemaUnrestricted :: (Generic a, GToSchema (Rep a)) => SchemaOptions -> proxy a -> Declare (Definitions Schema) Schema+genericDeclareSchemaUnrestricted :: (Generic a, GToSchema (Rep a)) => SchemaOptions -> Proxy a -> Declare (Definitions Schema) Schema genericDeclareSchemaUnrestricted opts proxy = _namedSchemaSchema <$> genericDeclareNamedSchemaUnrestricted opts proxy -- | A configurable generic @'NamedSchema'@ creator. -- -- Unlike 'genericDeclareNamedSchema' also works for mixed sum types. -- Use with care since some Swagger tools do not support well schemas for mixed sum types.-genericDeclareNamedSchemaUnrestricted :: forall a proxy. (Generic a, GToSchema (Rep a)) =>- SchemaOptions -> proxy a -> Declare (Definitions Schema) NamedSchema+genericDeclareNamedSchemaUnrestricted :: forall a. (Generic a, GToSchema (Rep a)) =>+ SchemaOptions -> Proxy a -> Declare (Definitions Schema) NamedSchema genericDeclareNamedSchemaUnrestricted opts _ = gdeclareNamedSchema opts (Proxy :: Proxy (Rep a)) mempty -gdatatypeSchemaName :: forall proxy d. Datatype d => SchemaOptions -> proxy d -> Maybe T.Text-gdatatypeSchemaName opts _ = case name of+-- | Derive a 'Generic'-based name for a datatype and assign it to a given 'Schema'.+genericNameSchema :: forall a d f.+ (Generic a, Rep a ~ D1 d f, Datatype d)+ => SchemaOptions -> Proxy a -> Schema -> NamedSchema+genericNameSchema opts _ = NamedSchema (gdatatypeSchemaName opts (Proxy :: Proxy d))++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- name = datatypeNameModifier opts (datatypeName (Proxy3 :: Proxy3 d f a))+ orig = datatypeName (Proxy3 :: Proxy3 d f a)+ name = datatypeNameModifier opts orig -- | Lift a plain @'ParamSchema'@ into a model @'NamedSchema'@.-paramSchemaToNamedSchema :: forall a d f proxy.- (ToParamSchema a, Generic a, Rep a ~ D1 d f, Datatype d)- => SchemaOptions -> proxy a -> NamedSchema-paramSchemaToNamedSchema opts proxy = NamedSchema (gdatatypeSchemaName opts (Proxy :: Proxy d)) (paramSchemaToSchema proxy)+paramSchemaToNamedSchema :: (ToParamSchema a, Generic a, Rep a ~ D1 d f, Datatype d) =>+ SchemaOptions -> Proxy a -> NamedSchema+paramSchemaToNamedSchema opts proxy = genericNameSchema opts proxy (paramSchemaToSchema proxy) -- | Lift a plain @'ParamSchema'@ into a model @'Schema'@.-paramSchemaToSchema :: forall a proxy. ToParamSchema a => proxy a -> Schema-paramSchemaToSchema _ = mempty & paramSchema .~ toParamSchema (Proxy :: Proxy a)+paramSchemaToSchema :: ToParamSchema a => Proxy a -> Schema+paramSchemaToSchema proxy = mempty & paramSchema .~ toParamSchema proxy nullarySchema :: Schema nullarySchema = mempty- & type_ .~ SwaggerArray+ & type_ ?~ SwaggerArray & items ?~ SwaggerItemsArray [] -gtoNamedSchema :: GToSchema f => SchemaOptions -> proxy f -> NamedSchema+gtoNamedSchema :: GToSchema f => SchemaOptions -> Proxy f -> NamedSchema gtoNamedSchema opts proxy = undeclare $ gdeclareNamedSchema opts proxy mempty -gdeclareSchema :: GToSchema f => SchemaOptions -> proxy f -> Declare (Definitions Schema) Schema+gdeclareSchema :: GToSchema f => SchemaOptions -> Proxy f -> Declare (Definitions Schema) Schema gdeclareSchema opts proxy = _namedSchemaSchema <$> gdeclareNamedSchema opts proxy mempty instance (GToSchema f, GToSchema g) => GToSchema (f :*: g) where@@ -656,14 +735,14 @@ 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.-instance (Selector s, GToSchema f) => GToSchema (C1 c (S1 s f)) where+instance (Selector s, GToSchema f, GToSchema (S1 s f)) => GToSchema (C1 c (S1 s f)) where gdeclareNamedSchema opts _ s | unwrapUnaryRecords opts = fieldSchema | otherwise =@@ -677,7 +756,7 @@ recordSchema = gdeclareNamedSchema opts (Proxy :: Proxy (S1 s f)) s fieldSchema = gdeclareNamedSchema opts (Proxy :: Proxy f) s -gdeclareSchemaRef :: GToSchema a => SchemaOptions -> proxy a -> Declare (Definitions Schema) (Referenced Schema)+gdeclareSchemaRef :: GToSchema a => SchemaOptions -> Proxy a -> Declare (Definitions Schema) (Referenced Schema) gdeclareSchemaRef opts proxy = do case gtoNamedSchema opts proxy of NamedSchema (Just name) schema -> do@@ -708,12 +787,12 @@ return $ if T.null fname then schema- & type_ .~ SwaggerArray+ & type_ ?~ SwaggerArray & items %~ appendItem ref & maxItems %~ Just . maybe 1 (+1) -- increment maxItems & minItems %~ Just . maybe 1 (+1) -- increment minItems else schema- & type_ .~ SwaggerObject+ & type_ ?~ SwaggerObject & properties . at fname ?~ ref & if isRequiredField then required %~ (++ [fname])@@ -722,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@@ -741,7 +820,7 @@ where gdeclareNamedSchema = gdeclareNamedSumSchema -gdeclareNamedSumSchema :: GSumToSchema f => SchemaOptions -> proxy f -> Schema -> Declare (Definitions Schema) NamedSchema+gdeclareNamedSumSchema :: GSumToSchema f => SchemaOptions -> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema gdeclareNamedSumSchema opts proxy s | allNullaryToStringTag opts && allNullary = pure $ unnamed (toStringTag sumSchema) | otherwise = (unnamed . fst) <$> runWriterT declareSumSchema@@ -750,34 +829,34 @@ (sumSchema, All allNullary) = undeclare (runWriterT declareSumSchema) toStringTag schema = mempty- & type_ .~ SwaggerString+ & type_ ?~ SwaggerString & enum_ ?~ map toJSON (schema ^.. properties.ifolded.asIndex) type AllNullary = All class GSumToSchema (f :: * -> *) where- gsumToSchema :: SchemaOptions -> proxy f -> Schema -> WriterT AllNullary (Declare (Definitions Schema)) Schema+ gsumToSchema :: SchemaOptions -> Proxy f -> Schema -> WriterT AllNullary (Declare (Definitions Schema)) Schema instance (GSumToSchema f, GSumToSchema g) => GSumToSchema (f :+: g) where gsumToSchema opts _ = gsumToSchema opts (Proxy :: Proxy f) >=> gsumToSchema opts (Proxy :: Proxy g) -gsumConToSchemaWith :: forall c f proxy. (GToSchema (C1 c f), Constructor c) =>- Referenced Schema -> SchemaOptions -> proxy (C1 c f) -> Schema -> Schema+gsumConToSchemaWith :: forall c f. (GToSchema (C1 c f), Constructor c) =>+ Referenced Schema -> SchemaOptions -> Proxy (C1 c f) -> Schema -> Schema gsumConToSchemaWith ref opts _ schema = schema- & type_ .~ SwaggerObject+ & type_ ?~ SwaggerObject & properties . at tag ?~ ref & maxProperties ?~ 1 & minProperties ?~ 1 where tag = T.pack (constructorTagModifier opts (conName (Proxy3 :: Proxy3 c f p))) -gsumConToSchema :: forall c f proxy. (GToSchema (C1 c f), Constructor c) =>- SchemaOptions -> proxy (C1 c f) -> Schema -> Declare (Definitions Schema) Schema+gsumConToSchema :: (GToSchema (C1 c f), Constructor c) =>+ SchemaOptions -> Proxy (C1 c f) -> Schema -> Declare (Definitions Schema) Schema gsumConToSchema opts proxy schema = do 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@@ -797,3 +876,4 @@ -- $setup -- >>> import Data.Swagger -- >>> import Data.Aeson (encode)+-- >>> import Data.Aeson.Types (toJSONKeyText)
src/Data/Swagger/Internal/Schema/Validation.hs view
@@ -1,15 +1,17 @@-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE GADTs #-}+{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE PackageImports #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE UndecidableInstances #-} -- | -- Module: Data.Swagger.Internal.Schema.Validation -- Copyright: (c) 2015 GetShopTV@@ -20,28 +22,35 @@ -- Validate JSON values with Swagger Schema. module Data.Swagger.Internal.Schema.Validation where -import Control.Applicative-import Control.Lens-import Control.Monad (when)+import Prelude ()+import Prelude.Compat -import Data.Aeson hiding (Result)-import Data.Foldable (traverse_, for_, sequenceA_)-import Data.HashMap.Strict (HashMap)-import qualified Data.HashMap.Strict as HashMap+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.Compat as InsOrdHashMap import qualified "unordered-containers" Data.HashSet as HashSet-import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap-import Data.Monoid-import Data.Proxy-import Data.Scientific (Scientific, isInteger)-import Data.Text (Text)-import qualified Data.Text as Text-import Data.Vector (Vector)-import qualified Data.Vector as Vector+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 -import Data.Swagger.Declare-import Data.Swagger.Internal-import Data.Swagger.Internal.Schema-import Data.Swagger.Lens+import Data.Swagger.Declare+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:@@ -50,22 +59,119 @@ -- -- /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'@.-validateToJSONWithPatternChecker :: forall a. (ToJSON a, ToSchema a) =>- (Pattern -> Text -> Bool) -> a -> [ValidationError]-validateToJSONWithPatternChecker checker x =+-- 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)) == []+--+-- /NOTE:/ @'validateJSON'@ does not perform string pattern validation.+-- See @'validateJSONWithPatternChecker'@.+validateJSON :: Definitions Schema -> Schema -> Value -> [ValidationError]+validateJSON = validateJSONWithPatternChecker (\_pattern _str -> True)++-- | Validate JSON @'Value'@ agains Swagger @'ToSchema'@ for a given value and pattern checker.+--+-- For validation without patterns see @'validateJSON'@.+validateJSONWithPatternChecker :: (Pattern -> Text -> Bool) -> Definitions Schema -> Schema -> Value -> [ValidationError]+validateJSONWithPatternChecker checker defs sch js = case runValidation (validateWithSchema js) cfg sch of Failed xs -> xs Passed _ -> mempty where- (defs, sch) = runDeclare (declareSchema (Proxy :: Proxy a)) mempty- js = toJSON x cfg = defaultConfig { configPatternChecker = checker , configDefinitions = defs }@@ -158,12 +264,18 @@ -- | Validate schema's property given a lens into that property -- and property checker.-check :: Lens' s (Maybe a) -> (a -> Validation s ()) -> Validation s ()-check l g = withSchema $ \sch ->+checkMissing :: Validation s () -> Lens' s (Maybe a) -> (a -> Validation s ()) -> Validation s ()+checkMissing missing l g = withSchema $ \sch -> case sch ^. l of- Nothing -> valid+ Nothing -> missing Just x -> g x +-- | Validate schema's property given a lens into that property+-- and property checker.+-- If property is missing in schema, consider it valid.+check :: Lens' s (Maybe a) -> (a -> Validation s ()) -> Validation s ()+check = checkMissing valid+ -- | Validate same value with different schema. sub :: t -> Validation t a -> Validation s a sub = lmap . const@@ -264,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@@ -292,34 +404,115 @@ Null | not (k `elem` (sch ^. required)) -> valid -- null is fine for non-required property _ -> case InsOrdHashMap.lookup k (sch ^. properties) of- Nothing -> check additionalProperties $ \s -> validateWithSchemaRef s v+ Nothing -> checkMissing (unknownProperty k) additionalProperties $ validateAdditional k v Just s -> validateWithSchemaRef s v + validateAdditional _ _ (AdditionalPropertiesAllowed True) = valid+ validateAdditional k _ (AdditionalPropertiesAllowed False) = invalid $ "additionalProperties=false but extra property " <> show k <> " found"+ validateAdditional _ v (AdditionalPropertiesSchema s) = validateWithSchemaRef s v++ unknownProperty :: Text -> Validation s a+ unknownProperty pname = invalid $+ "property " <> show pname <> " is found in JSON value, but it is not mentioned in Swagger schema"+ validateEnum :: Value -> Validation (ParamSchema t) () validateEnum value = do check enum_ $ \xs -> when (value `notElem` xs) $ invalid ("expected one of " ++ show (encode xs) ++ " but got " ++ show value) +-- | Infer schema type based on used properties.+--+-- This is like 'inferParamSchemaTypes', but also works for objects:+--+-- >>> inferSchemaTypes <$> decode "{\"minProperties\": 1}"+-- Just [SwaggerObject]+inferSchemaTypes :: Schema -> [SwaggerType 'SwaggerKindSchema]+inferSchemaTypes sch = inferParamSchemaTypes (sch ^. paramSchema) +++ [ SwaggerObject | any ($ sch)+ [ has (additionalProperties._Just)+ , has (maxProperties._Just)+ , has (minProperties._Just)+ , has (properties.folded)+ , has (required.folded) ] ]++-- | Infer schema type based on used properties.+--+-- >>> inferSchemaTypes <$> decode "{\"minLength\": 2}"+-- Just [SwaggerString]+--+-- >>> inferSchemaTypes <$> decode "{\"maxItems\": 0}"+-- Just [SwaggerArray]+--+-- From numeric properties 'SwaggerInteger' type is inferred.+-- If you want 'SwaggerNumber' instead, you must specify it explicitly.+--+-- >>> inferSchemaTypes <$> decode "{\"minimum\": 1}"+-- Just [SwaggerInteger]+inferParamSchemaTypes :: ParamSchema t -> [SwaggerType t]+inferParamSchemaTypes sch = concat+ [ [ SwaggerArray | any ($ sch)+ [ has (items._Just)+ , has (maxItems._Just)+ , has (minItems._Just)+ , has (uniqueItems._Just) ] ]+ , [ SwaggerInteger | any ($ sch)+ [ has (exclusiveMaximum._Just)+ , has (exclusiveMinimum._Just)+ , has (maximum_._Just)+ , has (minimum_._Just)+ , has (multipleOf._Just) ] ]+ , [ SwaggerString | any ($ sch)+ [ has (maxLength._Just)+ , has (minLength._Just)+ , has (pattern._Just) ] ]+ ]+ validateSchemaType :: Value -> Validation Schema () validateSchemaType value = withSchema $ \sch -> case (sch ^. type_, value) of- (SwaggerNull, Null) -> valid- (SwaggerBoolean, Bool _) -> valid- (SwaggerInteger, Number n) -> sub_ paramSchema (validateInteger n)- (SwaggerNumber, Number n) -> sub_ paramSchema (validateNumber n)- (SwaggerString, String s) -> sub_ paramSchema (validateString s)- (SwaggerArray, Array xs) -> sub_ paramSchema (validateArray xs)- (SwaggerObject, Object o) -> validateObject o- (t, _) -> invalid $ "expected JSON value of type " ++ show t+ (Just SwaggerNull, Null) -> valid+ (Just SwaggerBoolean, Bool _) -> valid+ (Just SwaggerInteger, Number n) -> sub_ paramSchema (validateInteger n)+ (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 $ 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 $ 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 -> case (sch ^. type_, value) of- (SwaggerBoolean, Bool _) -> valid- (SwaggerInteger, Number n) -> validateInteger n- (SwaggerNumber, Number n) -> validateNumber n- (SwaggerString, String s) -> validateString s- (SwaggerArray, Array xs) -> validateArray xs- (t, _) -> invalid $ "expected JSON value of type " ++ show t+ (Just SwaggerBoolean, Bool _) -> valid+ (Just SwaggerInteger, Number n) -> validateInteger n+ (Just SwaggerNumber, Number n) -> validateNumber n+ (Just SwaggerString, String s) -> validateString s+ (Just SwaggerArray, Array xs) -> validateArray xs+ (Nothing, Bool _) -> valid+ -- Number by default+ (Nothing, Number n) -> validateNumber n+ (Nothing, String s) -> validateString s+ (Nothing, Array xs) -> validateArray xs+ bad -> invalid $ "expected JSON value of type " ++ showType bad +showType :: (Maybe (SwaggerType t), Value) -> String+showType (Just ty, _) = show ty+showType (Nothing, Null) = "SwaggerNull"+showType (Nothing, Bool _) = "SwaggerBoolean"+showType (Nothing, Number _) = "SwaggerNumber"+showType (Nothing, String _) = "SwaggerString"+showType (Nothing, Array _) = "SwaggerArray"+showType (Nothing, Object _) = "SwaggerObject"
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,10 +18,9 @@ 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.Monoid import Data.Set (Set) import Data.Text (Text) import GHC.Generics
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>@@ -96,13 +94,19 @@ 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-instance HasType Header (SwaggerType ('SwaggerKindNormal Header)) where type_ = paramSchema.type_-instance HasType Schema (SwaggerType 'SwaggerKindSchema) where type_ = paramSchema.type_-instance HasType NamedSchema (SwaggerType 'SwaggerKindSchema) where type_ = paramSchema.type_-instance HasType ParamOtherSchema (SwaggerType 'SwaggerKindParamOtherSchema) where type_ = paramSchema.type_+instance HasType Header (Maybe (SwaggerType ('SwaggerKindNormal Header))) where type_ = paramSchema.type_+instance HasType Schema (Maybe (SwaggerType 'SwaggerKindSchema)) where type_ = paramSchema.type_+instance HasType NamedSchema (Maybe (SwaggerType 'SwaggerKindSchema)) where type_ = paramSchema.type_+instance HasType ParamOtherSchema (Maybe (SwaggerType 'SwaggerKindParamOtherSchema)) where type_ = paramSchema.type_ -- HasDefault instances instance HasDefault Header (Maybe Value) where default_ = paramSchema.default_@@ -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
src/Data/Swagger/Operation.hs view
@@ -17,6 +17,10 @@ applyTags, applyTagsFor, + -- ** Extensions+ addExtensions,+ addExtensionsFor,+ -- ** Responses setResponse, setResponseWith,@@ -34,28 +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.Monoid+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@@ -76,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@@ -107,19 +116,26 @@ 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 applyTagsFor ops ts swag = swag- & ops . tags %~ (<> Set.fromList (map _tagName ts))- & tags %~ (<> Set.fromList ts)+ & ops . tags %~ (<> InsOrdHS.fromList (map _tagName ts))+ & tags %~ (<> InsOrdHS.fromList ts) -- | Construct a response with @'Schema'@ while declaring all -- necessary schema definitions. -- -- >>> encode $ runDeclare (declareResponse (Proxy :: Proxy Day)) mempty -- "[{\"Day\":{\"example\":\"2016-07-22\",\"format\":\"date\",\"type\":\"string\"}},{\"description\":\"\",\"schema\":{\"$ref\":\"#/definitions/Day\"}}]"-declareResponse :: ToSchema a => proxy a -> Declare (Definitions Schema) Response+declareResponse :: ToSchema a => Proxy a -> Declare (Definitions Schema) Response declareResponse proxy = do s <- declareSchemaRef proxy return (mempty & schema ?~ s)@@ -135,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@@ -190,4 +206,3 @@ Nothing -> new -- response name can't be dereferenced, replacing with new response combine (Just (Inline old)) = f old new combine Nothing = new-
+ src/Data/Swagger/Optics.hs view
@@ -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 #-}
src/Data/Swagger/Schema.hs view
@@ -17,8 +17,18 @@ -- * Generic schema encoding genericDeclareNamedSchema, genericDeclareSchema,+ genericDeclareNamedSchemaNewtype,+ genericNameSchema,++ -- ** 'Bounded' 'Integral' genericToNamedSchemaBoundedIntegral, toSchemaBoundedIntegral,++ -- ** 'Bounded' 'Enum' key mappings+ declareSchemaBoundedEnumKeyMapping,+ toSchemaBoundedEnumKeyMapping,++ -- ** Reusing 'ToParamSchema' paramSchemaToNamedSchema, paramSchemaToSchema, @@ -44,6 +54,7 @@ -- * Generic encoding configuration SchemaOptions(..), defaultSchemaOptions,+ fromAesonOptions, ) where import Data.Swagger.Internal.Schema
+ src/Data/Swagger/Schema/Generator.hs view
@@ -0,0 +1,114 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Data.Swagger.Schema.Generator where++import Prelude ()+import Prelude.Compat++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.Compat as M+import Data.Maybe+import Data.Proxy+import Data.Scientific+import qualified Data.Set as S+import Data.Swagger+import Data.Swagger.Declare+import Data.Swagger.Internal.Schema.Validation (inferSchemaTypes)+import qualified Data.Text as T+import qualified Data.Vector as V+import Test.QuickCheck (arbitrary)+import Test.QuickCheck.Gen+import Test.QuickCheck.Property++-- | Note: 'schemaGen' may 'error', if schema type is not specified,+-- and cannot be inferred.+schemaGen :: Definitions Schema -> Schema -> Gen Value+schemaGen _ schema+ | Just cases <- schema ^. paramSchema . enum_ = elements cases+schemaGen defns schema =+ case schema ^. type_ of+ Nothing ->+ case inferSchemaTypes schema of+ [ inferredType ] -> schemaGen defns (schema & type_ ?~ inferredType)+ -- Gen is not MonadFail+ _ -> error "unable to infer schema type"+ Just SwaggerBoolean -> Bool <$> elements [True, False]+ Just SwaggerNull -> pure Null+ Just SwaggerNumber+ | Just min <- schema ^. minimum_+ , Just max <- schema ^. maximum_ ->+ Number . fromFloatDigits <$>+ choose (toRealFloat min, toRealFloat max :: Double)+ | otherwise -> Number .fromFloatDigits <$> (arbitrary :: Gen Double)+ Just SwaggerInteger+ | Just min <- schema ^. minimum_+ , Just max <- schema ^. maximum_ ->+ Number . fromInteger <$>+ choose (truncate min, truncate max)+ | otherwise -> Number . fromInteger <$> arbitrary+ Just SwaggerArray+ | Just 0 <- schema ^. maxLength -> pure $ Array V.empty+ | Just items <- schema ^. items ->+ case items of+ SwaggerItemsObject ref -> do+ size <- getSize+ let itemSchema = dereference defns ref+ minLength' = fromMaybe 0 $ fromInteger <$> schema ^. minItems+ maxLength' = fromMaybe size $ fromInteger <$> schema ^. maxItems+ arrayLength <- choose (minLength', max minLength' maxLength')+ generatedArray <- vectorOf arrayLength $ schemaGen defns itemSchema+ return . Array $ V.fromList generatedArray+ SwaggerItemsArray refs ->+ let itemGens = schemaGen defns . dereference defns <$> refs+ in fmap (Array . V.fromList) $ sequence itemGens+ Just SwaggerString -> do+ size <- getSize+ let minLength' = fromMaybe 0 $ fromInteger <$> schema ^. minLength+ let maxLength' = fromMaybe size $ fromInteger <$> schema ^. maxLength+ length <- choose (minLength', max minLength' maxLength')+ str <- vectorOf length arbitrary+ return . String $ T.pack str+ Just SwaggerObject -> do+ size <- getSize+ let props = dereference defns <$> schema ^. properties+ reqKeys = S.fromList $ schema ^. required+ allKeys = S.fromList . M.keys $ schema ^. properties+ optionalKeys = allKeys S.\\ reqKeys+ minProps' = fromMaybe (length reqKeys) $+ fromInteger <$> schema ^. minProperties+ maxProps' = fromMaybe size $ fromInteger <$> schema ^. maxProperties+ shuffledOptional <- shuffle $ S.toList optionalKeys+ numProps <- choose (minProps', max minProps' maxProps')+ let presentKeys = take numProps $ S.toList reqKeys ++ shuffledOptional+ let presentProps = M.filterWithKey (\k _ -> k `elem` presentKeys) props+ let gens = schemaGen defns <$> presentProps+ additionalGens <- case schema ^. additionalProperties of+ Just (AdditionalPropertiesSchema addlSchema) -> do+ additionalKeys <- sequence . take (numProps - length presentProps) . repeat $ T.pack <$> arbitrary+ return . M.fromList $ zip additionalKeys (repeat . schemaGen defns $ dereference defns addlSchema)+ _ -> return []+ x <- sequence $ gens <> additionalGens+ return . Object . KM.fromHashMapText $ M.toHashMap x+ where+ dereference :: Definitions a -> Referenced a -> a+ dereference _ (Inline a) = a+ dereference defs (Ref (Reference ref)) = fromJust $ M.lookup ref defs++genValue :: (ToSchema a) => Proxy a -> Gen Value+genValue p =+ let (defs, NamedSchema _ schema) = runDeclare (declareNamedSchema p) M.empty+ in schemaGen defs schema++validateFromJSON :: forall a . (ToSchema a, FromJSON a) => Proxy a -> Property+validateFromJSON p = forAll (genValue p) $+ \val -> case parseEither parseJSON val of+ Right (_ :: a) -> succeeded+ Left err -> failed+ { reason = err+ }
src/Data/Swagger/Schema/Validation.hs view
@@ -15,9 +15,18 @@ -- $maybe -- * JSON validation++ ValidationError,++ -- ** Using 'ToJSON' and 'ToSchema'+ validatePrettyToJSON, validateToJSON, validateToJSONWithPatternChecker,- ValidationError,+ renderValidationErrors,++ -- ** Using 'Value' and 'Schema'+ validateJSON,+ validateJSONWithPatternChecker, ) where import Data.Swagger.Internal.Schema.Validation@@ -62,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'@
src/Data/Swagger/SchemaOptions.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE RecordWildCards #-} -- | -- Module: Data.Swagger.SchemaOptions -- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>@@ -6,6 +7,8 @@ -- Generic deriving options for @'ToParamSchema'@ and @'ToSchema'@. module Data.Swagger.SchemaOptions where +import qualified Data.Aeson.Types as Aeson+ -- | Options that specify how to encode your type to Swagger schema. data SchemaOptions = SchemaOptions { -- | Function applied to field labels. Handy for removing common record prefixes for example.@@ -41,3 +44,29 @@ , unwrapUnaryRecords = False } +-- | Convert 'Aeson.Options' to 'SchemaOptions'.+--+-- Specifically the following fields get copied:+--+-- * 'fieldLabelModifier'+-- * 'constructorTagModifier'+-- * 'allNullaryToStringTag'+-- * 'unwrapUnaryRecords'+--+-- Note that these fields have no effect on `SchemaOptions`:+--+-- * 'Aeson.omitNothingFields'+-- * 'Aeson.sumEncoding'+-- * 'Aeson.tagSingleConstructors'+--+-- The rest is defined as in 'defaultSchemaOptions'.+--+-- @since 2.2.1+--+fromAesonOptions :: Aeson.Options -> SchemaOptions+fromAesonOptions opts = defaultSchemaOptions+ { fieldLabelModifier = Aeson.fieldLabelModifier opts+ , constructorTagModifier = Aeson.constructorTagModifier opts+ , allNullaryToStringTag = Aeson.allNullaryToStringTag opts+ , unwrapUnaryRecords = Aeson.unwrapUnaryRecords opts+ }
swagger2.cabal view
@@ -1,11 +1,15 @@+cabal-version: >=1.10 name: swagger2-version: 2.1.6+version: 2.9+ synopsis: Swagger 2.0 data model+category: Web, Swagger description:- This library is inteded to be used for decoding and encoding Swagger 2.0 API+ This library is intended to be used for decoding and encoding Swagger 2.0 API specifications as well as manipulating them. . The original Swagger 2.0 specification is available at http://swagger.io/specification/.+ homepage: https://github.com/GetShopTV/swagger2 bug-reports: https://github.com/GetShopTV/swagger2/issues license: BSD3@@ -13,30 +17,39 @@ author: Nickolay Kudasov maintainer: nickolay@getshoptv.com copyright: (c) 2015-2016, GetShopTV-category: Web, Swagger build-type: Custom extra-source-files: README.md , CHANGELOG.md , examples/*.hs- , include/overlapping-compat.h-cabal-version: >=1.10-tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.1+tested-with:+ 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.2 && <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 Data.Swagger.Schema.Validation Data.Swagger.SchemaOptions @@ -48,68 +61,95 @@ Data.Swagger.Internal.Utils Data.Swagger.Internal.AesonUtils Data.Swagger.Internal.TypeShape- build-depends: base >=4.7 && <4.11- , base-compat >=0.9.1 && <0.10- , aeson >=0.11.2.1- , bytestring- , containers- , hashable- , generics-sop >=0.2 && <0.4- , http-media- , insert-ordered-containers >=0.1.0.0 && <0.3- , lens- , mtl- , network- , scientific- , text- , template-haskell- , time- , transformers- , transformers-compat >= 0.3- , unordered-containers- , vector- , uuid-types >=1.0.2 && <1.1- if !impl(ghc >= 7.10)- build-depends: nats >=1.1.1 && <1.2++ -- GHC boot libraries+ build-depends:+ 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.2.2 && <2.4+ , text >=1.2.3.0 && <2.2++ -- other dependencies+ build-depends:+ 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.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+ , unordered-containers >=0.2.9.0 && <0.3+ , uuid-types >=1.0.3 && <1.1+ , vector >=0.12.0.1 && <0.14+ , QuickCheck >=2.10.1 && <2.17+ default-language: Haskell2010 test-suite spec type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Spec.hs++ -- From library parat -- We need aeson's toEncoding for doctests too- build-depends: base- , base-compat- , aeson >=0.10.0.0- , aeson-qq- , bytestring- , containers- , hashable- , hspec- , insert-ordered-containers- , HUnit- , mtl- , QuickCheck >=2.8.2- , swagger2- , text- , time- , unordered-containers- , vector- , lens+ build-depends:+ base >=4.9 && <4.22+ , swagger2+ , aeson+ , base-compat-batteries+ , bytestring+ , containers+ , hashable+ , insert-ordered-containers+ , lens+ , mtl+ , template-haskell+ , text+ , time+ , unordered-containers+ , vector+ , QuickCheck++ -- test-suite only dependencies+ build-depends:+ hspec >=2.5.5 && <2.12+ , HUnit >=1.6.0.0 && <1.7+ , 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.12+ other-modules: SpecCommon Data.SwaggerSpec+ Data.Swagger.CommonTestTypes Data.Swagger.ParamSchemaSpec Data.Swagger.SchemaSpec Data.Swagger.Schema.ValidationSpec+ Data.Swagger.Schema.GeneratorSpec default-language: Haskell2010- -- https://github.com/haskell/cabal/issues/3708- build-tool-depends:- hspec-discover:hspec-discover 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
@@ -0,0 +1,706 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Data.Swagger.CommonTestTypes where++import Prelude ()+import Prelude.Compat++import Data.Aeson (ToJSON (..), ToJSONKey (..), Value)+import Data.Aeson.QQ.Simple+import Data.Aeson.Types (toJSONKeyText)+import Data.Char+import Data.Map (Map)+import Data.Proxy+import Data.Set (Set)+import qualified Data.Text as Text+import Data.Word+import GHC.Generics++import Data.Swagger++-- ========================================================================+-- Unit type+-- ========================================================================++data Unit = Unit deriving (Generic)+instance ToParamSchema Unit+instance ToSchema Unit++unitSchemaJSON :: Value+unitSchemaJSON = [aesonQQ|+{+ "type": "string",+ "enum": ["Unit"]+}+|]++-- ========================================================================+-- Color (enum)+-- ========================================================================+data Color+ = Red+ | Green+ | Blue+ deriving (Generic)+instance ToParamSchema Color+instance ToSchema Color++colorSchemaJSON :: Value+colorSchemaJSON = [aesonQQ|+{+ "type": "string",+ "enum": ["Red", "Green", "Blue"]+}+|]++-- ========================================================================+-- Shade (paramSchemaToNamedSchema)+-- ========================================================================++data Shade = Dim | Bright deriving (Generic)+instance ToParamSchema Shade++instance ToSchema Shade where declareNamedSchema = pure . paramSchemaToNamedSchema defaultSchemaOptions++shadeSchemaJSON :: Value+shadeSchemaJSON = [aesonQQ|+{+ "type": "string",+ "enum": ["Dim", "Bright"]+}+|]++-- ========================================================================+-- Paint (record with bounded enum property)+-- ========================================================================++newtype Paint = Paint { color :: Color }+ deriving (Generic)+instance ToSchema Paint++paintSchemaJSON :: Value+paintSchemaJSON = [aesonQQ|+{+ "type": "object",+ "properties":+ {+ "color":+ {+ "$ref": "#/definitions/Color"+ }+ },+ "required": ["color"]+}+|]++paintInlinedSchemaJSON :: Value+paintInlinedSchemaJSON = [aesonQQ|+{+ "type": "object",+ "properties":+ {+ "color":+ {+ "type": "string",+ "enum": ["Red", "Green", "Blue"]+ }+ },+ "required": ["color"]+}+|]++-- ========================================================================+-- Status (constructorTagModifier)+-- ========================================================================++data Status+ = StatusOk+ | StatusError+ deriving (Generic)++instance ToParamSchema Status where+ toParamSchema = genericToParamSchema defaultSchemaOptions+ { constructorTagModifier = map toLower . drop (length "Status") }+instance ToSchema Status where+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions+ { constructorTagModifier = map toLower . drop (length "Status") }++statusSchemaJSON :: Value+statusSchemaJSON = [aesonQQ|+{+ "type": "string",+ "enum": ["ok", "error"]+}+|]++-- ========================================================================+-- Email (newtype with unwrapUnaryRecords set to True)+-- ========================================================================++newtype Email = Email { getEmail :: String }+ deriving (Generic)+instance ToParamSchema Email+instance ToSchema Email where+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions+ { unwrapUnaryRecords = True }++emailSchemaJSON :: Value+emailSchemaJSON = [aesonQQ|+{+ "type": "string"+}+|]++-- ========================================================================+-- UserId (non-record newtype)+-- ========================================================================++newtype UserId = UserId Integer+ deriving (Eq, Ord, Generic)+instance ToParamSchema UserId+instance ToSchema UserId++userIdSchemaJSON :: Value+userIdSchemaJSON = [aesonQQ|+{+ "type": "integer"+}+|]++-- ========================================================================+-- UserGroup (set newtype)+-- ========================================================================++newtype UserGroup = UserGroup (Set UserId)+ deriving (Generic)+instance ToSchema UserGroup++userGroupSchemaJSON :: Value+userGroupSchemaJSON = [aesonQQ|+{+ "type": "array",+ "items": { "$ref": "#/definitions/UserId" },+ "uniqueItems": true+}+|]++-- ========================================================================+-- Person (simple record with optional fields)+-- ========================================================================+data Person = Person+ { name :: String+ , phone :: Integer+ , email :: Maybe String+ } deriving (Generic)++instance ToSchema Person++personSchemaJSON :: Value+personSchemaJSON = [aesonQQ|+{+ "type": "object",+ "properties":+ {+ "name": { "type": "string" },+ "phone": { "type": "integer" },+ "email": { "type": "string" }+ },+ "required": ["name", "phone"]+}+|]++-- ========================================================================+-- Player (record newtype)+-- ========================================================================++newtype Player = Player+ { position :: Point+ } deriving (Generic)+instance ToSchema Player++playerSchemaJSON :: Value+playerSchemaJSON = [aesonQQ|+{+ "type": "object",+ "properties":+ {+ "position":+ {+ "$ref": "#/definitions/Point"+ }+ },+ "required": ["position"]+}+|]++newtype Players = Players [Inlined Player]+ deriving (Generic)+instance ToSchema Players++playersSchemaJSON :: Value+playersSchemaJSON = [aesonQQ|+{+ "type": "array",+ "items":+ {+ "type": "object",+ "properties":+ {+ "position":+ {+ "$ref": "#/definitions/Point"+ }+ },+ "required": ["position"]+ }+}+|]++-- ========================================================================+-- Character (sum type with ref and record in alternative)+-- ========================================================================++data Character+ = PC Player+ | NPC { npcName :: String, npcPosition :: Point }+ deriving (Generic)+instance ToSchema Character++characterSchemaJSON :: Value+characterSchemaJSON = [aesonQQ|+{+ "type": "object",+ "properties":+ {+ "PC": { "$ref": "#/definitions/Player" },+ "NPC":+ {+ "type": "object",+ "properties":+ {+ "npcName": { "type": "string" },+ "npcPosition": { "$ref": "#/definitions/Point" }+ },+ "required": ["npcName", "npcPosition"]+ }+ },+ "maxProperties": 1,+ "minProperties": 1+}+|]++characterInlinedSchemaJSON :: Value+characterInlinedSchemaJSON = [aesonQQ|+{+ "type": "object",+ "properties":+ {+ "PC":+ {+ "type": "object",+ "properties":+ {+ "position":+ {+ "type": "object",+ "properties":+ {+ "x": { "type": "number", "format": "double" },+ "y": { "type": "number", "format": "double" }+ },+ "required": ["x", "y"]+ }+ },+ "required": ["position"]+ },+ "NPC":+ {+ "type": "object",+ "properties":+ {+ "npcName": { "type": "string" },+ "npcPosition":+ {+ "type": "object",+ "properties":+ {+ "x": { "type": "number", "format": "double" },+ "y": { "type": "number", "format": "double" }+ },+ "required": ["x", "y"]+ }+ },+ "required": ["npcName", "npcPosition"]+ }+ },+ "maxProperties": 1,+ "minProperties": 1+}+|]++characterInlinedPlayerSchemaJSON :: Value+characterInlinedPlayerSchemaJSON = [aesonQQ|+{+ "type": "object",+ "properties":+ {+ "PC":+ {+ "type": "object",+ "properties":+ {+ "position":+ {+ "$ref": "#/definitions/Point"+ }+ },+ "required": ["position"]+ },+ "NPC":+ {+ "type": "object",+ "properties":+ {+ "npcName": { "type": "string" },+ "npcPosition": { "$ref": "#/definitions/Point" }+ },+ "required": ["npcName", "npcPosition"]+ }+ },+ "maxProperties": 1,+ "minProperties": 1+}+|]++-- ========================================================================+-- ISPair (non-record product data type)+-- ========================================================================+data ISPair = ISPair Integer String+ deriving (Generic)++instance ToSchema ISPair++ispairSchemaJSON :: Value+ispairSchemaJSON = [aesonQQ|+{+ "type": "array",+ "items":+ [+ { "type": "integer" },+ { "type": "string" }+ ],+ "minItems": 2,+ "maxItems": 2+}+|]++-- ========================================================================+-- Point (record data type with custom fieldLabelModifier)+-- ========================================================================++data Point = Point+ { pointX :: Double+ , pointY :: Double+ } deriving (Generic)++instance ToSchema Point where+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions+ { fieldLabelModifier = map toLower . drop (length "point") }++pointSchemaJSON :: Value+pointSchemaJSON = [aesonQQ|+{+ "type": "object",+ "properties":+ {+ "x": { "type": "number", "format": "double" },+ "y": { "type": "number", "format": "double" }+ },+ "required": ["x", "y"]+}+|]++-- ========================================================================+-- Point (record data type with multiple fields)+-- ========================================================================++data Point5 = Point5+ { point5X :: Double+ , point5Y :: Double+ , point5Z :: Double+ , point5U :: Double+ , point5V :: Double -- 5 dimensional!+ } deriving (Generic)++instance ToSchema Point5 where+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions+ { fieldLabelModifier = map toLower . drop (length "point5") }++point5SchemaJSON :: Value+point5SchemaJSON = [aesonQQ|+{+ "type": "object",+ "properties":+ {+ "x": { "type": "number", "format": "double" },+ "y": { "type": "number", "format": "double" },+ "z": { "type": "number", "format": "double" },+ "u": { "type": "number", "format": "double" },+ "v": { "type": "number", "format": "double" }+ },+ "required": ["x", "y", "z", "u", "v"]+}+|]++point5Properties :: [String]+point5Properties = ["x", "y", "z", "u", "v"]++-- ========================================================================+-- MyRoseTree (custom datatypeNameModifier)+-- ========================================================================++data MyRoseTree = MyRoseTree+ { root :: String+ , trees :: [MyRoseTree]+ } deriving (Generic)++instance ToSchema MyRoseTree where+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions+ { datatypeNameModifier = drop (length "My") }++myRoseTreeSchemaJSON :: Value+myRoseTreeSchemaJSON = [aesonQQ|+{+ "type": "object",+ "properties":+ {+ "root": { "type": "string" },+ "trees":+ {+ "type": "array",+ "items":+ {+ "$ref": "#/definitions/RoseTree"+ }+ }+ },+ "required": ["root", "trees"]+}+|]++data MyRoseTree' = MyRoseTree'+ { root' :: String+ , trees' :: [MyRoseTree']+ } deriving (Generic)++instance ToSchema MyRoseTree' where+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions+ { datatypeNameModifier = map toLower }++myRoseTreeSchemaJSON' :: Value+myRoseTreeSchemaJSON' = [aesonQQ|+{+ "type": "object",+ "properties":+ {+ "root'": { "type": "string" },+ "trees'":+ {+ "type": "array",+ "items":+ {+ "$ref": "#/definitions/myrosetree'"+ }+ }+ },+ "required": ["root'", "trees'"]+}+|]++-- ========================================================================+-- Inlined (newtype for inlining schemas)+-- ========================================================================++newtype Inlined a = Inlined { getInlined :: a }++instance ToSchema a => ToSchema (Inlined a) where+ declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)+ where+ unname (NamedSchema _ s) = NamedSchema Nothing s++-- ========================================================================+-- Light (sum type with unwrapUnaryRecords)+-- ========================================================================++data Light+ = NoLight+ | LightFreq Double+ | LightColor Color+ | LightWaveLength { waveLength :: Double }+ deriving (Generic)++instance ToSchema Light where+ declareNamedSchema = genericDeclareNamedSchemaUnrestricted defaultSchemaOptions+ { unwrapUnaryRecords = True }++lightSchemaJSON :: Value+lightSchemaJSON = [aesonQQ|+{+ "type": "object",+ "properties":+ {+ "NoLight": { "type": "array", "items": {}, "maxItems": 0, "example": [] },+ "LightFreq": { "type": "number", "format": "double" },+ "LightColor": { "$ref": "#/definitions/Color" },+ "LightWaveLength": { "type": "number", "format": "double" }+ },+ "maxProperties": 1,+ "minProperties": 1+}+|]++lightInlinedSchemaJSON :: Value+lightInlinedSchemaJSON = [aesonQQ|+{+ "type": "object",+ "properties":+ {+ "NoLight": { "type": "array", "items": {}, "maxItems": 0, "example": [] },+ "LightFreq": { "type": "number", "format": "double" },+ "LightColor":+ {+ "type": "string",+ "enum": ["Red", "Green", "Blue"]+ },+ "LightWaveLength": { "type": "number", "format": "double" }+ },+ "maxProperties": 1,+ "minProperties": 1+}+|]++-- ========================================================================+-- ResourceId (series of newtypes)+-- ========================================================================++newtype Id = Id String deriving (Generic)+instance ToSchema Id++newtype ResourceId = ResourceId Id deriving (Generic)+instance ToSchema ResourceId++-- ========================================================================+-- ButtonImages (bounded enum key mapping)+-- ========================================================================++data ButtonState = Neutral | Focus | Active | Hover | Disabled+ deriving (Show, Bounded, Enum, Generic)++instance ToJSON ButtonState+instance ToSchema ButtonState+instance ToJSONKey ButtonState where toJSONKey = toJSONKeyText (Text.pack . show)++type ImageUrl = Text.Text++newtype ButtonImages = ButtonImages { getButtonImages :: Map ButtonState ImageUrl }+ deriving (Generic)++instance ToJSON ButtonImages where+ toJSON = toJSON . getButtonImages++instance ToSchema ButtonImages where+ declareNamedSchema = genericDeclareNamedSchemaNewtype defaultSchemaOptions+ declareSchemaBoundedEnumKeyMapping++buttonImagesSchemaJSON :: Value+buttonImagesSchemaJSON = [aesonQQ|+{+ "type": "object",+ "properties":+ {+ "Neutral": { "type": "string" },+ "Focus": { "type": "string" },+ "Active": { "type": "string" },+ "Hover": { "type": "string" },+ "Disabled": { "type": "string" }+ }+}+|]++-- ========================================================================+-- SingleMaybeField (single field data with optional field)+-- ========================================================================++data SingleMaybeField = SingleMaybeField { singleMaybeField :: Maybe String }+ deriving (Show, Generic)++instance ToJSON SingleMaybeField+instance ToSchema SingleMaybeField++singleMaybeFieldSchemaJSON :: Value+singleMaybeFieldSchemaJSON = [aesonQQ|+{+ "type": "object",+ "properties":+ {+ "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"]+}+|]
test/Data/Swagger/ParamSchemaSpec.hs view
@@ -3,10 +3,11 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE OverloadedStrings #-} module Data.Swagger.ParamSchemaSpec where -import Data.Aeson (Value)-import Data.Aeson.QQ+import Data.Aeson+import Data.Aeson.QQ.Simple import Data.Char import Data.Proxy import GHC.Generics@@ -14,9 +15,13 @@ import Data.Swagger import Data.Swagger.Internal (SwaggerKind(..)) +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 @@ -29,88 +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---- ========================================================================--- Unit type--- ========================================================================--data Unit = Unit deriving (Generic)-instance ToParamSchema Unit--unitSchemaJSON :: Value-unitSchemaJSON = [aesonQQ|-{- "type": "string",- "enum": ["Unit"]-}-|]---- ========================================================================--- Color (enum)--- ========================================================================-data Color- = Red- | Green- | Blue- deriving (Generic)-instance ToParamSchema Color--colorSchemaJSON :: Value-colorSchemaJSON = [aesonQQ|-{- "type": "string",- "enum": ["Red", "Green", "Blue"]-}-|]---- ========================================================================--- Status (constructorTagModifier)--- ========================================================================--data Status = StatusOk | StatusError deriving (Generic)--instance ToParamSchema Status where- toParamSchema = genericToParamSchema defaultSchemaOptions- { constructorTagModifier = map toLower . drop (length "Status") }--statusSchemaJSON :: Value-statusSchemaJSON = [aesonQQ|-{- "type": "string",- "enum": ["ok", "error"]-}-|]---- ========================================================================--- Email (newtype with unwrapUnaryRecords set to True)--- ========================================================================--newtype Email = Email { getEmail :: String }- deriving (Generic)-instance ToParamSchema Email--emailSchemaJSON :: Value-emailSchemaJSON = [aesonQQ|-{- "type": "string"-}-|]---- ========================================================================--- UserId (non-record newtype)--- ========================================================================--newtype UserId = UserId Integer- deriving (Generic)-instance ToParamSchema UserId--userIdSchemaJSON :: Value-userIdSchemaJSON = [aesonQQ|-{- "type": "integer"-}-|]-
+ test/Data/Swagger/Schema/GeneratorSpec.hs view
@@ -0,0 +1,168 @@+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PackageImports #-}+module Data.Swagger.Schema.GeneratorSpec where++import Prelude ()+import Prelude.Compat++import Data.Swagger+import Data.Swagger.Schema.Generator++import Control.Lens.Operators+import Data.Aeson+import Data.Hashable (Hashable)+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap+import "unordered-containers" Data.HashSet (HashSet)+import qualified "unordered-containers" Data.HashSet as HashSet+import Data.Int+import Data.IntMap (IntMap)+import Data.List.NonEmpty.Compat (NonEmpty (..), nonEmpty)+import Data.Map (Map, fromList)+import Data.Monoid (mempty)+import Data.Proxy+import Data.Proxy+import Data.Set (Set)+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import Data.Time+import Data.Version (Version)+import Data.Word+import GHC.Generics++import Test.Hspec+import Test.Hspec.QuickCheck+import Test.QuickCheck++shouldValidate :: (FromJSON a, ToSchema a) => Proxy a -> Property+shouldValidate = validateFromJSON+++shouldNotValidate :: (FromJSON a, ToSchema a) => Proxy a -> Property+shouldNotValidate = expectFailure . shouldValidate+++spec :: Spec+spec = do+ describe "FromJSON validation" $ do+ prop "Bool" $ shouldValidate (Proxy :: Proxy Bool)+ prop "Char" $ shouldValidate (Proxy :: Proxy Char)+ prop "Double" $ shouldValidate (Proxy :: Proxy Double)+ prop "Float" $ shouldValidate (Proxy :: Proxy Float)+ prop "Int" $ shouldValidate (Proxy :: Proxy Int)+ prop "Int8" $ shouldValidate (Proxy :: Proxy Int8)+ prop "Int16" $ shouldValidate (Proxy :: Proxy Int16)+ prop "Int32" $ shouldValidate (Proxy :: Proxy Int32)+ prop "Int64" $ shouldValidate (Proxy :: Proxy Int64)+ prop "Integer" $ shouldValidate (Proxy :: Proxy Integer)+ prop "Word" $ shouldValidate (Proxy :: Proxy Word)+ prop "Word8" $ shouldValidate (Proxy :: Proxy Word8)+ prop "Word16" $ shouldValidate (Proxy :: Proxy Word16)+ prop "Word32" $ shouldValidate (Proxy :: Proxy Word32)+ prop "Word64" $ shouldValidate (Proxy :: Proxy Word64)+ prop "String" $ shouldValidate (Proxy :: Proxy String)+ prop "()" $ shouldValidate (Proxy :: Proxy ())+-- prop "ZonedTime" $ shouldValidate (Proxy :: Proxy ZonedTime)+-- prop "UTCTime" $ shouldValidate (Proxy :: Proxy UTCTime)+ prop "T.Text" $ shouldValidate (Proxy :: Proxy T.Text)+ prop "TL.Text" $ shouldValidate (Proxy :: Proxy TL.Text)+ prop "[String]" $ shouldValidate (Proxy :: Proxy [String])+ -- prop "(Maybe [Int])" $ shouldValidate (Proxy :: Proxy (Maybe [Int]))+ prop "(IntMap String)" $ shouldValidate (Proxy :: Proxy (IntMap String))+ prop "(Set Bool)" $ shouldValidate (Proxy :: Proxy (Set Bool))+ prop "(NonEmpty Bool)" $ shouldValidate (Proxy :: Proxy (NonEmpty Bool))+ prop "(HashSet Bool)" $ shouldValidate (Proxy :: Proxy (HashSet Bool))+ prop "(Either Int String)" $ shouldValidate (Proxy :: Proxy (Either Int String))+ prop "(Int, String)" $ shouldValidate (Proxy :: Proxy (Int, String))+ prop "(Map String Int)" $ shouldValidate (Proxy :: Proxy (Map String Int))+ prop "(Map T.Text Int)" $ shouldValidate (Proxy :: Proxy (Map T.Text Int))+ prop "(Map TL.Text Bool)" $ shouldValidate (Proxy :: Proxy (Map TL.Text Bool))+ prop "(HashMap String Int)" $ shouldValidate (Proxy :: Proxy (HashMap String Int))+ prop "(HashMap T.Text Int)" $ shouldValidate (Proxy :: Proxy (HashMap T.Text Int))+ prop "(HashMap TL.Text Bool)" $ shouldValidate (Proxy :: Proxy (HashMap TL.Text Bool))+ prop "Object" $ shouldValidate (Proxy :: Proxy Object)+ prop "(Int, String, Double)" $ shouldValidate (Proxy :: Proxy (Int, String, Double))+ prop "(Int, String, Double, [Int])" $ shouldValidate (Proxy :: Proxy (Int, String, Double, [Int]))+ prop "(Int, String, Double, [Int], Int)" $ shouldValidate (Proxy :: Proxy (Int, String, Double, [Int], Int))+ describe "Invalid FromJSON validation" $ do+ prop "WrongType" $ shouldNotValidate (Proxy :: Proxy WrongType)+ prop "MissingRequired" $ shouldNotValidate (Proxy :: Proxy MissingRequired)+ prop "MissingProperty" $ shouldNotValidate (Proxy :: Proxy MissingProperty)+ prop "WrongPropType" $ shouldNotValidate (Proxy :: Proxy WrongPropType)++-- =============================+-- Data types and bunk instances+-- =============================++data WrongType = WrongType Bool++instance FromJSON WrongType where+ parseJSON = withBool "WrongType" $ return . WrongType++instance ToSchema WrongType where+ declareNamedSchema _ = return . NamedSchema (Just "WrongType") $+ mempty+ & type_ ?~ SwaggerObject+++data MissingRequired = MissingRequired+ { propA :: String+ , propB :: Bool+ }++instance FromJSON MissingRequired where+ parseJSON = withObject "MissingRequired" $ \o ->+ MissingRequired+ <$> o .: "propA"+ <*> o .: "propB"++instance ToSchema MissingRequired where+ declareNamedSchema _ = do+ stringSchema <- declareSchemaRef (Proxy :: Proxy String)+ boolSchema <- declareSchemaRef (Proxy :: Proxy Bool)+ return . NamedSchema (Just "MissingRequired") $+ mempty+ & type_ ?~ SwaggerObject+ & properties .~ [("propA", stringSchema)+ ,("propB", boolSchema)+ ]+ & required .~ ["propA"]++data MissingProperty = MissingProperty+ { propC :: String+ , propD :: Bool+ }++instance FromJSON MissingProperty where+ parseJSON = withObject "MissingProperty" $ \o ->+ MissingProperty+ <$> o .: "propC"+ <*> o .: "propD"++instance ToSchema MissingProperty where+ declareNamedSchema _ = do+ stringSchema <- declareSchemaRef (Proxy :: Proxy String)+ return . NamedSchema (Just "MissingProperty") $+ mempty+ & type_ ?~ SwaggerObject+ & properties .~ [("propC", stringSchema)]+ & required .~ ["propC"]++data WrongPropType = WrongPropType+ { propE :: String+ }++instance FromJSON WrongPropType where+ parseJSON = withObject "WrongPropType" $ \o ->+ WrongPropType+ <$> o .: "propE"++instance ToSchema WrongPropType where+ declareNamedSchema _ = do+ boolSchema <- declareSchemaRef (Proxy :: Proxy Bool)+ return . NamedSchema (Just "WrongPropType") $+ mempty+ & type_ ?~ SwaggerObject+ & properties .~ [("propE", boolSchema)]+ & required .~ ["propE"]
test/Data/Swagger/Schema/ValidationSpec.hs view
@@ -1,37 +1,53 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE PackageImports #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Data.Swagger.Schema.ValidationSpec where -import Control.Applicative-import Data.Aeson-import Data.Aeson.Types-import Data.Int-import Data.IntMap (IntMap)-import Data.Hashable (Hashable)-import "unordered-containers" Data.HashSet (HashSet)+import Control.Applicative+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+import "unordered-containers" Data.HashSet (HashSet) import qualified "unordered-containers" Data.HashSet as HashSet-import Data.HashMap.Strict (HashMap)-import qualified Data.HashMap.Strict as HashMap-import Data.Map (Map)-import Data.Proxy-import Data.Time-import qualified Data.Text as T-import qualified Data.Text.Lazy as TL-import Data.Set (Set)-import Data.Word-import GHC.Generics+import Data.Int+import Data.IntMap (IntMap)+import Data.List.NonEmpty.Compat (NonEmpty (..), nonEmpty)+import Data.Map (Map, fromList)+import Data.Monoid (mempty)+import Data.Proxy+import Data.Set (Set)+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import Data.Time+import Data.Version (Version)+import Data.Word+import GHC.Generics -import Data.Swagger+import Data.Swagger+import Data.Swagger.Declare -import Test.Hspec-import Test.Hspec.QuickCheck-import Test.QuickCheck+import Test.Hspec+import Test.Hspec.QuickCheck+import Test.QuickCheck+import Test.QuickCheck.Instances () shouldValidate :: (ToJSON a, ToSchema a) => Proxy a -> a -> Bool shouldValidate _ x = validateToJSON x == [] +shouldNotValidate :: forall a. ToSchema a => (a -> Value) -> a -> Bool+shouldNotValidate f = not . null . validateJSON defs sch . f+ where+ (defs, sch) = runDeclare (declareSchema (Proxy :: Proxy a)) mempty+ spec :: Spec spec = do describe "Validation" $ do@@ -60,6 +76,7 @@ -- prop "(Maybe [Int])" $ shouldValidate (Proxy :: Proxy (Maybe [Int])) prop "(IntMap String)" $ shouldValidate (Proxy :: Proxy (IntMap String)) prop "(Set Bool)" $ shouldValidate (Proxy :: Proxy (Set Bool))+ prop "(NonEmpty Bool)" $ shouldValidate (Proxy :: Proxy (NonEmpty Bool)) prop "(HashSet Bool)" $ shouldValidate (Proxy :: Proxy (HashSet Bool)) prop "(Either Int String)" $ shouldValidate (Proxy :: Proxy (Either Int String)) prop "(Int, String)" $ shouldValidate (Proxy :: Proxy (Int, String))@@ -69,6 +86,7 @@ prop "(HashMap String Int)" $ shouldValidate (Proxy :: Proxy (HashMap String Int)) prop "(HashMap T.Text Int)" $ shouldValidate (Proxy :: Proxy (HashMap T.Text Int)) prop "(HashMap TL.Text Bool)" $ shouldValidate (Proxy :: Proxy (HashMap TL.Text Bool))+ prop "Object" $ shouldValidate (Proxy :: Proxy Object) prop "(Int, String, Double)" $ shouldValidate (Proxy :: Proxy (Int, String, Double)) prop "(Int, String, Double, [Int])" $ shouldValidate (Proxy :: Proxy (Int, String, Double, [Int])) prop "(Int, String, Double, [Int], Int)" $ shouldValidate (Proxy :: Proxy (Int, String, Double, [Int], Int))@@ -77,7 +95,17 @@ prop "Paint" $ shouldValidate (Proxy :: Proxy Paint) prop "MyRoseTree" $ shouldValidate (Proxy :: Proxy MyRoseTree) prop "Light" $ shouldValidate (Proxy :: Proxy Light)+ prop "ButtonImages" $ shouldValidate (Proxy :: Proxy ButtonImages)+ prop "Version" $ shouldValidate (Proxy :: Proxy Version)+ prop "FreeForm" $ shouldValidate (Proxy :: Proxy FreeForm) + describe "invalid cases" $ do+ prop "invalidPersonToJSON" $ shouldNotValidate invalidPersonToJSON+ prop "invalidColorToJSON" $ shouldNotValidate invalidColorToJSON+ prop "invalidPaintToJSON" $ shouldNotValidate invalidPaintToJSON+ prop "invalidLightToJSON" $ shouldNotValidate invalidLightToJSON+ prop "invalidButtonImagesToJSON" $ shouldNotValidate invalidButtonImagesToJSON+ main :: IO () main = hspec spec @@ -96,6 +124,13 @@ instance Arbitrary Person where arbitrary = Person <$> arbitrary <*> arbitrary <*> arbitrary +invalidPersonToJSON :: Person -> Value+invalidPersonToJSON Person{..} = object+ [ fromString "personName" .= toJSON name+ , fromString "personPhone" .= toJSON phone+ , fromString "personEmail" .= toJSON email+ ]+ -- ======================================================================== -- Color (enum) -- ========================================================================@@ -107,6 +142,11 @@ instance Arbitrary Color where arbitrary = arbitraryBoundedEnum +invalidColorToJSON :: Color -> Value+invalidColorToJSON Red = toJSON "red"+invalidColorToJSON Green = toJSON "green"+invalidColorToJSON Blue = toJSON "blue"+ -- ======================================================================== -- Paint (record with bounded enum property) -- ========================================================================@@ -120,6 +160,9 @@ instance Arbitrary Paint where arbitrary = Paint <$> arbitrary +invalidPaintToJSON :: Paint -> Value+invalidPaintToJSON = toJSON . color+ -- ======================================================================== -- MyRoseTree (custom datatypeNameModifier) -- ========================================================================@@ -161,36 +204,83 @@ , LightColor <$> arbitrary ] --- Arbitrary instances for common types+invalidLightToJSON :: Light -> Value+invalidLightToJSON = genericToJSON defaultOptions -instance (Eq k, Hashable k, Arbitrary k, Arbitrary v) => Arbitrary (HashMap k v) where- arbitrary = HashMap.fromList <$> arbitrary+-- ========================================================================+-- ButtonImages (bounded enum key mapping)+-- ======================================================================== -instance (Eq a, Hashable a, Arbitrary a) => Arbitrary (HashSet a) where- arbitrary = HashSet.fromList <$> arbitrary+data ButtonState = Neutral | Focus | Active | Hover | Disabled+ deriving (Show, Eq, Ord, Bounded, Enum, Generic) -instance Arbitrary T.Text where- arbitrary = T.pack <$> arbitrary+instance ToJSON ButtonState+instance ToSchema ButtonState+instance ToJSONKey ButtonState where toJSONKey = toJSONKeyText (T.pack . show) -instance Arbitrary TL.Text where- arbitrary = TL.pack <$> arbitrary+instance Arbitrary ButtonState where+ arbitrary = arbitraryBoundedEnum -instance Arbitrary Day where- arbitrary = liftA3 fromGregorian (fmap ((+ 1) . abs) arbitrary) arbitrary arbitrary+type ImageUrl = T.Text -instance Arbitrary LocalTime where- arbitrary = LocalTime- <$> arbitrary- <*> liftA3 TimeOfDay (choose (0, 23)) (choose (0, 59)) (fromInteger <$> choose (0, 60))+newtype ButtonImages = ButtonImages { getButtonImages :: Map ButtonState ImageUrl }+ deriving (Show, Generic) +instance ToJSON ButtonImages where+ toJSON = toJSON . getButtonImages++instance ToSchema ButtonImages where+ declareNamedSchema = genericDeclareNamedSchemaNewtype defaultSchemaOptions+ declareSchemaBoundedEnumKeyMapping++invalidButtonImagesToJSON :: ButtonImages -> Value+invalidButtonImagesToJSON = genericToJSON defaultOptions++instance Arbitrary ButtonImages where+ arbitrary = ButtonImages <$> arbitrary++-- ========================================================================+-- FreeForm (wraps a raw JSON Value)+-- ========================================================================++data FreeForm = FreeForm { jsonContent :: Map T.Text Value }+ deriving (Show, Generic)++instance ToJSON FreeForm where+ toJSON = toJSON . jsonContent++instance ToSchema FreeForm where+ declareNamedSchema _ = pure $ NamedSchema (Just $ T.pack "FreeForm") $ mempty+ & type_ ?~ SwaggerObject+ & additionalProperties ?~ AdditionalPropertiesAllowed True++instance Arbitrary FreeForm where+ arbitrary = FreeForm . fromList <$> genObj+ where+ genObj = listOf $ do+ k <- arbitrary+ v <- oneof [ String <$> arbitrary, Number <$> arbitrary, Bool <$> arbitrary, pure Null ]+ pure (k, v)+ instance Eq ZonedTime where ZonedTime t (TimeZone x _ _) == ZonedTime t' (TimeZone y _ _) = t == t' && x == y -instance Arbitrary ZonedTime where- arbitrary = ZonedTime- <$> arbitrary- <*> liftA3 TimeZone arbitrary arbitrary (vectorOf 3 (elements ['A'..'Z']))+-- ========================================================================+-- Arbitrary instance for Data.Aeson.Value+-- ======================================================================== -instance Arbitrary UTCTime where- arbitrary = UTCTime <$> arbitrary <*> fmap fromInteger (choose (0, 86400))+#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 . 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,20 +9,21 @@ import Control.Lens ((^.)) import Data.Aeson (Value)-import Data.Aeson.QQ-import Data.Char-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-import GHC.Generics import Data.Swagger import Data.Swagger.Declare +import Data.Swagger.CommonTestTypes 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 @@ -76,12 +77,15 @@ context "Email (unwrapUnaryRecords)" $ checkToSchema (Proxy :: Proxy Email) emailSchemaJSON context "UserId (non-record newtype)" $ checkToSchema (Proxy :: Proxy UserId) userIdSchemaJSON context "Player (unary record)" $ checkToSchema (Proxy :: Proxy Player) playerSchemaJSON+ context "SingleMaybeField (unary record with Maybe)" $ checkToSchema (Proxy :: Proxy SingleMaybeField) singleMaybeFieldSchemaJSON context "Players (inlining schema)" $ checkToSchema (Proxy :: Proxy Players) playersSchemaJSON context "MyRoseTree (datatypeNameModifier)" $ checkToSchema (Proxy :: Proxy MyRoseTree) myRoseTreeSchemaJSON+ context "MyRoseTree' (datatypeNameModifier)" $ checkToSchema (Proxy :: Proxy MyRoseTree') myRoseTreeSchemaJSON' context "Sum types" $ do 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))@@ -93,6 +97,7 @@ context "Light" $ checkDefs (Proxy :: Proxy Light) ["Color"] context "Character" $ checkDefs (Proxy :: Proxy Character) ["Player", "Point"] context "MyRoseTree" $ checkDefs (Proxy :: Proxy MyRoseTree) ["RoseTree"]+ context "MyRoseTree'" $ checkDefs (Proxy :: Proxy MyRoseTree') ["myrosetree'"] context "[Set (Unit, Maybe Color)]" $ checkDefs (Proxy :: Proxy [Set (Unit, Maybe Color)]) ["Unit", "Color"] context "ResourceId" $ checkDefs (Proxy :: Proxy ResourceId) [] describe "Inlining Schemas" $ do@@ -101,549 +106,10 @@ context "Character (inlining only Player)" $ checkInlinedSchemas ["Player"] (Proxy :: Proxy Character) characterInlinedPlayerSchemaJSON context "Light" $ checkInlinedSchema (Proxy :: Proxy Light) lightInlinedSchemaJSON context "MyRoseTree (inlineNonRecursiveSchemas)" $ checkInlinedRecSchema (Proxy :: Proxy MyRoseTree) myRoseTreeSchemaJSON+ 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---- ========================================================================--- Person (simple record with optional fields)--- ========================================================================-data Person = Person- { name :: String- , phone :: Integer- , email :: Maybe String- } deriving (Generic)--instance ToSchema Person--personSchemaJSON :: Value-personSchemaJSON = [aesonQQ|-{- "type": "object",- "properties":- {- "name": { "type": "string" },- "phone": { "type": "integer" },- "email": { "type": "string" }- },- "required": ["name", "phone"]-}-|]---- ========================================================================--- ISPair (non-record product data type)--- ========================================================================-data ISPair = ISPair Integer String- deriving (Generic)--instance ToSchema ISPair--ispairSchemaJSON :: Value-ispairSchemaJSON = [aesonQQ|-{- "type": "array",- "items":- [- { "type": "integer" },- { "type": "string" }- ],- "minItems": 2,- "maxItems": 2-}-|]---- ========================================================================--- Point (record data type with custom fieldLabelModifier)--- ========================================================================--data Point = Point- { pointX :: Double- , pointY :: Double- } deriving (Generic)--instance ToSchema Point where- declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions- { fieldLabelModifier = map toLower . drop (length "point") }--pointSchemaJSON :: Value-pointSchemaJSON = [aesonQQ|-{- "type": "object",- "properties":- {- "x": { "type": "number", "format": "double" },- "y": { "type": "number", "format": "double" }- },- "required": ["x", "y"]-}-|]---- ========================================================================--- Point (record data type with multiple fields)--- ========================================================================--data Point5 = Point5- { point5X :: Double- , point5Y :: Double- , point5Z :: Double- , point5U :: Double- , point5V :: Double -- 5 dimensional!- } deriving (Generic)--instance ToSchema Point5 where- declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions- { fieldLabelModifier = map toLower . drop (length "point5") }--point5SchemaJSON :: Value-point5SchemaJSON = [aesonQQ|-{- "type": "object",- "properties":- {- "x": { "type": "number", "format": "double" },- "y": { "type": "number", "format": "double" },- "z": { "type": "number", "format": "double" },- "u": { "type": "number", "format": "double" },- "v": { "type": "number", "format": "double" }- },- "required": ["x", "y", "z", "u", "v"]-}-|]--point5Properties :: [String]-point5Properties = ["x", "y", "z", "u", "v"]---- ========================================================================--- Color (enum)--- ========================================================================-data Color- = Red- | Green- | Blue- deriving (Generic)-instance ToSchema Color--colorSchemaJSON :: Value-colorSchemaJSON = [aesonQQ|-{- "type": "string",- "enum": ["Red", "Green", "Blue"]-}-|]---- ========================================================================--- Shade (paramSchemaToNamedSchema)--- ========================================================================--data Shade = Dim | Bright deriving (Generic)-instance ToParamSchema Shade--instance ToSchema Shade where declareNamedSchema = pure . paramSchemaToNamedSchema defaultSchemaOptions--shadeSchemaJSON :: Value-shadeSchemaJSON = [aesonQQ|-{- "type": "string",- "enum": ["Dim", "Bright"]-}-|]---- ========================================================================--- Paint (record with bounded enum property)--- ========================================================================--newtype Paint = Paint { color :: Color }- deriving (Generic)-instance ToSchema Paint--paintSchemaJSON :: Value-paintSchemaJSON = [aesonQQ|-{- "type": "object",- "properties":- {- "color":- {- "$ref": "#/definitions/Color"- }- },- "required": ["color"]-}-|]--paintInlinedSchemaJSON :: Value-paintInlinedSchemaJSON = [aesonQQ|-{- "type": "object",- "properties":- {- "color":- {- "type": "string",- "enum": ["Red", "Green", "Blue"]- }- },- "required": ["color"]-}-|]---- ========================================================================--- Email (newtype with unwrapUnaryRecords set to True)--- ========================================================================--newtype Email = Email { getEmail :: String }- deriving (Generic)--instance ToSchema Email where- declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions- { unwrapUnaryRecords = True }--emailSchemaJSON :: Value-emailSchemaJSON = [aesonQQ|-{- "type": "string"-}-|]---- ========================================================================--- UserId (non-record newtype)--- ========================================================================--newtype UserId = UserId Integer- deriving (Eq, Ord, Generic)-instance ToSchema UserId--userIdSchemaJSON :: Value-userIdSchemaJSON = [aesonQQ|-{- "type": "integer"-}-|]---- ========================================================================--- UserGroup (set newtype)--- ========================================================================--newtype UserGroup = UserGroup (Set UserId)- deriving (Generic)-instance ToSchema UserGroup--userGroupSchemaJSON :: Value-userGroupSchemaJSON = [aesonQQ|-{- "type": "array",- "items": { "$ref": "#/definitions/UserId" },- "uniqueItems": true-}-|]---- ========================================================================--- Player (record newtype)--- ========================================================================--newtype Player = Player- { position :: Point- } deriving (Generic)-instance ToSchema Player--playerSchemaJSON :: Value-playerSchemaJSON = [aesonQQ|-{- "type": "object",- "properties":- {- "position":- {- "$ref": "#/definitions/Point"- }- },- "required": ["position"]-}-|]---- ========================================================================--- MyRoseTree (custom datatypeNameModifier)--- ========================================================================--data MyRoseTree = MyRoseTree- { root :: String- , trees :: [MyRoseTree]- } deriving (Generic)--instance ToSchema MyRoseTree where- declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions- { datatypeNameModifier = drop (length "My") }--myRoseTreeSchemaJSON :: Value-myRoseTreeSchemaJSON = [aesonQQ|-{- "type": "object",- "properties":- {- "root": { "type": "string" },- "trees":- {- "type": "array",- "items":- {- "$ref": "#/definitions/RoseTree"- }- }- },- "required": ["root", "trees"]-}-|]---- ========================================================================--- Inlined (newtype for inlining schemas)--- ========================================================================--newtype Inlined a = Inlined { getInlined :: a }--instance ToSchema a => ToSchema (Inlined a) where- declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)- where- unname (NamedSchema _ s) = NamedSchema Nothing s--newtype Players = Players [Inlined Player]- deriving (Generic)-instance ToSchema Players--playersSchemaJSON :: Value-playersSchemaJSON = [aesonQQ|-{- "type": "array",- "items":- {- "type": "object",- "properties":- {- "position":- {- "$ref": "#/definitions/Point"- }- },- "required": ["position"]- }-}-|]---- ========================================================================--- Status (sum type with unary constructors)--- ========================================================================--data Status- = StatusOk String- | StatusError String- deriving (Generic)--instance ToSchema Status where- declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions- { constructorTagModifier = map toLower . drop (length "Status") }--statusSchemaJSON :: Value-statusSchemaJSON = [aesonQQ|-{- "type": "object",- "properties":- {- "ok": { "type": "string" },- "error": { "type": "string" }- },- "maxProperties": 1,- "minProperties": 1-}-|]---- ========================================================================--- Unit type--- ========================================================================--data Unit = Unit deriving (Generic)-instance ToSchema Unit--unitSchemaJSON :: Value-unitSchemaJSON = [aesonQQ|-{- "type": "string",- "enum": ["Unit"]-}-|]----- ========================================================================--- Character (sum type with ref and record in alternative)--- ========================================================================--data Character- = PC Player- | NPC { npcName :: String, npcPosition :: Point }- deriving (Generic)-instance ToSchema Character--characterSchemaJSON :: Value-characterSchemaJSON = [aesonQQ|-{- "type": "object",- "properties":- {- "PC": { "$ref": "#/definitions/Player" },- "NPC":- {- "type": "object",- "properties":- {- "npcName": { "type": "string" },- "npcPosition": { "$ref": "#/definitions/Point" }- },- "required": ["npcName", "npcPosition"]- }- },- "maxProperties": 1,- "minProperties": 1-}-|]--characterInlinedSchemaJSON :: Value-characterInlinedSchemaJSON = [aesonQQ|-{- "type": "object",- "properties":- {- "PC":- {- "type": "object",- "properties":- {- "position":- {- "type": "object",- "properties":- {- "x": { "type": "number", "format": "double" },- "y": { "type": "number", "format": "double" }- },- "required": ["x", "y"]- }- },- "required": ["position"]- },- "NPC":- {- "type": "object",- "properties":- {- "npcName": { "type": "string" },- "npcPosition":- {- "type": "object",- "properties":- {- "x": { "type": "number", "format": "double" },- "y": { "type": "number", "format": "double" }- },- "required": ["x", "y"]- }- },- "required": ["npcName", "npcPosition"]- }- },- "maxProperties": 1,- "minProperties": 1-}-|]--characterInlinedPlayerSchemaJSON :: Value-characterInlinedPlayerSchemaJSON = [aesonQQ|-{- "type": "object",- "properties":- {- "PC":- {- "type": "object",- "properties":- {- "position":- {- "$ref": "#/definitions/Point"- }- },- "required": ["position"]- },- "NPC":- {- "type": "object",- "properties":- {- "npcName": { "type": "string" },- "npcPosition": { "$ref": "#/definitions/Point" }- },- "required": ["npcName", "npcPosition"]- }- },- "maxProperties": 1,- "minProperties": 1-}-|]---- ========================================================================--- Light (sum type with unwrapUnaryRecords)--- ========================================================================--data Light- = NoLight- | LightFreq Double- | LightColor Color- | LightWaveLength { waveLength :: Double }- deriving (Generic)--instance ToSchema Light where- declareNamedSchema = genericDeclareNamedSchemaUnrestricted defaultSchemaOptions- { unwrapUnaryRecords = True }--lightSchemaJSON :: Value-lightSchemaJSON = [aesonQQ|-{- "type": "object",- "properties":- {- "NoLight": { "type": "array", "items": [] },- "LightFreq": { "type": "number", "format": "double" },- "LightColor": { "$ref": "#/definitions/Color" },- "LightWaveLength": { "type": "number", "format": "double" }- },- "maxProperties": 1,- "minProperties": 1-}-|]--lightInlinedSchemaJSON :: Value-lightInlinedSchemaJSON = [aesonQQ|-{- "type": "object",- "properties":- {- "NoLight": { "type": "array", "items": [] },- "LightFreq": { "type": "number", "format": "double" },- "LightColor":- {- "type": "string",- "enum": ["Red", "Green", "Blue"]- },- "LightWaveLength": { "type": "number", "format": "double" }- },- "maxProperties": 1,- "minProperties": 1-}-|]---- ========================================================================--- ResourceId (series of newtypes)--- ========================================================================--newtype Id = Id String deriving (Generic)-instance ToSchema Id--newtype ResourceId = ResourceId Id deriving (Generic)-instance ToSchema ResourceId
test/Data/SwaggerSpec.hs view
@@ -10,9 +10,10 @@ import Control.Lens import Data.Aeson-import Data.Aeson.QQ+import Data.Aeson.QQ.Simple import Data.HashMap.Strict (HashMap)-import qualified Data.Set as Set+import qualified Data.HashMap.Strict.InsOrd.Compat as InsOrdHashMap+import qualified Data.HashSet.InsOrd as InsOrdHS import Data.Text (Text) import Data.Swagger@@ -37,13 +38,16 @@ context "Primitive Sample" $ schemaPrimitiveExample <=> schemaPrimitiveExampleJSON context "Simple Model" $ schemaSimpleModelExample <=> schemaSimpleModelExampleJSON context "Model with Map/Dictionary Properties" $ schemaModelDictExample <=> schemaModelDictExampleJSON+ context "Model with Arbitrary Properties" $ schemaAdditionalExample <=> schemaAdditionalExampleJSON context "Model with Example" $ schemaWithExampleExample <=> schemaWithExampleExampleJSON describe "Definitions Object" $ definitionsExample <=> definitionsExampleJSON 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@@ -126,7 +130,7 @@ operationExample :: Operation operationExample = mempty- & tags .~ Set.fromList ["pet"]+ & tags .~ InsOrdHS.fromList ["pet"] & summary ?~ "Updates a pet in the store with form data" & description ?~ "" & operationId ?~ "updatePetWithForm"@@ -153,11 +157,12 @@ & 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 & in_ .~ loc- & type_ .~ SwaggerString+ & type_ ?~ SwaggerString operationExampleJSON :: Value operationExampleJSON = [aesonQQ|@@ -213,7 +218,8 @@ "read:pets" ] }- ]+ ],+ "x-age": 42 } |] @@ -223,7 +229,7 @@ schemaPrimitiveExample :: Schema schemaPrimitiveExample = mempty- & type_ .~ SwaggerString+ & type_ ?~ SwaggerString & format ?~ "email" schemaPrimitiveExampleJSON :: Value@@ -236,14 +242,14 @@ schemaSimpleModelExample :: Schema schemaSimpleModelExample = mempty- & type_ .~ SwaggerObject+ & type_ ?~ SwaggerObject & required .~ [ "name" ] & properties .~- [ ("name", Inline (mempty & type_ .~ SwaggerString))+ [ ("name", Inline (mempty & type_ ?~ SwaggerString)) , ("address", Ref (Reference "Address")) , ("age", Inline $ mempty & minimum_ ?~ 0- & type_ .~ SwaggerInteger+ & type_ ?~ SwaggerInteger & format ?~ "int32" ) ] schemaSimpleModelExampleJSON :: Value@@ -271,8 +277,8 @@ schemaModelDictExample :: Schema schemaModelDictExample = mempty- & type_ .~ SwaggerObject- & additionalProperties ?~ Inline (mempty & type_ .~ SwaggerString)+ & type_ ?~ SwaggerObject+ & additionalProperties ?~ AdditionalPropertiesSchema (Inline (mempty & type_ ?~ SwaggerString)) schemaModelDictExampleJSON :: Value schemaModelDictExampleJSON = [aesonQQ|@@ -284,15 +290,28 @@ } |] +schemaAdditionalExample :: Schema+schemaAdditionalExample = mempty+ & type_ ?~ SwaggerObject+ & additionalProperties ?~ AdditionalPropertiesAllowed True++schemaAdditionalExampleJSON :: Value+schemaAdditionalExampleJSON = [aesonQQ|+{+ "type": "object",+ "additionalProperties": true+}+|]+ schemaWithExampleExample :: Schema schemaWithExampleExample = mempty- & type_ .~ SwaggerObject+ & type_ ?~ SwaggerObject & properties .~ [ ("id", Inline $ mempty- & type_ .~ SwaggerInteger+ & type_ ?~ SwaggerInteger & format ?~ "int64" ) , ("name", Inline $ mempty- & type_ .~ SwaggerString) ]+ & type_ ?~ SwaggerString) ] & required .~ [ "name" ] & example ?~ [aesonQQ| {@@ -331,19 +350,19 @@ definitionsExample :: HashMap Text Schema definitionsExample = [ ("Category", mempty- & type_ .~ SwaggerObject+ & type_ ?~ SwaggerObject & properties .~ [ ("id", Inline $ mempty- & type_ .~ SwaggerInteger+ & type_ ?~ SwaggerInteger & format ?~ "int64")- , ("name", Inline (mempty & type_ .~ SwaggerString)) ] )+ , ("name", Inline (mempty & type_ ?~ SwaggerString)) ] ) , ("Tag", mempty- & type_ .~ SwaggerObject+ & type_ ?~ SwaggerObject & properties .~ [ ("id", Inline $ mempty- & type_ .~ SwaggerInteger+ & type_ ?~ SwaggerInteger & format ?~ "int64")- , ("name", Inline (mempty & type_ .~ SwaggerString)) ] ) ]+ , ("name", Inline (mempty & type_ ?~ SwaggerString)) ] ) ] definitionsExampleJSON :: Value definitionsExampleJSON = [aesonQQ|@@ -387,7 +406,7 @@ & required ?~ True & schema .~ ParamOther (mempty & in_ .~ ParamQuery- & type_ .~ SwaggerInteger+ & type_ ?~ SwaggerInteger & format ?~ "int32" )) , ("limitParam", mempty & name .~ "limit"@@ -395,7 +414,7 @@ & required ?~ True & schema .~ ParamOther (mempty & in_ .~ ParamQuery- & type_ .~ SwaggerInteger+ & type_ ?~ SwaggerInteger & format ?~ "int32" )) ] paramsDefinitionExampleJSON :: Value@@ -445,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 })@@ -478,10 +497,62 @@ } |] +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 & basePath ?~ "/"@@ -496,7 +567,7 @@ & at 200 ?~ Inline (mempty & description .~ "OK" & schema ?~ Inline (mempty- & type_ .~ SwaggerObject+ & type_ ?~ SwaggerObject & example ?~ [aesonQQ| { "created": 100,@@ -505,9 +576,9 @@ & description ?~ "This is some real Todo right here" & properties .~ [ ("created", Inline $ mempty- & type_ .~ SwaggerInteger+ & type_ ?~ SwaggerInteger & format ?~ "int32")- , ("description", Inline (mempty & type_ .~ SwaggerString))]))+ , ("description", Inline (mempty & type_ ?~ SwaggerString))])) & produces ?~ MimeList [ "application/json" ] & parameters .~ [ Inline $ mempty@@ -516,8 +587,8 @@ & description ?~ "TodoId param" & schema .~ ParamOther (mempty & in_ .~ ParamPath- & type_ .~ SwaggerString ) ]- & tags .~ Set.fromList [ "todo" ] ))+ & type_ ?~ SwaggerString ) ]+ & tags .~ InsOrdHS.fromList [ "todo" ] )) swaggerExampleJSON :: Value swaggerExampleJSON = [aesonQQ|@@ -1618,14 +1689,14 @@ compositionSchemaExample :: Schema compositionSchemaExample = mempty- & type_ .~ SwaggerObject+ & type_ ?~ SwaggerObject & Data.Swagger.allOf ?~ [ Ref (Reference "Other") , Inline (mempty- & type_ .~ SwaggerObject+ & type_ ?~ SwaggerObject & properties .~ [ ("greet", Inline $ mempty- & type_ .~ SwaggerString) ])+ & type_ ?~ SwaggerString) ]) ] compositionSchemaExampleJSON :: Value
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