016e4c3 · typeable/swagger2

git.iko.soy/typeable/swagger2

on master help sign in

Merge pull request #82 from phadej/stack-pedantic

016e4c3Oleg Grenrus10 years ago

src/Data/Swagger/Internal.hs+2−2

compare with master

unifiedsplit

@@ -458,7 +458,7 @@ deriving instance Show (SwaggerType t)

458swaggerTypeConstr :: Data (SwaggerType t) => SwaggerType t -> Constr

459swaggerTypeConstr t = mkConstr (dataTypeOf t) (show t) [] Prefix

460

461−swaggerTypeDataType :: Data (SwaggerType t) => SwaggerType t -> DataType

461+swaggerTypeDataType :: {- Data (SwaggerType t) => -} SwaggerType t -> DataType

462swaggerTypeDataType _ = mkDataType "Data.Swagger.SwaggerType" swaggerTypeConstrs

463

464swaggerCommonTypes :: [SwaggerType k]

@@ -605,7 +605,7 @@ data ParamSchema (t :: SwaggerKind *) = ParamSchema

605 , _paramSchemaMultipleOf :: Maybe Scientific

606 } deriving (Eq, Show, Generic, Typeable)

607

608−deriving instance (Typeable k, Data (SwaggerKindType k), Data (SwaggerType k), Data (SwaggerItems k)) => Data (ParamSchema k)

608+deriving instance (Typeable k, Data (SwaggerType k), Data (SwaggerItems k)) => Data (ParamSchema k)

609

610data Xml = Xml

611 { -- | Replaces the name of the element/attribute used for the described schema property.

src/Data/Swagger/Internal/AesonUtils.hs+3−6

@@ -101,8 +101,7 @@ instance AesonDefaultValue (InsOrd.InsOrdHashMap k v) where defaultValue = Just

101-- * possible to merge sub-object

102sopSwaggerGenericToJSON

103 :: forall a xs.

104− ( Generic a

105− , HasDatatypeInfo a

104+ ( HasDatatypeInfo a

106 , HasSwaggerAesonOptions a

105 , HasSwaggerAesonOptions a

107 , All2 ToJSON (Code a)

106 , All2 ToJSON (Code a)

108 , All2 Eq (Code a)

107 , All2 Eq (Code a)

@@ -190,8 +189,7 @@ sopSwaggerGenericToJSON'' (SwaggerAesonOptions prefix _ sub) = go

190

189

191sopSwaggerGenericParseJSON

190sopSwaggerGenericParseJSON

192 :: forall a xs.

191 :: forall a xs.

193− ( Generic a

194− , HasDatatypeInfo a

192+ ( HasDatatypeInfo a

195 , HasSwaggerAesonOptions a

193 , HasSwaggerAesonOptions a

196 , All2 FromJSON (Code a)

194 , All2 FromJSON (Code a)

197 , All2 Eq (Code a)

195 , All2 Eq (Code a)

@@ -270,8 +268,7 @@ sopSwaggerGenericParseJSON'' (SwaggerAesonOptions prefix _ sub) obj = go

270

268

271sopSwaggerGenericToEncoding

269sopSwaggerGenericToEncoding

272 :: forall a xs.

270 :: forall a xs.

273− ( Generic a

274− , HasDatatypeInfo a

271+ ( HasDatatypeInfo a

275 , HasSwaggerAesonOptions a

272 , HasSwaggerAesonOptions a

276 , All2 ToJSON (Code a)

273 , All2 ToJSON (Code a)

277 , All2 Eq (Code a)

274 , All2 Eq (Code a)

src/Data/Swagger/Internal/ParamSchema.hs+4

@@ -9,6 +9,10 @@

9{-# LANGUAGE ScopedTypeVariables #-}

10{-# LANGUAGE TypeOperators #-}

11{-# LANGUAGE TypeSynonymInstances #-}

12+#if __GLASGOW_HASKELL__ >= 800

13+-- Generic a is redundant in ToParamSchema a default imple

14+{-# OPTIONS_GHC -Wno-redundant-constraints #-}

15+#endif

12#include "overlapping-compat.h"

16#include "overlapping-compat.h"

13module Data.Swagger.Internal.ParamSchema where

17module Data.Swagger.Internal.ParamSchema where

src/Data/Swagger/Internal/Schema.hs+13−13

@@ -13,6 +13,10 @@

13{-# LANGUAGE TypeFamilies #-}

14{-# LANGUAGE TypeOperators #-}

15{-# LANGUAGE TypeSynonymInstances #-}

16+#if __GLASGOW_HASKELL__ >= 800

17+-- Few generics related redundant constraints

18+{-# OPTIONS_GHC -Wno-redundant-constraints #-}

19+#endif

16#include "overlapping-compat.h"

20#include "overlapping-compat.h"

17module Data.Swagger.Internal.Schema where

21module Data.Swagger.Internal.Schema where

@@ -22,20 +26,16 @@ import Prelude.Compat

22import Control.Lens

26import Control.Lens

23import Data.Data.Lens (template)

27import Data.Data.Lens (template)

25−import Control.Applicative

26import Control.Monad

29import Control.Monad

27import Control.Monad.Writer

30import Control.Monad.Writer

28import Data.Aeson

31import Data.Aeson

29−import qualified Data.Aeson.Types as Aeson

30import Data.Char

32import Data.Char

31import Data.Data (Data)

33import Data.Data (Data)

32import Data.Foldable (traverse_)

34import Data.Foldable (traverse_)

33−import Data.Function (on)

34import Data.HashMap.Strict (HashMap)

35import Data.HashMap.Strict (HashMap)

35import qualified Data.HashMap.Strict as HashMap

36import qualified Data.HashMap.Strict as HashMap

36import "unordered-containers" Data.HashSet (HashSet)

37import "unordered-containers" Data.HashSet (HashSet)

37import qualified "unordered-containers" Data.HashSet as HashSet

38import qualified "unordered-containers" Data.HashSet as HashSet

38−import Data.HashMap.Strict.InsOrd (InsOrdHashMap)

39import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap

40import Data.Int

41import Data.IntSet (IntSet)

@@ -318,11 +318,11 @@ sketchSchema = sketch . toJSON

318 sketch js@(Bool _) = go js

319 sketch js = go js & example ?~ js

320

321− go Null = mempty & type_ .~ SwaggerNull

321+ go Null = mempty & type_ .~ SwaggerNull

322− go js@(Bool _) = mempty & type_ .~ SwaggerBoolean

322+ go (Bool _) = mempty & type_ .~ SwaggerBoolean

323− go js@(String s) = mempty & type_ .~ SwaggerString

323+ go (String _) = mempty & type_ .~ SwaggerString

324− go js@(Number n) = mempty & type_ .~ SwaggerNumber

324+ go (Number _) = mempty & type_ .~ SwaggerNumber

325− go js@(Array xs) = mempty

325+ go (Array xs) = mempty

326 & type_ .~ SwaggerArray

327 & items ?~ case ischema of

328 Just s -> SwaggerItemsObject (Inline s)

@@ -332,9 +332,9 @@ sketchSchema = sketch . toJSON

332 allSame = and ((zipWith (==)) ys (tail ys))

333

334 ischema = case ys of

335− (z:zs) | allSame -> Just z

335+ (z:_) | allSame -> Just z

336− _ -> Nothing

336+ _ -> Nothing

337− go js@(Object o) = mempty

337+ go (Object o) = mempty

338 & type_ .~ SwaggerObject

339 & required .~ HashMap.keys o

340 & properties .~ fmap (Inline . go) (InsOrdHashMap.fromHashMap o)

@@ -649,7 +649,7 @@ gdeclareSchemaRef opts proxy = do

649 return $ Ref (Reference name)

650 _ -> Inline <$> gdeclareSchema opts proxy

651

652−appendItem :: Referenced Schema -> Maybe (SwaggerItems SwaggerKindSchema) -> Maybe (SwaggerItems SwaggerKindSchema)

652+appendItem :: Referenced Schema -> Maybe (SwaggerItems 'SwaggerKindSchema) -> Maybe (SwaggerItems 'SwaggerKindSchema)

653appendItem x Nothing = Just (SwaggerItemsArray [x])

654appendItem x (Just (SwaggerItemsArray xs)) = Just (SwaggerItemsArray (xs ++ [x]))

655appendItem _ _ = error "GToSchema.appendItem: cannot append to SwaggerItemsObject"

src/Data/Swagger/Internal/Schema/Validation.hs+24−25

@@ -22,7 +22,6 @@ module Data.Swagger.Internal.Schema.Validation where

23import Control.Applicative

24import Control.Lens

25−import Control.Lens.TH

26import Control.Monad (when)

25import Control.Monad (when)

28import Data.Aeson hiding (Result)

27import Data.Aeson hiding (Result)

@@ -30,7 +29,6 @@ import Data.Foldable (traverse_, for_, sequenceA_)

30import Data.HashMap.Strict (HashMap)

29import Data.HashMap.Strict (HashMap)

31import qualified Data.HashMap.Strict as HashMap

30import qualified Data.HashMap.Strict as HashMap

32import qualified "unordered-containers" Data.HashSet as HashSet

31import qualified "unordered-containers" Data.HashSet as HashSet

33−import Data.HashMap.Strict.InsOrd (InsOrdHashMap)

34import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap

32import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap

35import Data.Monoid

33import Data.Monoid

36import Data.Proxy

34import Data.Proxy

@@ -61,11 +59,12 @@ validateToJSON = validateToJSONWithPatternChecker (\_pattern _str -> True)

61-- For validation without patterns see @'validateToJSON'@.

59-- For validation without patterns see @'validateToJSON'@.

62validateToJSONWithPatternChecker :: forall a. (ToJSON a, ToSchema a) =>

60validateToJSONWithPatternChecker :: forall a. (ToJSON a, ToSchema a) =>

63 (Pattern -> Text -> Bool) -> a -> [ValidationError]

61 (Pattern -> Text -> Bool) -> a -> [ValidationError]

62+validateToJSONWithPatternChecker checker x =

64−validateToJSONWithPatternChecker checker x = case runValidation (validateWithSchema js) cfg schema of

63+ case runValidation (validateWithSchema js) cfg sch of

65 Failed xs -> xs

64 Failed xs -> xs

66 Passed _ -> mempty

65 Passed _ -> mempty

67 where

66 where

68− (defs, schema) = runDeclare (declareSchema (Proxy :: Proxy a)) mempty

67+ (defs, sch) = runDeclare (declareSchema (Proxy :: Proxy a)) mempty

69 js = toJSON x

68 js = toJSON x

70 cfg = defaultConfig

69 cfg = defaultConfig

71 { configPatternChecker = checker

70 { configPatternChecker = checker

@@ -95,7 +94,7 @@ instance Alternative Result where

95instance Monad Result where

94instance Monad Result where

96 return = pure

95 return = pure

97 Passed x >>= f = f x

96 Passed x >>= f = f x

98− Failed xs >>= f = Failed xs

97+ Failed xs >>= _ = Failed xs

100-- | Validation configuration.

99-- | Validation configuration.

101data Config = Config

100data Config = Config

@@ -140,7 +139,7 @@ instance Choice Validation where

140

139

141instance Monad (Validation s) where

140instance Monad (Validation s) where

142 return = pure

141 return = pure

143− Validation x >>= f = Validation (\c s -> x c s >>= \x -> runValidation (f x) c s)

142+ Validation x >>= f = Validation (\c s -> x c s >>= \y -> runValidation (f y) c s)

144 (>>) = (*>)

143 (>>) = (*>)

145

144

146withConfig :: (Config -> Validation s a) -> Validation s a

145withConfig :: (Config -> Validation s a) -> Validation s a

@@ -160,8 +159,8 @@ valid = pure ()

160-- | Validate schema's property given a lens into that property

159-- | Validate schema's property given a lens into that property

161-- and property checker.

160-- and property checker.

162check :: Lens' s (Maybe a) -> (a -> Validation s ()) -> Validation s ()

161check :: Lens' s (Maybe a) -> (a -> Validation s ()) -> Validation s ()

163−check l g = withSchema $ \schema ->

162+check l g = withSchema $ \sch ->

164− case schema ^. l of

163+ case sch ^. l of

165 Nothing -> valid

164 Nothing -> valid

166 Just x -> g x

165 Just x -> g x

167

166

@@ -181,7 +180,7 @@ withRef (Reference ref) f = withConfig $ \cfg ->

181 Just s -> f s

180 Just s -> f s

182

181

183validateWithSchemaRef :: Referenced Schema -> Value -> Validation s ()

182validateWithSchemaRef :: Referenced Schema -> Value -> Validation s ()

184−validateWithSchemaRef (Ref ref) js = withRef ref $ \schema -> sub schema (validateWithSchema js)

183+validateWithSchemaRef (Ref ref) js = withRef ref $ \sch -> sub sch (validateWithSchema js)

185validateWithSchemaRef (Inline s) js = sub s (validateWithSchema js)

184validateWithSchemaRef (Inline s) js = sub s (validateWithSchema js)

186

185

187-- | Validate JSON @'Value'@ with Swagger @'Schema'@.

186-- | Validate JSON @'Value'@ with Swagger @'Schema'@.

@@ -203,9 +202,9 @@ validateInteger n = do

203 validateNumber n

202 validateNumber n

204

203

205validateNumber :: Scientific -> Validation (ParamSchema t) ()

204validateNumber :: Scientific -> Validation (ParamSchema t) ()

206−validateNumber n = withConfig $ \cfg -> withSchema $ \schema -> do

205+validateNumber n = withConfig $ \_cfg -> withSchema $ \sch -> do

207− let exMax = Just True == schema ^. exclusiveMaximum

206+ let exMax = Just True == sch ^. exclusiveMaximum

208− exMin = Just True == schema ^. exclusiveMinimum

207+ exMin = Just True == sch ^. exclusiveMinimum

209

208

210 check maximum_ $ \m ->

209 check maximum_ $ \m ->

211 when (if exMax then (n >= m) else (n > m)) $

210 when (if exMax then (n >= m) else (n > m)) $

@@ -262,8 +261,8 @@ validateArray xs = do

262 allUnique = len == HashSet.size (HashSet.fromList (Vector.toList xs))

261 allUnique = len == HashSet.size (HashSet.fromList (Vector.toList xs))

263

262

264validateObject :: HashMap Text Value -> Validation Schema ()

263validateObject :: HashMap Text Value -> Validation Schema ()

265−validateObject o = withSchema $ \schema ->

264+validateObject o = withSchema $ \sch ->

266− case schema ^. discriminator of

265+ case sch ^. discriminator of

267 Just pname -> case fromJSON <$> HashMap.lookup pname o of

266 Just pname -> case fromJSON <$> HashMap.lookup pname o of

268 Just (Success ref) -> validateWithSchemaRef ref (Object o)

267 Just (Success ref) -> validateWithSchemaRef ref (Object o)

269 Just (Error msg) -> invalid ("failed to parse discriminator property " ++ show pname ++ ": " ++ show msg)

268 Just (Error msg) -> invalid ("failed to parse discriminator property " ++ show pname ++ ": " ++ show msg)

@@ -282,17 +281,17 @@ validateObject o = withSchema $ \schema ->

282 where

281 where

283 size = fromIntegral (HashMap.size o)

282 size = fromIntegral (HashMap.size o)

284

283

285− validateRequired = withSchema $ \schema -> traverse_ validateReq (schema ^. required)

284+ validateRequired = withSchema $ \sch -> traverse_ validateReq (sch ^. required)

286− validateReq name =

285+ validateReq n =

287− when (not (HashMap.member name o)) $

286+ when (not (HashMap.member n o)) $

288− invalid ("property " ++ show name ++ " is required, but not found in " ++ show (encode o))

287+ invalid ("property " ++ show n ++ " is required, but not found in " ++ show (encode o))

289

288

290− validateProps = withSchema $ \schema -> do

289+ validateProps = withSchema $ \sch -> do

291 for_ (HashMap.toList o) $ \(k, v) ->

290 for_ (HashMap.toList o) $ \(k, v) ->

292 case v of

291 case v of

293− Null | not (k `elem` (schema ^. required)) -> valid -- null is fine for non-required property

292+ Null | not (k `elem` (sch ^. required)) -> valid -- null is fine for non-required property

294 _ ->

293 _ ->

295− case InsOrdHashMap.lookup k (schema ^. properties) of

294+ case InsOrdHashMap.lookup k (sch ^. properties) of

296 Nothing -> check additionalProperties $ \s -> validateWithSchemaRef s v

295 Nothing -> check additionalProperties $ \s -> validateWithSchemaRef s v

297 Just s -> validateWithSchemaRef s v

296 Just s -> validateWithSchemaRef s v

298

297

@@ -303,8 +302,8 @@ validateEnum value = do

303 invalid ("expected one of " ++ show (encode xs) ++ " but got " ++ show value)

302 invalid ("expected one of " ++ show (encode xs) ++ " but got " ++ show value)

304

303

305validateSchemaType :: Value -> Validation Schema ()

304validateSchemaType :: Value -> Validation Schema ()

306−validateSchemaType value = withSchema $ \schema ->

305+validateSchemaType value = withSchema $ \sch ->

307− case (schema ^. type_, value) of

306+ case (sch ^. type_, value) of

308 (SwaggerNull, Null) -> valid

307 (SwaggerNull, Null) -> valid

309 (SwaggerBoolean, Bool _) -> valid

308 (SwaggerBoolean, Bool _) -> valid

310 (SwaggerInteger, Number n) -> sub_ paramSchema (validateInteger n)

309 (SwaggerInteger, Number n) -> sub_ paramSchema (validateInteger n)

@@ -315,8 +314,8 @@ validateSchemaType value = withSchema $ \schema ->

315 (t, _) -> invalid $ "expected JSON value of type " ++ show t

314 (t, _) -> invalid $ "expected JSON value of type " ++ show t

316

315

317validateParamSchemaType :: Value -> Validation (ParamSchema t) ()

316validateParamSchemaType :: Value -> Validation (ParamSchema t) ()

318−validateParamSchemaType value = withSchema $ \schema ->

317+validateParamSchemaType value = withSchema $ \sch ->

319− case (schema ^. type_, value) of

318+ case (sch ^. type_, value) of

320 (SwaggerBoolean, Bool _) -> valid

319 (SwaggerBoolean, Bool _) -> valid

321 (SwaggerInteger, Number n) -> validateInteger n

320 (SwaggerInteger, Number n) -> validateInteger n

322 (SwaggerNumber, Number n) -> validateNumber n

321 (SwaggerNumber, Number n) -> validateNumber n

src/Data/Swagger/Lens.hs+6−2

@@ -62,17 +62,21 @@ makePrisms ''Referenced

63_SwaggerItemsArray :: Review (SwaggerItems 'SwaggerKindSchema) [Referenced Schema]

64_SwaggerItemsArray

65− = prism (\x -> SwaggerItemsArray x) $ \x -> case x of

65+ = unto (\x -> SwaggerItemsArray x)

66+{- \x -> case x of

66 SwaggerItemsPrimitive c p -> Left (SwaggerItemsPrimitive c p)

67 SwaggerItemsPrimitive c p -> Left (SwaggerItemsPrimitive c p)

67 SwaggerItemsObject o -> Left (SwaggerItemsObject o)

68 SwaggerItemsObject o -> Left (SwaggerItemsObject o)

68 SwaggerItemsArray a -> Right a

69 SwaggerItemsArray a -> Right a

70+-}

70_SwaggerItemsObject :: Review (SwaggerItems 'SwaggerKindSchema) (Referenced Schema)

72_SwaggerItemsObject :: Review (SwaggerItems 'SwaggerKindSchema) (Referenced Schema)

71_SwaggerItemsObject

73_SwaggerItemsObject

72− = prism (\x -> SwaggerItemsObject x) $ \x -> case x of

74+ = unto (\x -> SwaggerItemsObject x)

75+{- \x -> case x of

73 SwaggerItemsPrimitive c p -> Left (SwaggerItemsPrimitive c p)

76 SwaggerItemsPrimitive c p -> Left (SwaggerItemsPrimitive c p)

74 SwaggerItemsObject o -> Right o

77 SwaggerItemsObject o -> Right o

75 SwaggerItemsArray a -> Left (SwaggerItemsArray a)

78 SwaggerItemsArray a -> Left (SwaggerItemsArray a)

79+-}

77_SwaggerItemsPrimitive :: forall t p f. (Profunctor p, Bifunctor p, Functor f) => Optic' p f (SwaggerItems t) (Maybe (CollectionFormat t), ParamSchema t)

81_SwaggerItemsPrimitive :: forall t p f. (Profunctor p, Bifunctor p, Functor f) => Optic' p f (SwaggerItems t) (Maybe (CollectionFormat t), ParamSchema t)

78_SwaggerItemsPrimitive = unto (\(c, p) -> SwaggerItemsPrimitive c p)

82_SwaggerItemsPrimitive = unto (\(c, p) -> SwaggerItemsPrimitive c p)

src/Data/Swagger/Operation.hs+5−7

@@ -30,23 +30,21 @@ module Data.Swagger.Operation (

30 declareResponse,

31) where

33−import Control.Applicative

33+import Prelude ()

34−import Control.Arrow

34+import Prelude.Compat

35+

35import Control.Lens

36import Control.Lens

36import Data.Data.Lens

37import Data.Data.Lens

37−import qualified Data.HashMap.Strict as HashMap

38−import Data.List

38+import Data.List.Compat

39import Data.Maybe (mapMaybe)

40import Data.Monoid

41import qualified Data.Set as Set

42−import Data.Traversable

44import Data.Swagger.Declare

43import Data.Swagger.Declare

45import Data.Swagger.Internal

44import Data.Swagger.Internal

46import Data.Swagger.Lens

45import Data.Swagger.Lens

47import Data.Swagger.Schema

46import Data.Swagger.Schema

49−import Data.HashMap.Strict.InsOrd (InsOrdHashMap)

50import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap

48import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap

52-- $setup

50-- $setup

@@ -187,7 +185,7 @@ setResponseForWith ops f code dres swag = swag

187 where

185 where

188 (defs, new) = runDeclare dres mempty

186 (defs, new) = runDeclare dres mempty

189

187

190− combine (Just (Ref (Reference name))) = case swag ^. responses.at name of

188+ combine (Just (Ref (Reference n))) = case swag ^. responses.at n of

191 Just old -> f old new

189 Just old -> f old new

192 Nothing -> new -- response name can't be dereferenced, replacing with new response

190 Nothing -> new -- response name can't be dereferenced, replacing with new response

193 combine (Just (Inline old)) = f old new

191 combine (Just (Inline old)) = f old new

stack-ghc-8.0.yaml+2

@@ -1,3 +1,5 @@

1resolver: nightly-2016-05-29

2packages:

3- '.'

4+extra-deps:

5+ - aeson-0.11.2.1

stack-lts-2.yaml+9

@@ -2,7 +2,16 @@ flags: {}

2packages:

3- '.'

4extra-deps:

5+- aeson-0.11.2.1

6+- attoparsec-0.13.1.0

7+- base-compat-0.9.1

8+- fail-4.9.0.0

5- generics-sop-0.2.1.0

9- generics-sop-0.2.1.0

6- insert-ordered-containers-0.1.0.1

10- insert-ordered-containers-0.1.0.1

11+- primitive-0.6.1.0

12+- tagged-0.8.4

7- unordered-containers-0.2.7.0

13- unordered-containers-0.2.7.0

8resolver: lts-2.22

14resolver: lts-2.22

15+flags:

16+ aeson:

17+ old-locale: true

swagger2.cabal+2−2

@@ -40,8 +40,8 @@ library

40 Data.Swagger.Internal.Utils

41 Data.Swagger.Internal.AesonUtils

42 build-depends: base >=4.7 && <4.10

43− , base-compat >=0.6.0 && <0.10

43+ , base-compat >=0.9.1 && <0.10

44− , aeson

44+ , aeson >=0.11.2.1

45 , containers

46 , hashable

47 , generics-sop >=0.2 && <0.3