diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 ------- diff --git a/src/Data/Swagger/Internal.hs b/src/Data/Swagger/Internal.hs --- a/src/Data/Swagger/Internal.hs +++ b/src/Data/Swagger/Internal.hs @@ -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 +-- . +-- +-- >>> 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 diff --git a/src/Data/Swagger/Internal/ParamSchema.hs b/src/Data/Swagger/Internal/ParamSchema.hs --- a/src/Data/Swagger/Internal/ParamSchema.hs +++ b/src/Data/Swagger/Internal/ParamSchema.hs @@ -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 diff --git a/src/Data/Swagger/Schema/Generator.hs b/src/Data/Swagger/Schema/Generator.hs new file mode 100644 --- /dev/null +++ b/src/Data/Swagger/Schema/Generator.hs @@ -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 + } diff --git a/swagger2.cabal b/swagger2.cabal --- a/swagger2.cabal +++ b/swagger2.cabal @@ -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 diff --git a/test/Data/Aeson/QQ/Simple.hs b/test/Data/Aeson/QQ/Simple.hs deleted file mode 100644 --- a/test/Data/Aeson/QQ/Simple.hs +++ /dev/null @@ -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) |] diff --git a/test/Data/Swagger/CommonTestTypes.hs b/test/Data/Swagger/CommonTestTypes.hs --- a/test/Data/Swagger/CommonTestTypes.hs +++ b/test/Data/Swagger/CommonTestTypes.hs @@ -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": { diff --git a/test/Data/Swagger/Schema/GeneratorSpec.hs b/test/Data/Swagger/Schema/GeneratorSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/Swagger/Schema/GeneratorSpec.hs @@ -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"]