swagger2 2.6 → 2.7
raw patch · 20 files changed
+228/−287 lines, 20 filesdep −transformers-compatdep ~aesondep ~basedep ~base-compat-batteriesnew-uploader
Dependencies removed: transformers-compat
Dependency ranges changed: aeson, base, base-compat-batteries, bytestring, containers, generics-sop, hspec, http-media, lens, mtl, optics-core, optics-th, template-haskell, time, transformers
Files
- CHANGELOG.md +11/−0
- include/overlapping-compat.h +0/−8
- src/Data/Swagger.hs +6/−27
- src/Data/Swagger/Declare.hs +3/−3
- src/Data/Swagger/Internal.hs +37/−44
- src/Data/Swagger/Internal/AesonUtils.hs +21/−48
- src/Data/Swagger/Internal/ParamSchema.hs +9/−16
- src/Data/Swagger/Internal/Schema.hs +22/−50
- src/Data/Swagger/Internal/Schema/Validation.hs +18/−17
- src/Data/Swagger/Internal/TypeShape.hs +0/−10
- src/Data/Swagger/Lens.hs +14/−22
- src/Data/Swagger/Operation.hs +3/−3
- src/Data/Swagger/Optics.hs +1/−1
- src/Data/Swagger/Schema/Generator.hs +2/−2
- swagger2.cabal +23/−26
- test/Data/Swagger/CommonTestTypes.hs +27/−0
- test/Data/Swagger/Schema/ValidationSpec.hs +11/−6
- test/Data/Swagger/SchemaSpec.hs +1/−0
- test/Data/SwaggerSpec.hs +13/−0
- test/SpecCommon.hs +6/−4
CHANGELOG.md view
@@ -1,3 +1,14 @@+2.7+---++- Upgrade `aeson` to `2.0.1.0` (see [#228]( https://github.com/GetShopTV/swagger2/pull/228 ));+- Switch from Travis CI to GitHub Actions (see [#228]( https://github.com/GetShopTV/swagger2/pull/228 ));+- GHC 9 support (see [#228]( https://github.com/GetShopTV/swagger2/pull/228 ));+- More GHC-8.10 related cleanup, tighten lower bound on some dependencies.+ (see [#216]( https://github.com/GetShopTV/swagger2/pull/216 ));+- Add "format" field for uint32 and uint64+ (see [#215]( https://github.com/GetShopTV/swagger2/pull/215 ));+ 2.6 ---
− include/overlapping-compat.h
@@ -1,8 +0,0 @@-#if __GLASGOW_HASKELL__ >= 710-#define OVERLAPPABLE_ {-# OVERLAPPABLE #-}-#define OVERLAPPING_ {-# OVERLAPPING #-}-#else-{-# LANGUAGE OverlappingInstances #-}-#define OVERLAPPABLE_-#define OVERLAPPING_-#endif
src/Data/Swagger.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} -- | -- Module: Data.Swagger -- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>@@ -145,7 +144,7 @@ -- In this library you can use @'mempty'@ for a default/empty value. For instance: -- -- >>> encode (mempty :: Swagger)--- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"}}"+-- "{\"swagger\":\"2.0\",\"info\":{\"title\":\"\",\"version\":\"\"}}" -- -- As you can see some spec properties (e.g. @"version"@) are there even when the spec is empty. -- That is because these properties are actually required ones.@@ -154,12 +153,12 @@ -- although it is not strictly necessary: -- -- >>> encode mempty { _infoTitle = "Todo API", _infoVersion = "1.0" }--- "{\"version\":\"1.0\",\"title\":\"Todo API\"}"+-- "{\"title\":\"Todo API\",\"version\":\"1.0\"}" -- -- You can merge two values using @'mappend'@ or its infix version @('<>')@: -- -- >>> encode $ mempty { _infoTitle = "Todo API" } <> mempty { _infoVersion = "1.0" }--- "{\"version\":\"1.0\",\"title\":\"Todo API\"}"+-- "{\"title\":\"Todo API\",\"version\":\"1.0\"}" -- -- This can be useful for combining specifications of endpoints into a whole API specification: --@@ -193,7 +192,7 @@ -- & at 200 ?~ ("OK" & _Inline.schema ?~ Ref (Reference "User")) -- & at 404 ?~ "User info not found")) ] -- :}--- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"paths\":{\"/user\":{\"get\":{\"produces\":[\"application/json\"],\"responses\":{\"404\":{\"description\":\"User info not found\"},\"200\":{\"schema\":{\"$ref\":\"#/definitions/User\"},\"description\":\"OK\"}}}}},\"definitions\":{\"User\":{\"type\":\"string\"}}}"+-- "{\"swagger\":\"2.0\",\"info\":{\"title\":\"\",\"version\":\"\"},\"paths\":{\"/user\":{\"get\":{\"produces\":[\"application/json\"],\"responses\":{\"200\":{\"description\":\"OK\",\"schema\":{\"$ref\":\"#/definitions/User\"}},\"404\":{\"description\":\"User info not found\"}}}}},\"definitions\":{\"User\":{\"type\":\"string\"}}}" -- -- In the snippet above we declare an API with a single path @/user@. This path provides method @GET@ -- which produces @application/json@ output. It should respond with code @200@ and body specified@@ -295,38 +294,18 @@ -- -- 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+-- ...+-- ... In the instance declaration for ‘ToSchema BadMixedType’ -- -- 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
@@ -60,7 +60,7 @@ return (mappend d' d'', y) instance Monoid d => MonadTrans (DeclareT d) where- lift m = DeclareT (\_ -> (,) mempty `liftM` m)+ lift m = DeclareT (\_ -> (,) mempty <$> m) -- | -- Definitions of @declare@ and @look@ must satisfy the following laws:@@ -103,12 +103,12 @@ -- | Evaluate @'DeclareT' d m a@ computation, -- ignoring new output @d@. evalDeclareT :: Monad m => DeclareT d m a -> d -> m a-evalDeclareT (DeclareT f) d = snd `liftM` f d+evalDeclareT (DeclareT f) d = snd <$> f d -- | Execute @'DeclateT' d m a@ computation, -- ignoring result and only producing new output @d@. execDeclareT :: Monad m => DeclareT d m a -> d -> m d-execDeclareT (DeclareT f) d = fst `liftM` f d+execDeclareT (DeclareT f) d = fst <$> f d -- | Evaluate @'DeclareT' d m a@ computation, -- starting with empty output history.
src/Data/Swagger/Internal.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-}@@ -15,10 +14,6 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-}-#if __GLASGOW_HASKELL__ <710-{-# LANGUAGE PolyKinds #-}-#endif-#include "overlapping-compat.h" module Data.Swagger.Internal where import Prelude ()@@ -47,6 +42,7 @@ import Data.HashMap.Strict.InsOrd (InsOrdHashMap) import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap+import qualified Data.Aeson.KeyMap as KM import Generics.SOP.TH (deriveGeneric) import Data.Swagger.Internal.AesonUtils (sopSwaggerGenericToJSON@@ -58,13 +54,7 @@ ,saoAdditionalPairs ,saoSubObject) import Data.Swagger.Internal.Utils--#if MIN_VERSION_aeson(0,10,0) import Data.Swagger.Internal.AesonUtils (sopSwaggerGenericToEncoding)-#define DEFINE_TOENCODING toEncoding = sopSwaggerGenericToEncoding-#else-#define DEFINE_TOENCODING-#endif -- $setup -- >>> :seti -XDataKinds@@ -416,7 +406,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 @@ -832,6 +822,23 @@ | AdditionalPropertiesSchema (Referenced Schema) deriving (Eq, Show, Data, Typeable) +-------------------------------------------------------------------------------+-- Generic instances+-------------------------------------------------------------------------------++deriveGeneric ''Header+deriveGeneric ''OAuth2Params+deriveGeneric ''Operation+deriveGeneric ''Param+deriveGeneric ''ParamOtherSchema+deriveGeneric ''PathItem+deriveGeneric ''Response+deriveGeneric ''Responses+deriveGeneric ''SecurityScheme+deriveGeneric ''Schema+deriveGeneric ''ParamSchema+deriveGeneric ''Swagger+ -- ======================================================================= -- Monoid instances -- =======================================================================@@ -928,7 +935,7 @@ SecurityDefinitions $ InsOrdHashMap.unionWith (<>) sd1 sd2 instance Monoid SecurityDefinitions where- mempty = SecurityDefinitions $ InsOrdHashMap.empty+ mempty = SecurityDefinitions InsOrdHashMap.empty mappend = (<>) -- =======================================================================@@ -959,7 +966,7 @@ swaggerMempty = ParamQuery swaggerMappend _ y = y -instance OVERLAPPING_ SwaggerMonoid (InsOrdHashMap FilePath PathItem) where+instance {-# OVERLAPPING #-} SwaggerMonoid (InsOrdHashMap FilePath PathItem) where swaggerMempty = InsOrdHashMap.empty swaggerMappend = InsOrdHashMap.unionWith mappend @@ -1060,7 +1067,7 @@ instance ToJSON OAuth2Params where toJSON = sopSwaggerGenericToJSON- DEFINE_TOENCODING+ toEncoding = sopSwaggerGenericToEncoding instance ToJSON SecuritySchemeType where toJSON SecuritySchemeBasic@@ -1073,20 +1080,23 @@ <+> object [ "type" .= ("oauth2" :: Text) ] instance ToJSON Swagger where- toJSON = sopSwaggerGenericToJSON- DEFINE_TOENCODING+ toJSON a = sopSwaggerGenericToJSON a &+ if InsOrdHashMap.null (_swaggerPaths a)+ then (<+> object ["paths" .= object []])+ else id+ toEncoding = sopSwaggerGenericToEncoding instance ToJSON SecurityScheme where toJSON = sopSwaggerGenericToJSON- DEFINE_TOENCODING+ toEncoding = sopSwaggerGenericToEncoding instance ToJSON Schema where toJSON = sopSwaggerGenericToJSON- DEFINE_TOENCODING+ toEncoding = sopSwaggerGenericToEncoding instance ToJSON Header where toJSON = sopSwaggerGenericToJSON- DEFINE_TOENCODING+ toEncoding = sopSwaggerGenericToEncoding -- | As for nullary schema for 0-arity type constructors, see -- <https://github.com/GetShopTV/swagger2/issues/167>.@@ -1117,7 +1127,7 @@ instance ToJSON Param where toJSON = sopSwaggerGenericToJSON- DEFINE_TOENCODING+ toEncoding = sopSwaggerGenericToEncoding instance ToJSON ParamAnySchema where toJSON (ParamBody s) = object [ "in" .= ("body" :: Text), "schema" .= s ]@@ -1125,23 +1135,23 @@ 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+ toEncoding = sopSwaggerGenericToEncoding instance ToJSON PathItem where toJSON = sopSwaggerGenericToJSON- DEFINE_TOENCODING+ toEncoding = sopSwaggerGenericToEncoding instance ToJSON Example where toJSON = toJSON . Map.mapKeys show . getExample@@ -1293,7 +1303,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@@ -1366,23 +1376,6 @@ instance FromJSON AdditionalProperties where parseJSON (Bool b) = pure $ AdditionalPropertiesAllowed b parseJSON js = AdditionalPropertiesSchema <$> parseJSON js------------------------------------------------------------------------------------ TH splices----------------------------------------------------------------------------------deriveGeneric ''Header-deriveGeneric ''OAuth2Params-deriveGeneric ''Operation-deriveGeneric ''Param-deriveGeneric ''ParamOtherSchema-deriveGeneric ''PathItem-deriveGeneric ''Response-deriveGeneric ''Responses-deriveGeneric ''SecurityScheme-deriveGeneric ''Schema-deriveGeneric ''ParamSchema-deriveGeneric ''Swagger instance HasSwaggerAesonOptions Header where swaggerAesonOptions _ = mkSwaggerAesonOptions "header" & saoSubObject ?~ "paramSchema"
src/Data/Swagger/Internal/AesonUtils.hs view
@@ -1,20 +1,15 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE TemplateHaskell #-}-#if __GLASGOW_HASKELL__ >= 800 {-# LANGUAGE UndecidableSuperClasses #-}-#endif module Data.Swagger.Internal.AesonUtils ( -- * Generic functions AesonDefaultValue(..), sopSwaggerGenericToJSON,-#if MIN_VERSION_aeson(0,10,0) sopSwaggerGenericToEncoding,-#endif sopSwaggerGenericToJSONWithOpts, sopSwaggerGenericParseJSON, -- * Options@@ -30,10 +25,17 @@ import Prelude.Compat import Control.Applicative ((<|>))-import Control.Lens (makeLenses, (^.))-import Control.Monad (unless)-import Data.Aeson (ToJSON(..), FromJSON(..), Value(..), Object, object, (.:), (.:?), (.!=), withObject)+import Control.Lens (makeLenses, (^.))+import Control.Monad (unless)+import Data.Aeson ( Encoding, FromJSON (..), ToJSON (..)+ , Object, Series, Value (..)+ , object, pairs, withObject+ , (.!=), (.:), (.:?), (.=)+ )+import Data.Aeson.Key (fromString, toString, fromText, toText)+import qualified Data.Aeson.KeyMap as KM import Data.Aeson.Types (Parser, Pair)+import Data.Bifunctor (first) import Data.Char (toLower, isUpper) import Data.Foldable (traverse_) import Data.Text (Text)@@ -46,10 +48,6 @@ import qualified Data.HashMap.Strict.InsOrd as InsOrd import qualified Data.HashSet.InsOrd as InsOrdHS -#if MIN_VERSION_aeson(0,10,0)-import Data.Aeson (Encoding, pairs, (.=), Series)-#endif- ------------------------------------------------------------------------------- -- SwaggerAesonOptions -------------------------------------------------------------------------------@@ -112,7 +110,7 @@ -> Value sopSwaggerGenericToJSON x = let ps = sopSwaggerGenericToJSON' opts (from x) (datatypeInfo proxy) (aesonDefaults proxy)- in object (opts ^. saoAdditionalPairs ++ ps)+ in object $ (map $ first fromText) (opts ^. saoAdditionalPairs ++ (map $ first toText) ps) where proxy = Proxy :: Proxy a opts = swaggerAesonOptions proxy@@ -134,7 +132,7 @@ -> Value sopSwaggerGenericToJSONWithOpts opts x = let ps = sopSwaggerGenericToJSON' opts (from x) (datatypeInfo proxy) defs- in object (opts ^. saoAdditionalPairs ++ ps)+ in object $ (map $ first fromText) (opts ^. saoAdditionalPairs ++ (map $ first toText) ps) where proxy = Proxy :: Proxy a defs = hcpure (Proxy :: Proxy AesonDefaultValue) defaultValue@@ -146,11 +144,7 @@ -> DatatypeInfo '[xs] -> POP Maybe '[xs] -> [Pair]-#if MIN_VERSION_generics_sop(0,5,0) sopSwaggerGenericToJSON' opts (SOP (Z fields)) (ADT _ _ (Record _ fieldsInfo :* Nil) _) (POP (defs :* Nil)) =-#else-sopSwaggerGenericToJSON' opts (SOP (Z fields)) (ADT _ _ (Record _ fieldsInfo :* Nil)) (POP (defs :* Nil)) =-#endif sopSwaggerGenericToJSON'' opts fields fieldsInfo defs sopSwaggerGenericToJSON' _ _ _ _ = error "sopSwaggerGenericToJSON: unsupported type" @@ -167,21 +161,18 @@ go Nil Nil Nil = [] go (I x :* xs) (FieldInfo name :* names) (def :* defs) | Just name' == sub = case json of- Object m -> HM.toList m ++ rest+ Object m -> KM.toList m ++ rest Null -> rest _ -> error $ "sopSwaggerGenericToJSON: subjson is not an object: " ++ show json -- If default value: omit it. | Just x == def = rest | otherwise =- (T.pack name', json) : rest+ (fromString name', json) : rest where json = toJSON x name' = fieldNameModifier name rest = go xs names defs-#if __GLASGOW_HASKELL__ < 800- go _ _ _ = error "not empty"-#endif fieldNameModifier = modifier . drop 1 modifier = lowerFirstUppers . drop (length prefix)@@ -213,7 +204,7 @@ parseAdditionalField :: Object -> (Text, Value) -> Parser () parseAdditionalField obj (k, v) = do- v' <- obj .: k+ v' <- obj .: fromText k unless (v == v') $ fail $ "Additonal field don't match for key " ++ T.unpack k ++ ": " ++ show v@@ -226,11 +217,7 @@ -> DatatypeInfo '[xs] -> POP Maybe '[xs] -> Parser (SOP I '[xs])-#if MIN_VERSION_generics_sop(0,5,0) sopSwaggerGenericParseJSON' opts obj (ADT _ _ (Record _ fieldsInfo :* Nil) _) (POP (defs :* Nil)) =-#else-sopSwaggerGenericParseJSON' opts obj (ADT _ _ (Record _ fieldsInfo :* Nil)) (POP (defs :* Nil)) =-#endif SOP . Z <$> sopSwaggerGenericParseJSON'' opts obj fieldsInfo defs sopSwaggerGenericParseJSON' _ _ _ _ = error "sopSwaggerGenericParseJSON: unsupported type" @@ -248,10 +235,10 @@ go (FieldInfo name :* names) (def :* defs) | Just name' == sub = -- Note: we might strip fields of outer structure.- cons <$> (withDef $ parseJSON $ Object obj) <*> rest+ cons <$> withDef (parseJSON $ Object obj) <*> rest | otherwise = case def of- Just def' -> cons <$> obj .:? T.pack name' .!= def' <*> rest- Nothing -> cons <$> obj .: T.pack name' <*> rest+ Just def' -> cons <$> obj .:? fromString name' .!= def' <*> rest+ Nothing -> cons <$> obj .: fromString name' <*> rest where cons h t = I h :* t name' = fieldNameModifier name@@ -260,9 +247,6 @@ withDef = case def of Just def' -> (<|> pure def') Nothing -> id-#if __GLASGOW_HASKELL__ < 800- go _ _ = error "not empty"-#endif fieldNameModifier = modifier . drop 1 modifier = lowerFirstUppers . drop (length prefix)@@ -273,8 +257,6 @@ -- ToEncoding ------------------------------------------------------------------------------- -#if MIN_VERSION_aeson(0,10,0)- sopSwaggerGenericToEncoding :: forall a xs. ( HasDatatypeInfo a@@ -287,7 +269,7 @@ -> Encoding sopSwaggerGenericToEncoding x = let ps = sopSwaggerGenericToEncoding' opts (from x) (datatypeInfo proxy) (aesonDefaults proxy)- in pairs (pairsToSeries (opts ^. saoAdditionalPairs) <> ps)+ in pairs (pairsToSeries ((map $ first fromText) (opts ^. saoAdditionalPairs)) <> ps) where proxy = Proxy :: Proxy a opts = swaggerAesonOptions proxy@@ -302,11 +284,7 @@ -> DatatypeInfo '[xs] -> POP Maybe '[xs] -> Series-#if MIN_VERSION_generics_sop(0,5,0) sopSwaggerGenericToEncoding' opts (SOP (Z fields)) (ADT _ _ (Record _ fieldsInfo :* Nil) _) (POP (defs :* Nil)) =-#else-sopSwaggerGenericToEncoding' opts (SOP (Z fields)) (ADT _ _ (Record _ fieldsInfo :* Nil)) (POP (defs :* Nil)) =-#endif sopSwaggerGenericToEncoding'' opts fields fieldsInfo defs sopSwaggerGenericToEncoding' _ _ _ _ = error "sopSwaggerGenericToEncoding: unsupported type" @@ -323,24 +301,19 @@ go Nil Nil Nil = mempty go (I x :* xs) (FieldInfo name :* names) (def :* defs) | Just name' == sub = case toJSON x of- Object m -> pairsToSeries (HM.toList m) <> rest+ Object m -> pairsToSeries (KM.toList m) <> rest Null -> rest _ -> error $ "sopSwaggerGenericToJSON: subjson is not an object: " ++ show (toJSON x) -- If default value: omit it. | Just x == def = rest | otherwise =- (T.pack name' .= x) <> rest+ (fromString name' .= x) <> rest where name' = fieldNameModifier name rest = go xs names defs-#if __GLASGOW_HASKELL__ < 800- go _ _ _ = error "not empty"-#endif fieldNameModifier = modifier . drop 1 modifier = lowerFirstUppers . drop (length prefix) lowerFirstUppers s = map toLower x ++ y where (x, y) = span isUpper s--#endif
src/Data/Swagger/Internal/ParamSchema.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-}@@ -12,13 +11,10 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE UndecidableInstances #-}-#if __GLASGOW_HASKELL__ >= 800 -- Generic a is redundant in ToParamSchema a default imple {-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For TypeErrors {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}-#endif-#include "overlapping-compat.h" module Data.Swagger.Internal.ParamSchema where import Control.Lens@@ -49,12 +45,9 @@ import Data.Swagger.Lens import Data.Swagger.SchemaOptions -#if __GLASGOW_HASKELL__ < 800-#else import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL import GHC.TypeLits (TypeError, ErrorMessage(..))-#endif -- | Default schema for binary data (any sequence of octets). binaryParamSchema :: ParamSchema t@@ -119,7 +112,7 @@ default toParamSchema :: (Generic a, GToParamSchema (Rep a)) => Proxy a -> ParamSchema t toParamSchema = genericToParamSchema defaultSchemaOptions -instance OVERLAPPING_ ToParamSchema String where+instance {-# OVERLAPPING #-} ToParamSchema String where toParamSchema _ = mempty & type_ ?~ SwaggerString instance ToParamSchema Bool where@@ -147,9 +140,13 @@ instance ToParamSchema Word where toParamSchema = toParamSchemaBoundedIntegral instance ToParamSchema Word8 where toParamSchema = toParamSchemaBoundedIntegral instance ToParamSchema Word16 where toParamSchema = toParamSchemaBoundedIntegral-instance ToParamSchema Word32 where toParamSchema = toParamSchemaBoundedIntegral-instance ToParamSchema Word64 where toParamSchema = toParamSchemaBoundedIntegral +instance ToParamSchema Word32 where+ toParamSchema proxy = toParamSchemaBoundedIntegral proxy & format ?~ "int32"++instance ToParamSchema Word64 where+ toParamSchema proxy = toParamSchemaBoundedIntegral proxy & format ?~ "int64"+ -- | Default plain schema for @'Bounded'@, @'Integral'@ types. -- -- >>> encode $ toParamSchemaBoundedIntegral (Proxy :: Proxy Int8)@@ -235,9 +232,6 @@ toParamSchema _ = mempty & type_ ?~ SwaggerString --#if __GLASGOW_HASKELL__ < 800-#else type family ToParamSchemaByteStringError bs where ToParamSchemaByteStringError bs = TypeError ( 'Text "Impossible to have an instance " :<>: ShowType (ToParamSchema bs) :<>: Text "."@@ -246,7 +240,6 @@ instance ToParamSchemaByteStringError BS.ByteString => ToParamSchema BS.ByteString where toParamSchema = error "impossible" instance ToParamSchemaByteStringError BSL.ByteString => ToParamSchema BSL.ByteString where toParamSchema = error "impossible"-#endif instance ToParamSchema All where toParamSchema _ = toParamSchema (Proxy :: Proxy Bool) instance ToParamSchema Any where toParamSchema _ = toParamSchema (Proxy :: Proxy Bool)@@ -277,7 +270,7 @@ -- | -- >>> encode $ toParamSchema (Proxy :: Proxy ())--- "{\"type\":\"string\",\"enum\":[\"_\"]}"+-- "{\"enum\":[\"_\"],\"type\":\"string\"}" instance ToParamSchema () where toParamSchema _ = mempty & type_ ?~ SwaggerString@@ -293,7 +286,7 @@ -- >>> :set -XDeriveGeneric -- >>> data Color = Red | Blue deriving Generic -- >>> encode $ genericToParamSchema defaultSchemaOptions (Proxy :: Proxy Color)--- "{\"type\":\"string\",\"enum\":[\"Red\",\"Blue\"]}"+-- "{\"enum\":[\"Red\",\"Blue\"],\"type\":\"string\"}" genericToParamSchema :: forall a t. (Generic a, GToParamSchema (Rep a)) => SchemaOptions -> Proxy a -> ParamSchema t genericToParamSchema opts _ = gtoParamSchema opts (Proxy :: Proxy (Rep a)) mempty
src/Data/Swagger/Internal/Schema.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-}@@ -15,13 +14,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 ()@@ -71,12 +66,11 @@ 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(..))-#endif+import qualified Data.Aeson.KeyMap as KM+import Data.Aeson.Key (toText) unnamed :: Schema -> NamedSchema unnamed schema = NamedSchema Nothing schema@@ -329,7 +323,7 @@ -- >>> data Person = Person { name :: String, age :: Int } deriving (Generic) -- >>> instance ToJSON Person -- >>> encode $ sketchSchema (Person "Jack" 25)--- "{\"required\":[\"age\",\"name\"],\"properties\":{\"age\":{\"type\":\"number\"},\"name\":{\"type\":\"string\"}},\"example\":{\"age\":25,\"name\":\"Jack\"},\"type\":\"object\"}"+-- "{\"required\":[\"name\",\"age\"],\"properties\":{\"name\":{\"type\":\"string\"},\"age\":{\"type\":\"number\"}},\"example\":{\"age\":25,\"name\":\"Jack\"},\"type\":\"object\"}" sketchSchema :: ToJSON a => a -> Schema sketchSchema = sketch . toJSON where@@ -353,7 +347,7 @@ ischema = case ys of (z:_) | allSame -> Just z _ -> Nothing- go (Object o) = mempty+ go (Object o') = let o = KM.toHashMapText o' in mempty & type_ ?~ SwaggerObject & required .~ HashMap.keys o & properties .~ fmap (Inline . go) (InsOrdHashMap.fromHashMap o)@@ -362,18 +356,18 @@ -- 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 -- >>> 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\":[\"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\"}" sketchStrictSchema :: ToJSON a => a -> Schema sketchStrictSchema = go . toJSON where@@ -403,7 +397,7 @@ where sz = length xs allUnique = sz == HashSet.size (HashSet.fromList (V.toList xs))- go js@(Object o) = mempty+ go js@(Object o') = let o = KM.toHashMapText o' in mempty & type_ ?~ SwaggerObject & required .~ names & properties .~ fmap (Inline . go) (InsOrdHashMap.fromHashMap o)@@ -411,19 +405,19 @@ & minProperties ?~ fromIntegral (length names) & enum_ ?~ [js] where- names = HashMap.keys o+ names = HashMap.keys (KM.toHashMapText o') class GToSchema (f :: * -> *) where gdeclareNamedSchema :: SchemaOptions -> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema -instance OVERLAPPABLE_ ToSchema a => ToSchema [a] where+instance {-# OVERLAPPABLE #-} ToSchema a => ToSchema [a] where declareNamedSchema _ = do ref <- declareSchemaRef (Proxy :: Proxy a) return $ unnamed $ mempty & type_ ?~ SwaggerArray & items ?~ SwaggerItemsObject ref -instance OVERLAPPING_ ToSchema String where declareNamedSchema = plain . paramSchemaToSchema+instance {-# OVERLAPPING #-} ToSchema String where declareNamedSchema = plain . paramSchemaToSchema instance ToSchema Bool where declareNamedSchema = plain . paramSchemaToSchema instance ToSchema Integer where declareNamedSchema = plain . paramSchemaToSchema instance ToSchema Natural where declareNamedSchema = plain . paramSchemaToSchema@@ -505,8 +499,6 @@ instance ToSchema Version where declareNamedSchema = plain . paramSchemaToSchema -#if __GLASGOW_HASKELL__ < 800-#else type family ToSchemaByteStringError bs where ToSchemaByteStringError bs = TypeError ( Text "Impossible to have an instance " :<>: ShowType (ToSchema bs) :<>: Text "."@@ -515,7 +507,6 @@ instance ToSchemaByteStringError BS.ByteString => ToSchema BS.ByteString where declareNamedSchema = error "impossible" instance ToSchemaByteStringError BSL.ByteString => ToSchema BSL.ByteString where declareNamedSchema = error "impossible"-#endif instance ToSchema IntSet where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Set Int)) @@ -523,7 +514,6 @@ instance ToSchema a => ToSchema (IntMap a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [(Int, a)]) -#if MIN_VERSION_aeson(1,0,0) instance (ToJSONKey k, ToSchema k, ToSchema v) => ToSchema (Map k v) where declareNamedSchema _ = case toJSONKey :: ToJSONKeyFunction k of ToJSONKeyText _ _ -> declareObjectMapSchema@@ -538,25 +528,7 @@ instance (ToJSONKey k, ToSchema k, ToSchema v) => ToSchema (HashMap k v) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map k v)) -#else--instance ToSchema a => ToSchema (Map String a) where- declareNamedSchema _ = do- schema <- declareSchemaRef (Proxy :: Proxy a)- return $ unnamed $ mempty- & type_ ?~ SwaggerObject- & additionalProperties ?~ schema--instance ToSchema a => ToSchema (Map T.Text a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map String a))-instance ToSchema a => ToSchema (Map TL.Text a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map String a))--instance ToSchema a => ToSchema (HashMap String a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map String a))-instance ToSchema a => ToSchema (HashMap T.Text a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map String a))-instance ToSchema a => ToSchema (HashMap TL.Text a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map String a))--#endif--instance OVERLAPPING_ ToSchema Object where+instance {-# OVERLAPPING #-} ToSchema Object where declareNamedSchema _ = pure $ NamedSchema (Just "Object") $ mempty & type_ ?~ SwaggerObject & description ?~ "Arbitrary JSON object."@@ -643,9 +615,9 @@ objectSchema keyToText = do valueRef <- declareSchemaRef (Proxy :: Proxy value) let allKeys = [minBound..maxBound :: key]- mkPair k = (keyToText k, valueRef)+ mkPair k = (toText $ keyToText k, valueRef) return $ mempty- & type_ ?~ SwaggerObject+ & type_ ?~ SwaggerObject & properties .~ InsOrdHashMap.fromList (map mkPair allKeys) -- | A 'Schema' for a mapping with 'Bounded' 'Enum' keys.@@ -738,10 +710,10 @@ where name = gdatatypeSchemaName opts (Proxy :: Proxy d) -instance OVERLAPPABLE_ GToSchema f => GToSchema (C1 c f) where+instance {-# OVERLAPPABLE #-} GToSchema f => GToSchema (C1 c f) where gdeclareNamedSchema opts _ = gdeclareNamedSchema opts (Proxy :: Proxy f) -instance OVERLAPPING_ Constructor c => GToSchema (C1 c U1) where+instance {-# OVERLAPPING #-} Constructor c => GToSchema (C1 c U1) where gdeclareNamedSchema = gdeclareNamedSumSchema -- | Single field constructor.@@ -804,17 +776,17 @@ fname = T.pack (fieldLabelModifier opts (selName (Proxy3 :: Proxy3 s f p))) -- | Optional record fields.-instance OVERLAPPING_ (Selector s, ToSchema c) => GToSchema (S1 s (K1 i (Maybe c))) where+instance {-# OVERLAPPING #-} (Selector s, ToSchema c) => GToSchema (S1 s (K1 i (Maybe c))) where gdeclareNamedSchema opts _ = fmap unnamed . withFieldSchema opts (Proxy2 :: Proxy2 s (K1 i (Maybe c))) False -- | Record fields.-instance OVERLAPPABLE_ (Selector s, GToSchema f) => GToSchema (S1 s f) where+instance {-# OVERLAPPABLE #-} (Selector s, GToSchema f) => GToSchema (S1 s f) where gdeclareNamedSchema opts _ = fmap unnamed . withFieldSchema opts (Proxy2 :: Proxy2 s f) True -instance OVERLAPPING_ ToSchema c => GToSchema (K1 i (Maybe c)) where+instance {-# OVERLAPPING #-} ToSchema c => GToSchema (K1 i (Maybe c)) where gdeclareNamedSchema _ _ _ = declareNamedSchema (Proxy :: Proxy c) -instance OVERLAPPABLE_ ToSchema c => GToSchema (K1 i c) where+instance {-# OVERLAPPABLE #-} ToSchema c => GToSchema (K1 i c) where gdeclareNamedSchema _ _ _ = declareNamedSchema (Proxy :: Proxy c) instance ( GSumToSchema f@@ -859,7 +831,7 @@ ref <- gdeclareSchemaRef opts proxy return $ gsumConToSchemaWith ref opts proxy schema -instance OVERLAPPABLE_ (Constructor c, GToSchema f) => GSumToSchema (C1 c f) where+instance {-# OVERLAPPABLE #-} (Constructor c, GToSchema f) => GSumToSchema (C1 c f) where gsumToSchema opts proxy schema = do tell (All False) lift $ gsumConToSchema opts proxy schema
src/Data/Swagger/Internal/Schema/Validation.hs view
@@ -50,6 +50,7 @@ import Data.Swagger.Internal import Data.Swagger.Internal.Schema import Data.Swagger.Lens+import qualified Data.Aeson.KeyMap as KM -- | Validate @'ToJSON'@ instance matches @'ToSchema'@ for a given value. -- This can be used with QuickCheck to ensure those instances are coherent:@@ -101,33 +102,33 @@ -- <BLANKLINE> -- Swagger Schema: -- {--- "required": [--- "name",--- "phone"--- ],--- "type": "object", -- "properties": {--- "phone": {--- "$ref": "#/definitions/Phone"--- }, -- "name": { -- "type": "string"+-- },+-- "phone": {+-- "$ref": "#/definitions/Phone" -- }--- }+-- },+-- "required": [+-- "name",+-- "phone"+-- ],+-- "type": "object" -- } -- <BLANKLINE> -- Swagger Description Context: -- { -- "Phone": {--- "required": [--- "value"--- ],--- "type": "object", -- "properties": { -- "value": { -- "type": "string" -- }--- }+-- },+-- "required": [+-- "value"+-- ],+-- "type": "object" -- } -- } -- <BLANKLINE>@@ -375,7 +376,7 @@ validateObject o = withSchema $ \sch -> case sch ^. discriminator of Just pname -> case fromJSON <$> HashMap.lookup pname o of- Just (Success ref) -> validateWithSchemaRef ref (Object o)+ Just (Success ref) -> validateWithSchemaRef ref (Object $ KM.fromHashMapText o) Just (Error msg) -> invalid ("failed to parse discriminator property " ++ show pname ++ ": " ++ show msg) Nothing -> invalid ("discriminator property " ++ show pname ++ "is missing") Nothing -> do@@ -476,14 +477,14 @@ (Just SwaggerNumber, Number n) -> sub_ paramSchema (validateNumber n) (Just SwaggerString, String s) -> sub_ paramSchema (validateString s) (Just SwaggerArray, Array xs) -> sub_ paramSchema (validateArray xs)- (Just SwaggerObject, Object o) -> validateObject o+ (Just SwaggerObject, Object o) -> validateObject $ KM.toHashMapText o (Nothing, Null) -> valid (Nothing, Bool _) -> valid -- Number by default (Nothing, Number n) -> sub_ paramSchema (validateNumber n) (Nothing, String s) -> sub_ paramSchema (validateString s) (Nothing, Array xs) -> sub_ paramSchema (validateArray xs)- (Nothing, Object o) -> validateObject o+ (Nothing, Object o) -> validateObject $ KM.toHashMapText o bad -> invalid $ "expected JSON value of type " ++ showType bad validateParamSchemaType :: Value -> Validation (ParamSchema t) ()
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/Lens.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-}@@ -10,7 +9,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-}-#include "overlapping-compat.h" -- | -- Module: Data.Swagger.Lens -- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>@@ -118,69 +116,63 @@ -- OVERLAPPABLE instances instance-#if __GLASGOW_HASKELL__ >= 710- OVERLAPPABLE_-#endif+ {-# OVERLAPPABLE #-} HasParamSchema s (ParamSchema t) => HasFormat s (Maybe Format) where format = paramSchema.format instance-#if __GLASGOW_HASKELL__ >= 710- OVERLAPPABLE_-#endif+ {-# OVERLAPPABLE #-} HasParamSchema s (ParamSchema t) => HasItems s (Maybe (SwaggerItems t)) where items = paramSchema.items instance-#if __GLASGOW_HASKELL__ >= 710- OVERLAPPABLE_-#endif+ {-# OVERLAPPABLE #-} HasParamSchema s (ParamSchema t) => HasMaximum s (Maybe Scientific) where maximum_ = paramSchema.maximum_ -instance OVERLAPPABLE_ HasParamSchema s (ParamSchema t)+instance {-# OVERLAPPABLE #-} HasParamSchema s (ParamSchema t) => HasExclusiveMaximum s (Maybe Bool) where exclusiveMaximum = paramSchema.exclusiveMaximum -instance OVERLAPPABLE_ HasParamSchema s (ParamSchema t)+instance {-# OVERLAPPABLE #-} HasParamSchema s (ParamSchema t) => HasMinimum s (Maybe Scientific) where minimum_ = paramSchema.minimum_ -instance OVERLAPPABLE_ HasParamSchema s (ParamSchema t)+instance {-# OVERLAPPABLE #-} HasParamSchema s (ParamSchema t) => HasExclusiveMinimum s (Maybe Bool) where exclusiveMinimum = paramSchema.exclusiveMinimum -instance OVERLAPPABLE_ HasParamSchema s (ParamSchema t)+instance {-# OVERLAPPABLE #-} HasParamSchema s (ParamSchema t) => HasMaxLength s (Maybe Integer) where maxLength = paramSchema.maxLength -instance OVERLAPPABLE_ HasParamSchema s (ParamSchema t)+instance {-# OVERLAPPABLE #-} HasParamSchema s (ParamSchema t) => HasMinLength s (Maybe Integer) where minLength = paramSchema.minLength -instance OVERLAPPABLE_ HasParamSchema s (ParamSchema t)+instance {-# OVERLAPPABLE #-} HasParamSchema s (ParamSchema t) => HasPattern s (Maybe Text) where pattern = paramSchema.pattern -instance OVERLAPPABLE_ HasParamSchema s (ParamSchema t)+instance {-# OVERLAPPABLE #-} HasParamSchema s (ParamSchema t) => HasMaxItems s (Maybe Integer) where maxItems = paramSchema.maxItems -instance OVERLAPPABLE_ HasParamSchema s (ParamSchema t)+instance {-# OVERLAPPABLE #-} HasParamSchema s (ParamSchema t) => HasMinItems s (Maybe Integer) where minItems = paramSchema.minItems -instance OVERLAPPABLE_ HasParamSchema s (ParamSchema t)+instance {-# OVERLAPPABLE #-} HasParamSchema s (ParamSchema t) => HasUniqueItems s (Maybe Bool) where uniqueItems = paramSchema.uniqueItems -instance OVERLAPPABLE_ HasParamSchema s (ParamSchema t)+instance {-# OVERLAPPABLE #-} HasParamSchema s (ParamSchema t) => HasEnum s (Maybe [Value]) where enum_ = paramSchema.enum_ -instance OVERLAPPABLE_ HasParamSchema s (ParamSchema t)+instance {-# OVERLAPPABLE #-} HasParamSchema s (ParamSchema t) => HasMultipleOf s (Maybe Scientific) where multipleOf = paramSchema.multipleOf
src/Data/Swagger/Operation.hs view
@@ -80,9 +80,9 @@ -- >>> let api = (mempty :: Swagger) & paths .~ [("/user", mempty & get ?~ ok & post ?~ ok)] -- >>> let sub = (mempty :: Swagger) & paths .~ [("/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@@ -139,7 +139,7 @@ -- >>> let api = (mempty :: Swagger) & paths .~ [("/user", mempty & get ?~ mempty)] -- >>> let res = declareResponse (Proxy :: Proxy Day) -- >>> encode $ api & setResponse 200 res--- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"paths\":{\"/user\":{\"get\":{\"responses\":{\"200\":{\"schema\":{\"$ref\":\"#/definitions/Day\"},\"description\":\"\"}}}}},\"definitions\":{\"Day\":{\"example\":\"2016-07-22\",\"format\":\"date\",\"type\":\"string\"}}}"+-- "{\"swagger\":\"2.0\",\"info\":{\"title\":\"\",\"version\":\"\"},\"paths\":{\"/user\":{\"get\":{\"responses\":{\"200\":{\"description\":\"\",\"schema\":{\"$ref\":\"#/definitions/Day\"}}}}}},\"definitions\":{\"Day\":{\"example\":\"2016-07-22\",\"format\":\"date\",\"type\":\"string\"}}}" -- -- See also @'setResponseWith'@. setResponse :: HttpStatusCode -> Declare (Definitions Schema) Response -> Swagger -> Swagger
src/Data/Swagger/Optics.hs view
@@ -29,7 +29,7 @@ -- & at 200 ?~ ("OK" & #_Inline % #schema ?~ Ref (Reference "User")) -- & at 404 ?~ "User info not found")) ] -- :}--- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"paths\":{\"/user\":{\"get\":{\"produces\":[\"application/json\"],\"responses\":{\"404\":{\"description\":\"User info not found\"},\"200\":{\"schema\":{\"$ref\":\"#/definitions/User\"},\"description\":\"OK\"}}}}},\"definitions\":{\"User\":{\"type\":\"string\"}}}"+-- "{\"swagger\":\"2.0\",\"info\":{\"title\":\"\",\"version\":\"\"},\"paths\":{\"/user\":{\"get\":{\"produces\":[\"application/json\"],\"responses\":{\"200\":{\"description\":\"OK\",\"schema\":{\"$ref\":\"#/definitions/User\"}},\"404\":{\"description\":\"User info not found\"}}}}},\"definitions\":{\"User\":{\"type\":\"string\"}}}" -- -- For convenience optics are defined as /labels/. It means that field accessor -- names can be overloaded for different types. One such common field is
src/Data/Swagger/Schema/Generator.hs view
@@ -10,10 +10,10 @@ import Control.Lens.Operators import Control.Monad (filterM) import Data.Aeson+import qualified Data.Aeson.KeyMap as KM import Data.Aeson.Types import qualified Data.HashMap.Strict.InsOrd as M import Data.Maybe-import Data.Maybe import Data.Proxy import Data.Scientific import qualified Data.Set as S@@ -94,7 +94,7 @@ return . M.fromList $ zip additionalKeys (repeat . schemaGen defns $ dereference defns addlSchema) _ -> return [] x <- sequence $ gens <> additionalGens- return . Object $ M.toHashMap x+ return . Object . KM.fromHashMapText $ M.toHashMap x where dereference :: Definitions a -> Referenced a -> a dereference _ (Inline a) = a
swagger2.cabal view
@@ -1,6 +1,6 @@ cabal-version: >=1.10 name: swagger2-version: 2.6+version: 2.7 synopsis: Swagger 2.0 data model category: Web, Swagger@@ -22,14 +22,13 @@ README.md , CHANGELOG.md , examples/*.hs- , include/overlapping-compat.h tested-with:- GHC ==8.0.2- || ==8.2.2- || ==8.4.4+ GHC ==8.4.4 || ==8.6.5- || ==8.8.1- || ==8.10.1+ || ==8.8.4+ || ==8.10.4+ || ==8.10.7+ || ==9.0.1 custom-setup setup-depends:@@ -37,7 +36,6 @@ library hs-source-dirs: src- include-dirs: include exposed-modules: Data.Swagger Data.Swagger.Declare@@ -61,38 +59,37 @@ -- GHC boot libraries build-depends:- base >=4.9 && <4.15- , bytestring >=0.10.4.0 && <0.11- , containers >=0.5.5.1 && <0.7- , template-haskell >=2.9.0.0 && <2.17- , time >=1.4.2 && <1.10- , transformers >=0.3.0.0 && <0.6+ base >=4.9 && <4.16+ , bytestring >=0.10.8.1 && <0.11+ , containers >=0.5.7.1 && <0.7+ , template-haskell >=2.11.1.0 && <2.18+ , time >=1.6.0.1 && <1.10+ , transformers >=0.5.2.0 && <0.6 build-depends:- mtl >=2.1 && <2.3+ mtl >=2.2.2 && <2.3 , text >=1.2.3.0 && <1.3 -- other dependencies build-depends:- base-compat-batteries >=0.10.4 && <0.12- , aeson >=1.4.2.0 && <1.5+ base-compat-batteries >=0.11.1 && <0.12+ , aeson >=2.0.0.0 && <2.1 , aeson-pretty >=0.8.7 && <0.9 -- cookie 0.4.3 is needed by GHC 7.8 due to time>=1.4 constraint , cookie >=0.4.3 && <0.5- , generics-sop >=0.3.2.0 && <0.6+ , generics-sop >=0.5.1.0 && <0.6 , hashable >=1.2.7.0 && <1.4- , http-media >=0.7.1.2 && <0.9+ , http-media >=0.8.0.0 && <0.9 , insert-ordered-containers >=0.2.3 && <0.3- , lens >=4.16.1 && <4.20+ , lens >=4.16.1 && <5.1 , network >=2.6.3.5 && <3.2- , optics-core >=0.2 && <0.4- , optics-th >=0.2 && <0.4+ , optics-core >=0.2 && <0.5+ , optics-th >=0.2 && <0.5 , scientific >=0.3.6.2 && <0.4- , transformers-compat >=0.3 && <0.7 , unordered-containers >=0.2.9.0 && <0.3 , uuid-types >=1.0.3 && <1.1 , vector >=0.12.0.1 && <0.13- , QuickCheck >=2.10.1 && <2.14+ , QuickCheck >=2.10.1 && <2.15 default-language: Haskell2010 @@ -123,14 +120,14 @@ -- test-suite only dependencies build-depends:- hspec >=2.5.5 && <2.8+ hspec >=2.5.5 && <2.9 , HUnit >=1.6.0.0 && <1.7 , quickcheck-instances >=0.3.19 && <0.14 , utf8-string >=1.0.1.1 && <1.1 -- https://github.com/haskell/cabal/issues/3708 build-tool-depends:- hspec-discover:hspec-discover >=2.5.5 && <2.8+ hspec-discover:hspec-discover >=2.5.5 && <2.9 other-modules: SpecCommon
test/Data/Swagger/CommonTestTypes.hs view
@@ -15,6 +15,7 @@ import Data.Proxy import Data.Set (Set) import qualified Data.Text as Text+import Data.Word import GHC.Generics import Data.Swagger@@ -675,5 +676,31 @@ { "type": "string", "format": "hh:MM:ss"+}+|]+++-- ========================================================================+-- UnsignedInts+-- ========================================================================+data UnsignedInts = UnsignedInts+ { unsignedIntsUint32 :: Word32+ , unsignedIntsUint64 :: Word64+ } deriving (Generic)++instance ToSchema UnsignedInts where+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions+ { fieldLabelModifier = map toLower . drop (length "unsignedInts") }++unsignedIntsSchemaJSON :: Value+unsignedIntsSchemaJSON = [aesonQQ|+{+ "type": "object",+ "properties":+ {+ "uint32": { "type": "integer", "format": "int32", "minimum": 0, "maximum": 4294967295 },+ "uint64": { "type": "integer", "format": "int64", "minimum": 0, "maximum": 18446744073709551615 }+ },+ "required": ["uint32", "uint64"] } |]
test/Data/Swagger/Schema/ValidationSpec.hs view
@@ -1,8 +1,8 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE PackageImports #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Data.Swagger.Schema.ValidationSpec where @@ -10,6 +10,8 @@ import Control.Lens ((&), (.~), (?~)) import Data.Aeson import Data.Aeson.Types+import Data.Aeson.Key+import qualified Data.Aeson.KeyMap as KM import Data.Hashable (Hashable) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap@@ -123,9 +125,9 @@ invalidPersonToJSON :: Person -> Value invalidPersonToJSON Person{..} = object- [ T.pack "personName" .= toJSON name- , T.pack "personPhone" .= toJSON phone- , T.pack "personEmail" .= toJSON email+ [ fromString "personName" .= toJSON name+ , fromString "personPhone" .= toJSON phone+ , fromString "personEmail" .= toJSON email ] -- ========================================================================@@ -252,7 +254,7 @@ & additionalProperties ?~ AdditionalPropertiesAllowed True instance Arbitrary FreeForm where- arbitrary = (FreeForm . fromList) <$> genObj+ arbitrary = FreeForm . fromList <$> genObj where genObj = listOf $ do k <- arbitrary@@ -270,9 +272,12 @@ -- Weights are almost random -- Uniform oneof tends not to build complex objects cause of recursive call. arbitrary = resize 4 $ frequency- [ (3, Object <$> arbitrary)+ [ (3, Object . KM.fromHashMapText <$> arbitrary) , (3, Array <$> arbitrary) , (3, String <$> arbitrary) , (3, Number <$> arbitrary) , (3, Bool <$> arbitrary) , (1, return Null) ]++instance Arbitrary (KM.KeyMap Value) where+ arbitrary = KM.fromHashMapText <$> arbitrary
test/Data/Swagger/SchemaSpec.hs view
@@ -85,6 +85,7 @@ context "Status (sum of unary constructors)" $ checkToSchema (Proxy :: Proxy Status) statusSchemaJSON context "Character (ref and record sum)" $ checkToSchema (Proxy :: Proxy Character) characterSchemaJSON context "Light (sum with unwrapUnaryRecords)" $ checkToSchema (Proxy :: Proxy Light) lightSchemaJSON+ context "UnsignedInts" $ checkToSchema (Proxy :: Proxy UnsignedInts) unsignedIntsSchemaJSON context "Schema name" $ do context "String" $ checkSchemaName Nothing (Proxy :: Proxy String) context "(Int, Float)" $ checkSchemaName Nothing (Proxy :: Proxy (Int, Float))
test/Data/SwaggerSpec.hs view
@@ -46,6 +46,7 @@ describe "OAuth2 Security Definitions with merged Scope" $ oAuth2SecurityDefinitionsExample <=> oAuth2SecurityDefinitionsExampleJSON describe "Composition Schema Example" $ compositionSchemaExample <=> compositionSchemaExampleJSON describe "Swagger Object" $ do+ context "Example with no paths" $ emptyPathsFieldExample <=> emptyPathsFieldExampleJSON context "Todo Example" $ swaggerExample <=> swaggerExampleJSON context "PetStore Example" $ it "decodes successfully" $ do@@ -536,6 +537,18 @@ -- ======================================================================= -- Swagger object -- =======================================================================++emptyPathsFieldExample :: Swagger+emptyPathsFieldExample = mempty++emptyPathsFieldExampleJSON :: Value+emptyPathsFieldExampleJSON = [aesonQQ|+{+ "swagger": "2.0",+ "info": {"version": "", "title": ""},+ "paths": {}+}+|] swaggerExample :: Swagger swaggerExample = mempty
test/SpecCommon.hs view
@@ -1,18 +1,20 @@ module SpecCommon where import Data.Aeson+import Data.Aeson.Key import Data.ByteString.Builder (toLazyByteString)-import qualified Data.Foldable as F+import qualified Data.Foldable as F import qualified Data.HashMap.Strict as HashMap-import qualified Data.Vector as Vector+import qualified Data.Aeson.KeyMap as KM+import qualified Data.Vector as Vector import Test.Hspec isSubJSON :: Value -> Value -> Bool isSubJSON Null _ = True-isSubJSON (Object x) (Object y) = HashMap.keys x == HashMap.keys i && F.and i+isSubJSON (Object x) (Object y) = map toText (KM.keys x) == HashMap.keys i && F.and i where- i = HashMap.intersectionWith isSubJSON x y+ i = HashMap.intersectionWith isSubJSON (KM.toHashMapText x) (KM.toHashMapText y) isSubJSON (Array xs) (Array ys) = Vector.length xs == Vector.length ys && F.and (Vector.zipWith isSubJSON xs ys) isSubJSON x y = x == y