swagger2 2.3.0.1 → 2.3.1
raw patch · 8 files changed
+345/−63 lines, 8 filesdep +cookiedep ~QuickCheckdep ~aesondep ~hspec
Dependencies added: cookie
Dependency ranges changed: QuickCheck, aeson, hspec
Files
- CHANGELOG.md +10/−0
- src/Data/Swagger/Internal.hs +36/−2
- src/Data/Swagger/Internal/ParamSchema.hs +6/−0
- src/Data/Swagger/Schema/Generator.hs +106/−0
- swagger2.cabal +17/−14
- test/Data/Aeson/QQ/Simple.hs +0/−45
- test/Data/Swagger/CommonTestTypes.hs +2/−2
- test/Data/Swagger/Schema/GeneratorSpec.hs +168/−0
CHANGELOG.md view
@@ -1,3 +1,13 @@+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 -------
src/Data/Swagger/Internal.hs view
@@ -65,6 +65,10 @@ #define DEFINE_TOENCODING #endif +-- $setup+-- >>> :seti -XDataKinds+-- >>> import Data.Aeson+ -- | A list of definitions that can be used in references. type Definitions = InsOrdHashMap Text @@ -1050,11 +1054,22 @@ toJSON = sopSwaggerGenericToJSON DEFINE_TOENCODING +-- | 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@@ -1171,7 +1186,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@@ -1186,8 +1207,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
src/Data/Swagger/Internal/ParamSchema.hs view
@@ -43,6 +43,7 @@ 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@@ -223,6 +224,11 @@ toParamSchema _ = mempty & type_ .~ SwaggerString & pattern ?~ "^\\d+(\\.\\d+)*$"++instance ToParamSchema SetCookie where+ toParamSchema _ = mempty+ & type_ .~ SwaggerString+ #if __GLASGOW_HASKELL__ < 800 #else
+ src/Data/Swagger/Schema/Generator.hs view
@@ -0,0 +1,106 @@+{-# 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 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+import Data.Swagger+import Data.Swagger.Declare+import qualified Data.Text as T+import qualified Data.Vector as V+import Test.QuickCheck (arbitrary)+import Test.QuickCheck.Gen+import Test.QuickCheck.Property++schemaGen :: Definitions Schema -> Schema -> Gen Value+schemaGen _ schema+ | Just cases <- schema ^. paramSchema . enum_ = elements cases+schemaGen defns schema =+ case schema ^. type_ of+ SwaggerBoolean -> Bool <$> elements [True, False]+ SwaggerNull -> pure Null+ SwaggerNumber+ | Just min <- schema ^. minimum_+ , Just max <- schema ^. maximum_ ->+ Number . fromFloatDigits <$>+ choose (toRealFloat min, toRealFloat max :: Double)+ | otherwise -> Number .fromFloatDigits <$> (arbitrary :: Gen Double)+ SwaggerInteger+ | Just min <- schema ^. minimum_+ , Just max <- schema ^. maximum_ ->+ Number . fromInteger <$>+ choose (truncate min, truncate max)+ | otherwise -> Number . fromInteger <$> arbitrary+ 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+ 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+ 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 $ 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+ }
swagger2.cabal view
@@ -1,11 +1,11 @@ cabal-version: >=1.10 name: swagger2-version: 2.3.0.1+version: 2.3.1 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/.@@ -28,12 +28,12 @@ || ==7.10.3 || ==8.0.2 || ==8.2.2- || ==8.4.3- || ==8.6.1+ || ==8.4.4+ || ==8.6.2 custom-setup setup-depends:- base, Cabal, cabal-doctest >=1.0.2 && <1.1+ base, Cabal, cabal-doctest >=1.0.6 && <1.1 library hs-source-dirs: src@@ -45,6 +45,7 @@ Data.Swagger.Operation Data.Swagger.ParamSchema Data.Swagger.Schema+ Data.Swagger.Schema.Generator Data.Swagger.Schema.Validation Data.Swagger.SchemaOptions @@ -73,18 +74,21 @@ -- other dependencies build-depends: base-compat-batteries >=0.10.4 && <0.11- , aeson >=1.3.1.1 && <1.5- , generics-sop >=0.3.2.0 && <0.4+ , aeson >=1.4.2.0 && <1.5+ -- 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.5 , hashable >=1.2.7.0 && <1.3 , http-media >=0.7.1.2 && <0.8 , insert-ordered-containers >=0.2.1.0 && <0.3 , lens >=4.16.1 && <4.18- , network >=2.6.3.5 && <2.8+ , network >=2.6.3.5 && <2.9 , 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.13 default-language: Haskell2010 @@ -95,7 +99,7 @@ -- From library parat -- We need aeson's toEncoding for doctests too- build-depends: + build-depends: base , swagger2 , aeson@@ -114,15 +118,15 @@ -- test-suite only dependencies build-depends:- hspec >=2.5.5 && <2.6+ hspec >=2.5.5 && <2.7.0 , HUnit >=1.6.0.0 && <1.7- , QuickCheck >=2.11.3 && <2.12+ , QuickCheck >=2.11.3 && <2.13 , 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.6+ hspec-discover:hspec-discover >=2.5.5 && <2.7 other-modules: SpecCommon@@ -131,8 +135,7 @@ Data.Swagger.ParamSchemaSpec Data.Swagger.SchemaSpec Data.Swagger.Schema.ValidationSpec-- Data.Aeson.QQ.Simple+ Data.Swagger.Schema.GeneratorSpec default-language: Haskell2010 test-suite doctests
− test/Data/Aeson/QQ/Simple.hs
@@ -1,45 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}--- | Like "Data.Aeson.QQ" but without interpolation.-module Data.Aeson.QQ.Simple where--import Data.Aeson-import Data.ByteString.Lazy.UTF8 as UTF8-import qualified Data.HashMap.Strict as HM-import qualified Data.Text as T-import qualified Data.Vector as V-import Language.Haskell.TH-import Language.Haskell.TH.Quote-import Language.Haskell.TH.Syntax (Lift (..))-import Prelude ()-import Prelude.Compat--aesonQQ :: QuasiQuoter-aesonQQ = QuasiQuoter- { quoteExp = aesonExp- , quotePat = const $ error "No quotePat defined for jsonQQ"- , quoteType = const $ error "No quoteType defined for jsonQQ"- , quoteDec = const $ error "No quoteDec defined for jsonQQ"- }--aesonExp :: String -> ExpQ-aesonExp txt =- case eitherDecode $ UTF8.fromString txt of- Left err -> error $ "Error in aesonExp: " ++ show err- Right val -> liftValue val--liftValue :: Value -> ExpQ-liftValue (String str) = [| String $(liftText str) |]-liftValue Null = [| Null |]-liftValue (Number n) = [| Number (fromRational $(return $ LitE $ RationalL (toRational n))) |]-liftValue (Bool b) = [| Bool b |]-liftValue (Array arr) = [| Array $ V.fromList $(ListE <$> traverse liftValue (V.toList arr)) |]-liftValue (Object obj) = [| object $jsList |]- where- jsList :: ExpQ- jsList = ListE <$> traverse objs2list (HM.toList obj)-- objs2list :: (T.Text, Value) -> ExpQ- objs2list (key, value) = [| ($(liftText key), $(liftValue value)) |]--liftText :: T.Text -> ExpQ-liftText t = [| T.pack $(lift $ T.unpack t) |]
test/Data/Swagger/CommonTestTypes.hs view
@@ -552,7 +552,7 @@ "type": "object", "properties": {- "NoLight": { "type": "array", "items": [] },+ "NoLight": { "type": "array", "items": {}, "maxItems": 0, "example": [] }, "LightFreq": { "type": "number", "format": "double" }, "LightColor": { "$ref": "#/definitions/Color" }, "LightWaveLength": { "type": "number", "format": "double" }@@ -568,7 +568,7 @@ "type": "object", "properties": {- "NoLight": { "type": "array", "items": [] },+ "NoLight": { "type": "array", "items": {}, "maxItems": 0, "example": [] }, "LightFreq": { "type": "number", "format": "double" }, "LightColor": {
+ 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"]