15541f1 · typeable/openapi3

git.iko.soy/typeable/openapi3

on master help sign in

toEncoding via sopSwaggerGenericToEncoding

15541f1Oleg Grenrus11 years ago

src/Data/Swagger.hs+3−3

compare with master

unifiedsplit

@@ -186,7 +186,7 @@ import Data.Swagger.Internal

186-- & at 200 ?~ ("OK" & _Inline.schema ?~ Ref (Reference "User"))

187-- & at 404 ?~ "User info not found")) ]

188-- :}

189−-- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"definitions\":{\"User\":{\"type\":\"string\"}},\"paths\":{\"/user\":{\"get\":{\"responses\":{\"404\":{\"description\":\"User info not found\"},\"200\":{\"schema\":{\"$ref\":\"#/definitions/User\"},\"description\":\"OK\"}},\"produces\":[\"application/json\"]}}}}"

189+-- "{\"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\"}}}"

190--

191-- In the snippet above we declare an API with a single path @/user@. This path provides method @GET@

192-- which produces @application/json@ output. It should respond with code @200@ and body specified

@@ -205,7 +205,7 @@ import Data.Swagger.Internal

205-- & type_ .~ SwaggerBoolean

206-- & description ?~ "To be or not to be"

207-- :}

208−-- "{\"type\":\"boolean\",\"description\":\"To be or not to be\"}"

208+-- "{\"description\":\"To be or not to be\",\"type\":\"boolean\"}"

209--

210-- @'ParamSchema'@ is basically the /base schema specification/ and many types contain it (see @'HasParamSchema'@).

211-- So for convenience, all @'ParamSchema'@ fields are transitively made fields of the type that has it.

@@ -271,7 +271,7 @@ import Data.Swagger.Internal

271-- >>> encode (Person "David" 28)

272-- "{\"age\":28,\"name\":\"David\"}"

273-- >>> encode $ toSchema (Proxy :: Proxy Person)

274−-- "{\"required\":[\"name\",\"age\"],\"type\":\"object\",\"properties\":{\"age\":{\"type\":\"integer\"},\"name\":{\"type\":\"string\"}}}"

274+-- "{\"required\":[\"name\",\"age\"],\"properties\":{\"name\":{\"type\":\"string\"},\"age\":{\"type\":\"integer\"}},\"type\":\"object\"}"

275

276-- $manipulation

277-- Sometimes you have to work with an imported or generated @'Swagger'@.

src/Data/Swagger/Internal.hs+18

@@ -58,6 +58,13 @@ import Data.Swagger.Internal.AesonUtils (sopSwaggerGenericToJSON

58 ,saoSubObject)

59import Data.Swagger.Internal.Utils

61+#if MIN_VERSION_aeson(0,10,0)

62+import Data.Swagger.Internal.AesonUtils (sopSwaggerGenericToEncoding)

63+#define DEFINE_TOENCODING toEncoding = sopSwaggerGenericToEncoding

64+#else

65+#define DEFINE_TOENCODING

66+#endif

67+

61-- | A list of definitions that can be used in references.

68-- | A list of definitions that can be used in references.

62type Definitions = InsOrdHashMap Text

69type Definitions = InsOrdHashMap Text

@@ -982,6 +989,7 @@ instance ToJSON OAuth2Flow where

982

989

983instance ToJSON OAuth2Params where

990instance ToJSON OAuth2Params where

984 toJSON = sopSwaggerGenericToJSON

991 toJSON = sopSwaggerGenericToJSON

992+ DEFINE_TOENCODING

985

993

986instance ToJSON SecuritySchemeType where

994instance ToJSON SecuritySchemeType where

987 toJSON SecuritySchemeBasic

995 toJSON SecuritySchemeBasic

@@ -995,15 +1003,19 @@ instance ToJSON SecuritySchemeType where

995

1003

996instance ToJSON Swagger where

1004instance ToJSON Swagger where

997 toJSON = sopSwaggerGenericToJSON

1005 toJSON = sopSwaggerGenericToJSON

1006+ DEFINE_TOENCODING

998

1007

999instance ToJSON SecurityScheme where

1008instance ToJSON SecurityScheme where

1000 toJSON = sopSwaggerGenericToJSON

1009 toJSON = sopSwaggerGenericToJSON

1010+ DEFINE_TOENCODING

1001

1011

1002instance ToJSON Schema where

1012instance ToJSON Schema where

1003 toJSON = sopSwaggerGenericToJSON

1013 toJSON = sopSwaggerGenericToJSON

1014+ DEFINE_TOENCODING

1004

1015

1005instance ToJSON Header where

1016instance ToJSON Header where

1006 toJSON = sopSwaggerGenericToJSON

1017 toJSON = sopSwaggerGenericToJSON

1018+ DEFINE_TOENCODING

1007

1019

1008instance ToJSON (ParamSchema t) => ToJSON (SwaggerItems t) where

1020instance ToJSON (ParamSchema t) => ToJSON (SwaggerItems t) where

1009 toJSON (SwaggerItemsPrimitive fmt schema) = object

1021 toJSON (SwaggerItemsPrimitive fmt schema) = object

@@ -1023,6 +1035,7 @@ instance ToJSON MimeList where

1023

1035

1024instance ToJSON Param where

1036instance ToJSON Param where

1025 toJSON = sopSwaggerGenericToJSON

1037 toJSON = sopSwaggerGenericToJSON

1038+ DEFINE_TOENCODING

1026

1039

1027instance ToJSON ParamAnySchema where

1040instance ToJSON ParamAnySchema where

1028 toJSON (ParamBody s) = object [ "in" .= ("body" :: Text), "schema" .= s ]

1041 toJSON (ParamBody s) = object [ "in" .= ("body" :: Text), "schema" .= s ]

@@ -1030,18 +1043,23 @@ instance ToJSON ParamAnySchema where

1030

1043

1031instance ToJSON ParamOtherSchema where

1044instance ToJSON ParamOtherSchema where

1032 toJSON = sopSwaggerGenericToJSON

1045 toJSON = sopSwaggerGenericToJSON

1046+ DEFINE_TOENCODING

1033

1047

1034instance ToJSON Responses where

1048instance ToJSON Responses where

1035 toJSON = sopSwaggerGenericToJSON

1049 toJSON = sopSwaggerGenericToJSON

1050+ DEFINE_TOENCODING

1036

1051

1037instance ToJSON Response where

1052instance ToJSON Response where

1038 toJSON = sopSwaggerGenericToJSON

1053 toJSON = sopSwaggerGenericToJSON

1054+ DEFINE_TOENCODING

1039

1055

1040instance ToJSON Operation where

1056instance ToJSON Operation where

1041 toJSON = sopSwaggerGenericToJSON

1057 toJSON = sopSwaggerGenericToJSON

1058+ DEFINE_TOENCODING

1042

1059

1043instance ToJSON PathItem where

1060instance ToJSON PathItem where

1044 toJSON = sopSwaggerGenericToJSON

1061 toJSON = sopSwaggerGenericToJSON

1062+ DEFINE_TOENCODING

1045

1063

1046instance ToJSON Example where

1064instance ToJSON Example where

1047 toJSON = toJSON . Map.mapKeys show . getExample

1065 toJSON = toJSON . Map.mapKeys show . getExample

src/Data/Swagger/Internal/AesonUtils.hs+83−4

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

1+{-# LANGUAGE CPP #-}

1{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE FlexibleContexts #-}

3{-# LANGUAGE FlexibleContexts #-}

3{-# LANGUAGE GADTs #-}

4{-# LANGUAGE GADTs #-}

@@ -8,6 +9,9 @@ module Data.Swagger.Internal.AesonUtils (

8 -- * Generic functions

9 -- * Generic functions

9 AesonDefaultValue(..),

10 AesonDefaultValue(..),

10 sopSwaggerGenericToJSON,

11 sopSwaggerGenericToJSON,

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

13+ sopSwaggerGenericToEncoding,

14+#endif

11 sopSwaggerGenericToJSONWithOpts,

15 sopSwaggerGenericToJSONWithOpts,

12 sopSwaggerGenericParseJSON,

16 sopSwaggerGenericParseJSON,

13 -- * Options

17 -- * Options

@@ -26,7 +30,7 @@ import Control.Applicative ((<|>))

26import Control.Lens (makeLenses, (^.))

30import Control.Lens (makeLenses, (^.))

27import Control.Monad (unless)

31import Control.Monad (unless)

28import Data.Aeson (ToJSON(..), FromJSON(..), Value(..), Object, object, (.:), (.:?), (.!=), withObject)

32import Data.Aeson (ToJSON(..), FromJSON(..), Value(..), Object, object, (.:), (.:?), (.!=), withObject)

29−import Data.Aeson.Types (Parser)

33+import Data.Aeson.Types (Parser, Pair)

30import Data.Char (toLower, isUpper)

34import Data.Char (toLower, isUpper)

31import Data.Text (Text)

35import Data.Text (Text)

@@ -37,6 +41,12 @@ import qualified Data.HashMap.Strict as HM

37import qualified Data.Set as Set

41import qualified Data.Set as Set

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

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

44+#if MIN_VERSION_aeson(0,10,0)

45+import Data.Aeson (Encoding, pairs, (.=), Series)

46+import Data.Monoid ((<>))

47+import Data.Foldable (foldMap)

48+#endif

49+

40-------------------------------------------------------------------------------

50-------------------------------------------------------------------------------

41-- SwaggerAesonOptions

51-- SwaggerAesonOptions

42-------------------------------------------------------------------------------

52-------------------------------------------------------------------------------

@@ -132,7 +142,7 @@ sopSwaggerGenericToJSON'

132 -> SOP I '[xs]

142 -> SOP I '[xs]

133 -> DatatypeInfo '[xs]

143 -> DatatypeInfo '[xs]

134 -> POP Maybe '[xs]

144 -> POP Maybe '[xs]

135− -> [(Text, Value)]

145+ -> [Pair]

136sopSwaggerGenericToJSON' opts (SOP (Z fields)) (ADT _ _ (Record _ fieldsInfo :* Nil)) (POP (defs :* Nil)) =

146sopSwaggerGenericToJSON' opts (SOP (Z fields)) (ADT _ _ (Record _ fieldsInfo :* Nil)) (POP (defs :* Nil)) =

137 sopSwaggerGenericToJSON'' opts fields fieldsInfo defs

147 sopSwaggerGenericToJSON'' opts fields fieldsInfo defs

138

148

@@ -142,10 +152,10 @@ sopSwaggerGenericToJSON''

142 -> NP I xs

152 -> NP I xs

143 -> NP FieldInfo xs

153 -> NP FieldInfo xs

144 -> NP Maybe xs

154 -> NP Maybe xs

145− -> [(Text, Value)]

155+ -> [Pair]

146sopSwaggerGenericToJSON'' (SwaggerAesonOptions prefix _ sub) = go

156sopSwaggerGenericToJSON'' (SwaggerAesonOptions prefix _ sub) = go

147 where

157 where

148− go :: (All ToJSON ys, All Eq ys) => NP I ys -> NP FieldInfo ys -> NP Maybe ys -> [(Text, Value)]

158+ go :: (All ToJSON ys, All Eq ys) => NP I ys -> NP FieldInfo ys -> NP Maybe ys -> [Pair]

149 go Nil Nil Nil = []

159 go Nil Nil Nil = []

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

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

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

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

@@ -240,3 +250,72 @@ sopSwaggerGenericParseJSON'' (SwaggerAesonOptions prefix _ sub) obj = go

240 modifier = lowerFirstUppers . drop (length prefix)

250 modifier = lowerFirstUppers . drop (length prefix)

241 lowerFirstUppers s = map toLower x ++ y

251 lowerFirstUppers s = map toLower x ++ y

242 where (x, y) = span isUpper s

252 where (x, y) = span isUpper s

253+

254+-------------------------------------------------------------------------------

255+-- ToEncoding

256+-------------------------------------------------------------------------------

257+

258+#if MIN_VERSION_aeson(0,10,0)

259+

260+sopSwaggerGenericToEncoding

261+ :: forall a xs.

262+ ( Generic a

263+ , HasDatatypeInfo a

264+ , HasSwaggerAesonOptions a

265+ , All2 ToJSON (Code a)

266+ , All2 Eq (Code a)

267+ , Code a ~ '[xs]

268+ )

269+ => a

270+ -> Encoding

271+sopSwaggerGenericToEncoding x =

272+ let ps = sopSwaggerGenericToEncoding' opts (from x) (datatypeInfo proxy) (aesonDefaults proxy)

273+ in pairs (pairsToSeries (opts ^. saoAdditionalPairs) <> ps)

274+ where

275+ proxy = Proxy :: Proxy a

276+ opts = swaggerAesonOptions proxy

277+

278+pairsToSeries :: [Pair] -> Series

279+pairsToSeries = foldMap (\(k, v) -> (k .= v))

280+

281+sopSwaggerGenericToEncoding'

282+ :: (All2 ToJSON '[xs], All2 Eq '[xs])

283+ => SwaggerAesonOptions

284+ -> SOP I '[xs]

285+ -> DatatypeInfo '[xs]

286+ -> POP Maybe '[xs]

287+ -> Series

288+sopSwaggerGenericToEncoding' opts (SOP (Z fields)) (ADT _ _ (Record _ fieldsInfo :* Nil)) (POP (defs :* Nil)) =

289+ sopSwaggerGenericToEncoding'' opts fields fieldsInfo defs

290+

291+sopSwaggerGenericToEncoding''

292+ :: (All ToJSON xs, All Eq xs)

293+ => SwaggerAesonOptions

294+ -> NP I xs

295+ -> NP FieldInfo xs

296+ -> NP Maybe xs

297+ -> Series

298+sopSwaggerGenericToEncoding'' (SwaggerAesonOptions prefix _ sub) = go

299+ where

300+ go :: (All ToJSON ys, All Eq ys) => NP I ys -> NP FieldInfo ys -> NP Maybe ys -> Series

301+ go Nil Nil Nil = mempty

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

303+ | Just name' == sub = case toJSON x of

304+ Object m -> pairsToSeries (HM.toList m) <> rest

305+ Null -> rest

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

307+ -- If default value: omit it.

308+ | Just x == def =

309+ rest

310+ | otherwise =

311+ (T.pack name' .= x) <> rest

312+ where

313+ name' = fieldNameModifier name

314+ rest = go xs names defs

315+

316+ fieldNameModifier = modifier . drop 1

317+ modifier = lowerFirstUppers . drop (length prefix)

318+ lowerFirstUppers s = map toLower x ++ y

319+ where (x, y) = span isUpper s

320+

321+#endif

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

@@ -308,7 +308,7 @@ passwordSchema = mempty

308-- >>> data Person = Person { name :: String, age :: Int } deriving (Generic)

309-- >>> instance ToJSON Person

310-- >>> encode $ sketchSchema (Person "Jack" 25)

311−-- "{\"example\":{\"age\":25,\"name\":\"Jack\"},\"required\":[\"age\",\"name\"],\"type\":\"object\",\"properties\":{\"age\":{\"type\":\"number\"},\"name\":{\"type\":\"string\"}}}"

311+-- "{\"required\":[\"age\",\"name\"],\"properties\":{\"age\":{\"type\":\"number\"},\"name\":{\"type\":\"string\"}},\"example\":{\"age\":25,\"name\":\"Jack\"},\"type\":\"object\"}"

312sketchSchema :: ToJSON a => a -> Schema

313sketchSchema = sketch . toJSON

314 where

@@ -352,7 +352,7 @@ sketchSchema = sketch . toJSON

352-- >>> data Person = Person { name :: String, age :: Int } deriving (Generic)

353-- >>> instance ToJSON Person

354-- >>> encode $ sketchStrictSchema (Person "Jack" 25)

355−-- "{\"minProperties\":2,\"required\":[\"age\",\"name\"],\"maxProperties\":2,\"type\":\"object\",\"enum\":[{\"age\":25,\"name\":\"Jack\"}],\"properties\":{\"age\":{\"maximum\":25,\"minimum\":25,\"multipleOf\":25,\"type\":\"number\",\"enum\":[25]},\"name\":{\"maxLength\":4,\"pattern\":\"Jack\",\"minLength\":4,\"type\":\"string\",\"enum\":[\"Jack\"]}}}"

355+-- "{\"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\"}]}"

356sketchStrictSchema :: ToJSON a => a -> Schema

357sketchStrictSchema = go . toJSON

358 where

src/Data/Swagger/Operation.hs+4−4

@@ -81,9 +81,9 @@ allOperations = paths.traverse.template

81-- >>> let api = (mempty :: Swagger) & paths .~ [("/user", mempty & get ?~ ok & post ?~ ok)]

82-- >>> let sub = (mempty :: Swagger) & paths .~ [("/user", mempty & get ?~ mempty)]

83-- >>> encode api

84−-- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"paths\":{\"/user\":{\"post\":{\"responses\":{\"200\":{\"description\":\"OK\"}}},\"get\":{\"responses\":{\"200\":{\"description\":\"OK\"}}}}}}"

84+-- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"paths\":{\"/user\":{\"get\":{\"responses\":{\"200\":{\"description\":\"OK\"}}},\"post\":{\"responses\":{\"200\":{\"description\":\"OK\"}}}}}}"

85-- >>> encode $ api & operationsOf sub . at 404 ?~ "Not found"

86−-- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"paths\":{\"/user\":{\"post\":{\"responses\":{\"200\":{\"description\":\"OK\"}}},\"get\":{\"responses\":{\"404\":{\"description\":\"Not found\"},\"200\":{\"description\":\"OK\"}}}}}}"

86+-- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"paths\":{\"/user\":{\"get\":{\"responses\":{\"404\":{\"description\":\"Not found\"},\"200\":{\"description\":\"OK\"}}},\"post\":{\"responses\":{\"200\":{\"description\":\"OK\"}}}}}}"

87operationsOf :: Swagger -> Traversal' Swagger Operation

88operationsOf sub = paths.itraversed.withIndex.subops

89 where

@@ -120,7 +120,7 @@ applyTagsFor ops ts swag = swag

120-- necessary schema definitions.

121--

122-- >>> encode $ runDeclare (declareResponse (Proxy :: Proxy Day)) mempty

123−-- "[{\"Day\":{\"format\":\"date\",\"type\":\"string\"}},{\"schema\":{\"$ref\":\"#/definitions/Day\"},\"description\":\"\"}]"

123+-- "[{\"Day\":{\"format\":\"date\",\"type\":\"string\"}},{\"description\":\"\",\"schema\":{\"$ref\":\"#/definitions/Day\"}}]"

124declareResponse :: ToSchema a => proxy a -> Declare (Definitions Schema) Response

125declareResponse proxy = do

126 s <- declareSchemaRef proxy

@@ -140,7 +140,7 @@ declareResponse proxy = do

140-- >>> let api = (mempty :: Swagger) & paths .~ [("/user", mempty & get ?~ mempty)]

141-- >>> let res = declareResponse (Proxy :: Proxy Day)

142-- >>> encode $ api & setResponse 200 res

143−-- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"definitions\":{\"Day\":{\"format\":\"date\",\"type\":\"string\"}},\"paths\":{\"/user\":{\"get\":{\"responses\":{\"200\":{\"schema\":{\"$ref\":\"#/definitions/Day\"},\"description\":\"\"}}}}}}"

143+-- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"paths\":{\"/user\":{\"get\":{\"responses\":{\"200\":{\"schema\":{\"$ref\":\"#/definitions/Day\"},\"description\":\"\"}}}}},\"definitions\":{\"Day\":{\"format\":\"date\",\"type\":\"string\"}}}"

144--

145-- See also @'setResponseWith'@.

146setResponse :: HttpStatusCode -> Declare (Definitions Schema) Response -> Swagger -> Swagger

swagger2.cabal+3−1

@@ -63,10 +63,12 @@ test-suite spec

63 type: exitcode-stdio-1.0

64 hs-source-dirs: test

65 main-is: Spec.hs

66+ -- We need aeson's toEncoding for doctests too

66 build-depends: base

67 build-depends: base

67 , base-compat

68 , base-compat

68− , aeson

69+ , aeson >=0.10.0.0

69 , aeson-qq

70 , aeson-qq

71+ , bytestring

70 , containers

72 , containers

71 , hashable

73 , hashable

72 , hspec

74 , hspec

test/SpecCommon.hs+7−2

@@ -1,6 +1,7 @@

1module SpecCommon where

3import Data.Aeson

4+import Data.ByteString.Builder (toLazyByteString)

4import qualified Data.Foldable as F

5import qualified Data.Foldable as F

5import qualified Data.HashMap.Strict as HashMap

6import qualified Data.HashMap.Strict as HashMap

6import qualified Data.Vector as Vector

7import qualified Data.Vector as Vector

@@ -21,5 +22,9 @@ x <=> js = do

21 toJSON x `shouldBe` js

22 toJSON x `shouldBe` js

22 it "decodes correctly" $ do

23 it "decodes correctly" $ do

23 fromJSON js `shouldBe` Success x

24 fromJSON js `shouldBe` Success x

24−

25+ it "roundtrips: eitherDecode . encode" $ do

25−

26+ eitherDecode (encode x) `shouldBe` Right x

27+ it "roundtrips with toJSON" $ do

28+ eitherDecode (encode $ toJSON x) `shouldBe` Right x

29+ it "roundtrips with toEncoding" $ do

30+ eitherDecode (toLazyByteString $ fromEncoding $ toEncoding x) `shouldBe` Right x