e1ea5fe · typeable/openapi3

.github/workflows/haskell-ci.yml+12−3

compare with master

unifiedsplit

@@ -8,9 +8,9 @@

8#

9# For more information, see https://github.com/haskell-CI/haskell-ci

10#

11−# version: 0.12

11+# version: 0.12.1

12#

13−# REGENDATA ("0.12",["github","cabal.project"])

13+# REGENDATA ("0.12.1",["github","cabal.project"])

14#

15name: Haskell-CI

16on:

@@ -21,7 +21,7 @@ jobs:

21 name: Haskell-CI - Linux - ${{ matrix.compiler }}

22 runs-on: ubuntu-18.04

23 container:

24− image: buildpack-deps:bionic

24+ image: buildpack-deps:xenial

25 continue-on-error: ${{ matrix.allow-failure }}

26 strategy:

27 matrix:

@@ -175,3 +175,12 @@ jobs:

175 run: |

176 rm -f cabal.project.local

177 $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all

178+ - name: prepare for constraint sets

179+ run: |

180+ rm -f cabal.project.local

181+ - name: constraint set aeson-2

182+ run: |

183+ $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --constraint='aeson >=2.0' all

184+ - name: constraint set aeson-1

185+ run: |

186+ $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --constraint='aeson <2.0' all

cabal.haskell-cinew file+7

@@ -0,0 +1,7 @@

1+branches: master

2+

3+constraint-set aeson-1

4+ constraints: aeson <2.0

5+

6+constraint-set aeson-2

7+ constraints: aeson >=2.0

openapi3.cabal+4−2

@@ -56,6 +56,8 @@ library

56 Data.OpenApi.Internal.AesonUtils

57 Data.OpenApi.Internal.TypeShape

58

59+ Data.OpenApi.Aeson.Compat

60+

59 -- GHC boot libraries

61 -- GHC boot libraries

60 build-depends:

62 build-depends:

61 base >=4.11.1.0 && <4.16

63 base >=4.11.1.0 && <4.16

@@ -71,8 +73,8 @@ library

71

73

72 -- other dependencies

74 -- other dependencies

73 build-depends:

75 build-depends:

74− base-compat-batteries >=0.11.1 && <0.12

76+ base-compat-batteries >=0.11.1 && <0.13

75− , aeson >=1.4.2.0 && <1.6

77+ , aeson >=1.4.2.0 && <1.6 || >=2.0.1.0 && < 2.1

76 , aeson-pretty >=0.8.7 && <0.9

78 , aeson-pretty >=0.8.7 && <0.9

77 -- cookie 0.4.3 is needed by GHC 7.8 due to time>=1.4 constraint

79 -- cookie 0.4.3 is needed by GHC 7.8 due to time>=1.4 constraint

78 , cookie >=0.4.3 && <0.5

80 , cookie >=0.4.3 && <0.5

src/Data/OpenApi/Aeson/Compat.hsnew file+76

@@ -0,0 +1,76 @@

1+{-# LANGUAGE CPP #-}

2+

3+module Data.OpenApi.Aeson.Compat where

4+

5+#if MIN_VERSION_aeson(2,0,0)

6+import Data.Aeson (Key)

7+import qualified Data.Aeson.Key as Key

8+import qualified Data.Aeson.KeyMap as KeyMap

9+#else

10+import qualified Data.HashMap.Strict as HM

11+#endif

12+import Data.Bifunctor (first)

13+import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap

14+import qualified Data.Text as T

15+

16+#if MIN_VERSION_aeson(2,0,0)

17+deleteKey :: Key -> KeyMap.KeyMap v -> KeyMap.KeyMap v

18+deleteKey = KeyMap.delete

19+

20+objectToList :: KeyMap.KeyMap v -> [(Key, v)]

21+objectToList = KeyMap.toList

22+

23+objectKeys :: KeyMap.KeyMap v -> [T.Text]

24+objectKeys = map Key.toText . KeyMap.keys

25+

26+stringToKey :: String -> Key

27+stringToKey = Key.fromString

28+

29+keyToString :: Key -> String

30+keyToString = Key.toString

31+

32+keyToText :: Key -> T.Text

33+keyToText = Key.toText

34+

35+toInsOrdHashMap :: KeyMap.KeyMap v -> InsOrdHashMap.InsOrdHashMap T.Text v

36+toInsOrdHashMap = InsOrdHashMap.fromList . fmap (first Key.toText) . KeyMap.toList

37+

38+fromInsOrdHashMap :: InsOrdHashMap.InsOrdHashMap T.Text v -> KeyMap.KeyMap v

39+fromInsOrdHashMap = KeyMap.fromList . fmap (first Key.fromText) . InsOrdHashMap.toList

40+

41+lookupKey :: T.Text -> KeyMap.KeyMap v -> Maybe v

42+lookupKey = KeyMap.lookup . Key.fromText

43+

44+hasKey :: T.Text -> KeyMap.KeyMap a -> Bool

45+hasKey = KeyMap.member . Key.fromText

46+#else

47+deleteKey :: T.Text -> HM.HashMap T.Text v -> HM.HashMap T.Text v

48+deleteKey = HM.delete

49+

50+objectToList :: HM.HashMap T.Text v -> [(T.Text, v)]

51+objectToList = HM.toList

52+

53+objectKeys :: HM.HashMap T.Text v -> [T.Text]

54+objectKeys = HM.keys

55+

56+stringToKey :: String -> T.Text

57+stringToKey = T.pack

58+

59+keyToString :: T.Text -> String

60+keyToString = T.unpack

61+

62+keyToText :: T.Text -> T.Text

63+keyToText = id

64+

65+toInsOrdHashMap :: HM.HashMap T.Text v -> InsOrdHashMap.InsOrdHashMap T.Text v

66+toInsOrdHashMap = InsOrdHashMap.fromHashMap

67+

68+fromInsOrdHashMap :: InsOrdHashMap.InsOrdHashMap T.Text v -> HM.HashMap T.Text v

69+fromInsOrdHashMap = InsOrdHashMap.toHashMap

70+

71+lookupKey :: T.Text -> HM.HashMap T.Text v -> Maybe v

72+lookupKey = HM.lookup

73+

74+hasKey :: T.Text -> HM.HashMap T.Text a -> Bool

75+hasKey = HM.member

76+#endif

src/Data/OpenApi/Internal.hs+14−14

@@ -1,3 +1,4 @@

1+{-# LANGUAGE CPP #-}

1{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DeriveDataTypeable #-}

3{-# LANGUAGE DeriveDataTypeable #-}

3{-# LANGUAGE DeriveGeneric #-}

4{-# LANGUAGE DeriveGeneric #-}

@@ -21,6 +22,9 @@ import Prelude.Compat

21import Control.Applicative

22import Control.Applicative

22import Control.Lens ((&), (.~), (?~))

23import Control.Lens ((&), (.~), (?~))

23import Data.Aeson hiding (Encoding)

24import Data.Aeson hiding (Encoding)

25+#if MIN_VERSION_aeson(2,0,0)

26+import qualified Data.Aeson.KeyMap as KeyMap

27+#endif

24import qualified Data.Aeson.Types as JSON

28import qualified Data.Aeson.Types as JSON

25import Data.Data (Constr, Data (..), DataType, Fixity (..), Typeable,

29import Data.Data (Constr, Data (..), DataType, Fixity (..), Typeable,

26 constrIndex, mkConstr, mkDataType)

30 constrIndex, mkConstr, mkDataType)

@@ -45,17 +49,13 @@ import Text.Read (readMaybe)

45import Data.HashMap.Strict.InsOrd (InsOrdHashMap)

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

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

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

47

51

48−import Generics.SOP.TH (deriveGeneric)

52+import Data.OpenApi.Aeson.Compat (deleteKey)

49−import Data.OpenApi.Internal.AesonUtils (sopSwaggerGenericToEncoding

53+import Data.OpenApi.Internal.AesonUtils (AesonDefaultValue (..), HasSwaggerAesonOptions (..),

50− ,sopSwaggerGenericToJSON

51− ,sopSwaggerGenericToJSONWithOpts

52− ,sopSwaggerGenericParseJSON

53− ,HasSwaggerAesonOptions(..)

54− ,AesonDefaultValue(..)

55− ,mkSwaggerAesonOptions

54+ mkSwaggerAesonOptions, saoAdditionalPairs, saoSubObject,

56− ,saoAdditionalPairs

55+ sopSwaggerGenericParseJSON, sopSwaggerGenericToEncoding,

57− ,saoSubObject)

56+ sopSwaggerGenericToJSON, sopSwaggerGenericToJSONWithOpts)

58import Data.OpenApi.Internal.Utils

57import Data.OpenApi.Internal.Utils

58+import Generics.SOP.TH (deriveGeneric)

59

60-- $setup

61-- >>> :seti -XDataKinds

@@ -337,7 +337,7 @@ data RequestBody = RequestBody

337 -- | The content of the request body.

338 -- The key is a media type or media type range and the value describes it.

339 -- For requests that match multiple keys, only the most specific key is applicable.

340− -- e.g. @text/plain@ overrides @text/*@

340+ -- e.g. @text/plain@ overrides @text/\*@

341 , _requestBodyContent :: InsOrdHashMap MediaType MediaTypeObject

342

343 -- | Determines if the request body is required in the request.

@@ -394,7 +394,7 @@ data Encoding = Encoding

394 -- for other primitive types – @text/plain@; for object - @application/json@;

395 -- for array – the default is defined based on the inner type.

396 -- The value can be a specific media type (e.g. @application/json@),

397− -- a wildcard media type (e.g. @image/*@), or a comma-separated list of the two types.

397+ -- a wildcard media type (e.g. @image/\*@), or a comma-separated list of the two types.

398 _encodingContentType :: Maybe MediaType

399

400 -- | A map allowing additional information to be provided as headers,

@@ -734,7 +734,7 @@ data Response = Response

734 -- | A map containing descriptions of potential response payloads.

735 -- The key is a media type or media type range and the value describes it.

736 -- For responses that match multiple keys, only the most specific key is applicable.

737− -- e.g. @text/plain@ overrides @text/*@.

737+ -- e.g. @text/plain@ overrides @text/\*@.

738 , _responseContent :: InsOrdHashMap MediaType MediaTypeObject

739

740 -- | Maps a header name to its definition.

@@ -1492,7 +1492,7 @@ instance FromJSON Param where

1492instance FromJSON Responses where

1493 parseJSON (Object o) = Responses

1494 <$> o .:? "default"

1495− <*> parseJSON (Object (HashMap.delete "default" o))

1495+ <*> parseJSON (Object (deleteKey "default" o))

1496 parseJSON _ = empty

1497

1498instance FromJSON Example where

src/Data/OpenApi/Internal/AesonUtils.hs+11−10

@@ -36,18 +36,19 @@ import Data.Text (Text)

36import Generics.SOP

37

38import qualified Data.Text as T

39−import qualified Data.HashMap.Strict as HM

40import qualified Data.Set as Set

39import qualified Data.Set as Set

41import qualified Data.HashMap.Strict.InsOrd as InsOrd

40import qualified Data.HashMap.Strict.InsOrd as InsOrd

42import qualified Data.HashSet.InsOrd as InsOrdHS

41import qualified Data.HashSet.InsOrd as InsOrdHS

43

42

43+import Data.OpenApi.Aeson.Compat (keyToString, objectToList, stringToKey)

44+

44-------------------------------------------------------------------------------

45-------------------------------------------------------------------------------

45-- SwaggerAesonOptions

46-- SwaggerAesonOptions

46-------------------------------------------------------------------------------

47-------------------------------------------------------------------------------

47

48

48data SwaggerAesonOptions = SwaggerAesonOptions

49data SwaggerAesonOptions = SwaggerAesonOptions

49 { _saoPrefix :: String

50 { _saoPrefix :: String

50− , _saoAdditionalPairs :: [(Text, Value)]

51+ , _saoAdditionalPairs :: [Pair]

51 , _saoSubObject :: Maybe String

52 , _saoSubObject :: Maybe String

52 }

53 }

53

54

@@ -154,14 +155,14 @@ sopSwaggerGenericToJSON'' (SwaggerAesonOptions prefix _ sub) = go

154 go Nil Nil Nil = []

155 go Nil Nil Nil = []

155 go (I x :* xs) (FieldInfo name :* names) (def :* defs)

156 go (I x :* xs) (FieldInfo name :* names) (def :* defs)

156 | Just name' == sub = case json of

157 | Just name' == sub = case json of

157− Object m -> HM.toList m ++ rest

158+ Object m -> objectToList m ++ rest

158 Null -> rest

159 Null -> rest

159 _ -> error $ "sopSwaggerGenericToJSON: subjson is not an object: " ++ show json

160 _ -> error $ "sopSwaggerGenericToJSON: subjson is not an object: " ++ show json

160 -- If default value: omit it.

161 -- If default value: omit it.

161 | Just x == def =

162 | Just x == def =

162 rest

163 rest

163 | otherwise =

164 | otherwise =

164− (T.pack name', json) : rest

165+ (stringToKey name', json) : rest

165 where

166 where

166 json = toJSON x

167 json = toJSON x

167 name' = fieldNameModifier name

168 name' = fieldNameModifier name

@@ -195,11 +196,11 @@ sopSwaggerGenericParseJSON = withObject "Swagger Record Object" $ \obj ->

195 proxy = Proxy :: Proxy a

196 proxy = Proxy :: Proxy a

196 opts = swaggerAesonOptions proxy

197 opts = swaggerAesonOptions proxy

197

198

198− parseAdditionalField :: Object -> (Text, Value) -> Parser ()

199+ parseAdditionalField :: Object -> Pair -> Parser ()

199 parseAdditionalField obj (k, v) = do

200 parseAdditionalField obj (k, v) = do

200 v' <- obj .: k

201 v' <- obj .: k

201 unless (v == v') $ fail $

202 unless (v == v') $ fail $

202− "Additonal field don't match for key " ++ T.unpack k

203+ "Additonal field don't match for key " ++ keyToString k

203 ++ ": " ++ show v

204 ++ ": " ++ show v

204 ++ " /= " ++ show v'

205 ++ " /= " ++ show v'

205

206

@@ -230,8 +231,8 @@ sopSwaggerGenericParseJSON'' (SwaggerAesonOptions prefix _ sub) obj = go

230 -- Note: we might strip fields of outer structure.

231 -- Note: we might strip fields of outer structure.

231 cons <$> (withDef $ parseJSON $ Object obj) <*> rest

232 cons <$> (withDef $ parseJSON $ Object obj) <*> rest

232 | otherwise = case def of

233 | otherwise = case def of

233− Just def' -> cons <$> obj .:? T.pack name' .!= def' <*> rest

234+ Just def' -> cons <$> obj .:? stringToKey name' .!= def' <*> rest

234− Nothing -> cons <$> obj .: T.pack name' <*> rest

235+ Nothing -> cons <$> obj .: stringToKey name' <*> rest

235 where

236 where

236 cons h t = I h :* t

237 cons h t = I h :* t

237 name' = fieldNameModifier name

238 name' = fieldNameModifier name

@@ -294,14 +295,14 @@ sopSwaggerGenericToEncoding'' (SwaggerAesonOptions prefix _ sub) = go

294 go Nil Nil Nil = mempty

295 go Nil Nil Nil = mempty

295 go (I x :* xs) (FieldInfo name :* names) (def :* defs)

296 go (I x :* xs) (FieldInfo name :* names) (def :* defs)

296 | Just name' == sub = case toJSON x of

297 | Just name' == sub = case toJSON x of

297− Object m -> pairsToSeries (HM.toList m) <> rest

298+ Object m -> pairsToSeries (objectToList m) <> rest

298 Null -> rest

299 Null -> rest

299 _ -> error $ "sopSwaggerGenericToJSON: subjson is not an object: " ++ show (toJSON x)

300 _ -> error $ "sopSwaggerGenericToJSON: subjson is not an object: " ++ show (toJSON x)

300 -- If default value: omit it.

301 -- If default value: omit it.

301 | Just x == def =

302 | Just x == def =

302 rest

303 rest

303 | otherwise =

304 | otherwise =

304− (T.pack name' .= x) <> rest

305+ (stringToKey name' .= x) <> rest

305 where

306 where

306 name' = fieldNameModifier name

307 name' = fieldNameModifier name

307 rest = go xs names defs

308 rest = go xs names defs

src/Data/OpenApi/Internal/Schema.hs+15−14

@@ -64,13 +64,14 @@ import GHC.Generics

64import qualified Data.UUID.Types as UUID

65import Type.Reflection (Typeable, typeRep)

66

67+import Data.OpenApi.Aeson.Compat (keyToText, objectKeys, toInsOrdHashMap)

67−import Data.OpenApi.Declare

68+import Data.OpenApi.Declare

68−import Data.OpenApi.Internal

69+import Data.OpenApi.Internal

69−import Data.OpenApi.Internal.ParamSchema (ToParamSchema(..))

70+import Data.OpenApi.Internal.ParamSchema (ToParamSchema (..))

71+import Data.OpenApi.Internal.TypeShape

70−import Data.OpenApi.Lens hiding (name, schema)

72+import Data.OpenApi.Lens hiding (name, schema)

71−import qualified Data.OpenApi.Lens as Swagger

73+import qualified Data.OpenApi.Lens as Swagger

72−import Data.OpenApi.SchemaOptions

74+import Data.OpenApi.SchemaOptions

73−import Data.OpenApi.Internal.TypeShape

74

75

75import qualified Data.ByteString as BS

76import qualified Data.ByteString as BS

76import qualified Data.ByteString.Lazy.Char8 as BSL

77import qualified Data.ByteString.Lazy.Char8 as BSL

@@ -405,8 +406,8 @@ sketchSchema = sketch . toJSON

405 _ -> Nothing

406 _ -> Nothing

406 go (Object o) = mempty

407 go (Object o) = mempty

407 & type_ ?~ OpenApiObject

408 & type_ ?~ OpenApiObject

408− & required .~ sort (HashMap.keys o)

409+ & required .~ sort (objectKeys o)

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

410+ & properties .~ fmap (Inline . go) (toInsOrdHashMap o)

410

411

411-- | Make a restrictive sketch of a @'Schema'@ based on a @'ToJSON'@ instance.

412-- | Make a restrictive sketch of a @'Schema'@ based on a @'ToJSON'@ instance.

412-- Produced schema uses as much constraints as possible.

413-- Produced schema uses as much constraints as possible.

@@ -570,12 +571,12 @@ sketchStrictSchema = go . toJSON

570 go js@(Object o) = mempty

571 go js@(Object o) = mempty

571 & type_ ?~ OpenApiObject

572 & type_ ?~ OpenApiObject

572 & required .~ sort names

573 & required .~ sort names

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

574+ & properties .~ fmap (Inline . go) (toInsOrdHashMap o)

574 & maxProperties ?~ fromIntegral (length names)

575 & maxProperties ?~ fromIntegral (length names)

575 & minProperties ?~ fromIntegral (length names)

576 & minProperties ?~ fromIntegral (length names)

576 & enum_ ?~ [js]

577 & enum_ ?~ [js]

577 where

578 where

578− names = HashMap.keys o

579+ names = objectKeys o

579

580

580class GToSchema (f :: * -> *) where

581class GToSchema (f :: * -> *) where

581 gdeclareNamedSchema :: SchemaOptions -> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema

582 gdeclareNamedSchema :: SchemaOptions -> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema

@@ -810,13 +811,13 @@ declareSchemaBoundedEnumKeyMapping :: forall map key value.

810 (Bounded key, Enum key, ToJSONKey key, ToSchema key, ToSchema value)

811 (Bounded key, Enum key, ToJSONKey key, ToSchema key, ToSchema value)

811 => Proxy (map key value) -> Declare (Definitions Schema) Schema

812 => Proxy (map key value) -> Declare (Definitions Schema) Schema

812declareSchemaBoundedEnumKeyMapping _ = case toJSONKey :: ToJSONKeyFunction key of

813declareSchemaBoundedEnumKeyMapping _ = case toJSONKey :: ToJSONKeyFunction key of

813− ToJSONKeyText keyToText _ -> objectSchema keyToText

814+ ToJSONKeyText getKey _ -> objectSchema getKey

814 ToJSONKeyValue _ _ -> declareSchema (Proxy :: Proxy [(key, value)])

815 ToJSONKeyValue _ _ -> declareSchema (Proxy :: Proxy [(key, value)])

815 where

816 where

816− objectSchema keyToText = do

817+ objectSchema getKey = do

817 valueRef <- declareSchemaRef (Proxy :: Proxy value)

818 valueRef <- declareSchemaRef (Proxy :: Proxy value)

818 let allKeys = [minBound..maxBound :: key]

819 let allKeys = [minBound..maxBound :: key]

819− mkPair k = (keyToText k, valueRef)

820+ mkPair k = (keyToText $ getKey k, valueRef)

820 return $ mempty

821 return $ mempty

821 & type_ ?~ OpenApiObject

822 & type_ ?~ OpenApiObject

822 & properties .~ InsOrdHashMap.fromList (map mkPair allKeys)

823 & properties .~ InsOrdHashMap.fromList (map mkPair allKeys)

src/Data/OpenApi/Internal/Schema/Validation.hs+23−11

@@ -1,4 +1,5 @@

1{-# OPTIONS_GHC -Wall #-}

2+{-# LANGUAGE CPP #-}

2{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE DeriveFunctor #-}

4{-# LANGUAGE DeriveFunctor #-}

4{-# LANGUAGE FlexibleInstances #-}

5{-# LANGUAGE FlexibleInstances #-}

@@ -31,10 +32,14 @@ import Control.Lens hiding (allOf)

31import Control.Monad (forM, forM_, when)

32import Control.Monad (forM, forM_, when)

32

33

33import Data.Aeson hiding (Result)

34import Data.Aeson hiding (Result)

35+#if MIN_VERSION_aeson(2,0,0)

36+import qualified Data.Aeson.KeyMap as KeyMap

37+#endif

34import Data.Foldable (for_, sequenceA_,

38import Data.Foldable (for_, sequenceA_,

35 traverse_)

39 traverse_)

40+#if !MIN_VERSION_aeson(2,0,0)

36import Data.HashMap.Strict (HashMap)

41import Data.HashMap.Strict (HashMap)

37−import qualified Data.HashMap.Strict as HashMap

42+#endif

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

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

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

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

40import Data.Maybe (fromMaybe)

45import Data.Maybe (fromMaybe)

@@ -47,11 +52,12 @@ import qualified Data.Text.Lazy.Encoding as TL

47import Data.Vector (Vector)

52import Data.Vector (Vector)

48import qualified Data.Vector as Vector

53import qualified Data.Vector as Vector

49

54

55+import Data.OpenApi.Aeson.Compat (hasKey, keyToText, lookupKey, objectToList)

50−import Data.OpenApi.Declare

56+import Data.OpenApi.Declare

57+import Data.OpenApi.Internal

51−import Data.OpenApi.Internal

58+import Data.OpenApi.Internal.Schema

52−import Data.OpenApi.Internal.Utils

59+import Data.OpenApi.Internal.Utils

53−import Data.OpenApi.Internal.Schema

54−import Data.OpenApi.Lens

60+import Data.OpenApi.Lens

55

61

56-- | Validate @'ToJSON'@ instance matches @'ToSchema'@ for a given value.

62-- | Validate @'ToJSON'@ instance matches @'ToSchema'@ for a given value.

57-- This can be used with QuickCheck to ensure those instances are coherent:

63-- This can be used with QuickCheck to ensure those instances are coherent:

@@ -366,10 +372,16 @@ validateArray xs = do

366 len = Vector.length xs

372 len = Vector.length xs

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

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

368

374

375+validateObject ::

376+#if MIN_VERSION_aeson(2,0,0)

377+ KeyMap.KeyMap Value

378+#else

369−validateObject :: HashMap Text Value -> Validation Schema ()

379+ HashMap Text Value

380+#endif

381+ -> Validation Schema ()

370validateObject o = withSchema $ \sch ->

382validateObject o = withSchema $ \sch ->

371 case sch ^. discriminator of

383 case sch ^. discriminator of

372− Just (Discriminator pname types) -> case fromJSON <$> HashMap.lookup pname o of

384+ Just (Discriminator pname types) -> case fromJSON <$> lookupKey pname o of

373 Just (Success pvalue) ->

385 Just (Success pvalue) ->

374 let ref = fromMaybe pvalue $ InsOrdHashMap.lookup pvalue types

386 let ref = fromMaybe pvalue $ InsOrdHashMap.lookup pvalue types

375 -- TODO ref may be name or reference

387 -- TODO ref may be name or reference

@@ -388,15 +400,15 @@ validateObject o = withSchema $ \sch ->

388 validateRequired

400 validateRequired

389 validateProps

401 validateProps

390 where

402 where

391− size = fromIntegral (HashMap.size o)

403+ size = fromIntegral (length o)

392

404

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

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

394 validateReq n =

406 validateReq n =

395− when (not (HashMap.member n o)) $

407+ when (not (hasKey n o)) $

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

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

397

409

398 validateProps = withSchema $ \sch -> do

410 validateProps = withSchema $ \sch -> do

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

411+ for_ (objectToList o) $ \(keyToText -> k, v) ->

400 case v of

412 case v of

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

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

402 _ ->

414 _ ->

src/Data/OpenApi/Schema/Generator.hs+3−1

@@ -25,6 +25,8 @@ import Test.QuickCheck (arbitrary)

25import Test.QuickCheck.Gen

26import Test.QuickCheck.Property

27

28+import Data.OpenApi.Aeson.Compat (fromInsOrdHashMap)

29+

28-- | Note: 'schemaGen' may 'error', if schema type is not specified,

30-- | Note: 'schemaGen' may 'error', if schema type is not specified,

29-- and cannot be inferred.

31-- and cannot be inferred.

30schemaGen :: Definitions Schema -> Schema -> Gen Value

32schemaGen :: Definitions Schema -> Schema -> Gen Value

@@ -95,7 +97,7 @@ schemaGen defns schema =

95 return . M.fromList $ zip additionalKeys (repeat . schemaGen defns $ dereference defns addlSchema)

97 return . M.fromList $ zip additionalKeys (repeat . schemaGen defns $ dereference defns addlSchema)

96 _ -> return []

98 _ -> return []

97 x <- sequence $ gens <> additionalGens

99 x <- sequence $ gens <> additionalGens

98− return . Object $ M.toHashMap x

100+ return . Object $ fromInsOrdHashMap x

99

101

100dereference :: Definitions a -> Referenced a -> a

102dereference :: Definitions a -> Referenced a -> a

101dereference _ (Inline a) = a

103dereference _ (Inline a) = a

test/Data/OpenApi/Schema/ValidationSpec.hs+17−3

@@ -1,3 +1,4 @@

1+{-# LANGUAGE CPP #-}

1{-# LANGUAGE DeriveGeneric #-}

2{-# LANGUAGE DeriveGeneric #-}

2{-# LANGUAGE PackageImports #-}

3{-# LANGUAGE PackageImports #-}

3{-# LANGUAGE RecordWildCards #-}

4{-# LANGUAGE RecordWildCards #-}

@@ -8,6 +9,10 @@ module Data.OpenApi.Schema.ValidationSpec where

8import Control.Applicative

9import Control.Applicative

9import Control.Lens ((&), (.~), (?~))

10import Control.Lens ((&), (.~), (?~))

10import Data.Aeson

11import Data.Aeson

12+#if MIN_VERSION_aeson(2,0,0)

13+import qualified Data.Aeson.Key as Key

14+import qualified Data.Aeson.KeyMap as KeyMap

15+#endif

11import Data.Aeson.Types

16import Data.Aeson.Types

12import Data.Hashable (Hashable)

17import Data.Hashable (Hashable)

13import Data.HashMap.Strict (HashMap)

18import Data.HashMap.Strict (HashMap)

@@ -30,6 +35,7 @@ import GHC.Generics

30

35

31import Data.OpenApi

36import Data.OpenApi

32import Data.OpenApi.Declare

37import Data.OpenApi.Declare

38+import Data.OpenApi.Aeson.Compat (stringToKey)

33

39

34import Test.Hspec

40import Test.Hspec

35import Test.Hspec.QuickCheck

41import Test.Hspec.QuickCheck

@@ -124,9 +130,9 @@ instance Arbitrary Person where

124

130

125invalidPersonToJSON :: Person -> Value

131invalidPersonToJSON :: Person -> Value

126invalidPersonToJSON Person{..} = object

132invalidPersonToJSON Person{..} = object

127− [ T.pack "personName" .= toJSON name

133+ [ stringToKey "personName" .= toJSON name

128− , T.pack "personPhone" .= toJSON phone

134+ , stringToKey "personPhone" .= toJSON phone

129− , T.pack "personEmail" .= toJSON email

135+ , stringToKey "personEmail" .= toJSON email

130 ]

136 ]

131

137

132-- ========================================================================

138-- ========================================================================

@@ -305,3 +311,11 @@ instance Arbitrary Value where

305 , (3, Number <$> arbitrary)

311 , (3, Number <$> arbitrary)

306 , (3, Bool <$> arbitrary)

312 , (3, Bool <$> arbitrary)

307 , (1, return Null) ]

313 , (1, return Null) ]

314+

315+#if MIN_VERSION_aeson(2,0,0)

316+instance Arbitrary v => Arbitrary (KeyMap.KeyMap v) where

317+ arbitrary = KeyMap.fromList <$> arbitrary

318+

319+instance Arbitrary Key.Key where

320+ arbitrary = Key.fromText <$> arbitrary

321+#endif

test/SpecCommon.hs−8

@@ -8,14 +8,6 @@ import qualified Data.Vector as Vector

8

9import Test.Hspec

10

11−isSubJSON :: Value -> Value -> Bool

12−isSubJSON Null _ = True

13−isSubJSON (Object x) (Object y) = HashMap.keys x == HashMap.keys i && F.and i

14− where

15− i = HashMap.intersectionWith isSubJSON x y

16−isSubJSON (Array xs) (Array ys) = Vector.length xs == Vector.length ys && F.and (Vector.zipWith isSubJSON xs ys)

17−isSubJSON x y = x == y

18−

19(<=>) :: (Eq a, Show a, ToJSON a, FromJSON a, HasCallStack) => a -> Value -> Spec

11(<=>) :: (Eq a, Show a, ToJSON a, FromJSON a, HasCallStack) => a -> Value -> Spec

20x <=> js = do

12x <=> js = do

21 it "encodes correctly" $ do

13 it "encodes correctly" $ do