From 4cb57ea0528a16a2bdf121c48a0b65e1792cd2ae Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Sat, 5 Mar 2016 20:16:04 +0200 Subject: [PATCH 1/9] Update stack.yaml --- stack.yaml | 6 ++++-- swagger2.cabal | 1 + 2 files changed, 5 insertions(+), 2 deletions(-) diff --git a/stack.yaml b/stack.yaml index 1472a8d..519328e 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,5 +1,7 @@ flags: {} packages: - '.' -extra-deps: [] -resolver: nightly-2016-01-26 +extra-deps: +- aeson-0.11.1.0 +- insert-ordered-containers-0.1.0.1 +resolver: nightly-2016-03-04 diff --git a/swagger2.cabal b/swagger2.cabal index c34e0c4..5c47638 100644 --- a/swagger2.cabal +++ b/swagger2.cabal @@ -44,6 +44,7 @@ library , containers , hashable , http-media + , insert-ordered-containers >=0.1.0.0 && <0.2 , lens , mtl , network From e924625a5d5ab3eb7f528cf1322f407002242f5c Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Sat, 5 Mar 2016 20:16:14 +0200 Subject: [PATCH 2/9] Use OrdHashMap --- src/Data/Swagger/Internal.hs | 29 ++++++++++++------- src/Data/Swagger/Internal/Schema.hs | 19 +++++++----- .../Swagger/Internal/Schema/Validation.hs | 6 ++-- src/Data/Swagger/Internal/Utils.hs | 6 ++++ src/Data/Swagger/Operation.hs | 9 +++--- test/Data/Swagger/SchemaSpec.hs | 3 +- 6 files changed, 46 insertions(+), 26 deletions(-) diff --git a/src/Data/Swagger/Internal.hs b/src/Data/Swagger/Internal.hs index 863693d..f658bef 100644 --- a/src/Data/Swagger/Internal.hs +++ b/src/Data/Swagger/Internal.hs @@ -38,10 +38,13 @@ import Network (HostName, PortNumber) import Network.HTTP.Media (MediaType) import Text.Read (readMaybe) +import Data.HashMap.Strict.InsOrd (InsOrdHashMap) +import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap + import Data.Swagger.Internal.Utils -- | A list of definitions that can be used in references. -type Definitions = HashMap Text +type Definitions = InsOrdHashMap Text -- | This is the root document object for the API specification. data Swagger = Swagger @@ -73,7 +76,7 @@ data Swagger = Swagger -- | The available paths and operations for the API. -- Holds the relative paths to the individual endpoints. -- The path is appended to the @'basePath'@ in order to construct the full URL. - , _swaggerPaths :: HashMap FilePath PathItem + , _swaggerPaths :: InsOrdHashMap FilePath PathItem -- | An object to hold data types produced and consumed by operations. , _swaggerDefinitions :: Definitions Schema @@ -482,7 +485,7 @@ data Schema = Schema , _schemaRequired :: [ParamName] , _schemaAllOf :: Maybe [Schema] - , _schemaProperties :: HashMap Text (Referenced Schema) + , _schemaProperties :: InsOrdHashMap Text (Referenced Schema) , _schemaAdditionalProperties :: Maybe (Referenced Schema) , _schemaDiscriminator :: Maybe Text @@ -574,7 +577,7 @@ data Responses = Responses -- | Any HTTP status code can be used as the property name (one property per HTTP status code). -- Describes the expected response for those HTTP status codes. - , _responsesResponses :: HashMap HttpStatusCode (Referenced Response) + , _responsesResponses :: InsOrdHashMap HttpStatusCode (Referenced Response) } deriving (Eq, Show, Generic, Data, Typeable) type HttpStatusCode = Int @@ -593,7 +596,7 @@ data Response = Response , _responseSchema :: Maybe (Referenced Schema) -- | A list of headers that are sent with the response. - , _responseHeaders :: HashMap HeaderName Header + , _responseHeaders :: InsOrdHashMap HeaderName Header -- | An example of the response message. , _responseExamples :: Maybe Example @@ -659,7 +662,7 @@ data OAuth2Params = OAuth2Params _oauth2Flow :: OAuth2Flow -- | The available scopes for the OAuth2 security scheme. - , _oauth2Scopes :: HashMap Text Text + , _oauth2Scopes :: InsOrdHashMap Text Text } deriving (Eq, Show, Generic, Data, Typeable) data SecuritySchemeType @@ -680,7 +683,7 @@ data SecurityScheme = SecurityScheme -- The object can have multiple security schemes declared in it which are all required -- (that is, there is a logical AND between the schemes). newtype SecurityRequirement = SecurityRequirement - { getSecurityRequirement :: HashMap Text [Text] + { getSecurityRequirement :: InsOrdHashMap Text [Text] } deriving (Eq, Read, Show, Monoid, ToJSON, FromJSON, Data, Typeable) -- | Tag name. @@ -818,6 +821,10 @@ instance OVERLAPPING_ SwaggerMonoid (HashMap FilePath PathItem) where swaggerMempty = HashMap.empty swaggerMappend = HashMap.unionWith mappend +instance OVERLAPPING_ SwaggerMonoid (InsOrdHashMap FilePath PathItem) where + swaggerMempty = InsOrdHashMap.empty + swaggerMappend = InsOrdHashMap.unionWith mappend + instance Monoid a => SwaggerMonoid (Referenced a) where swaggerMempty = Inline mempty swaggerMappend (Inline x) (Inline y) = Inline (x <> y) @@ -972,7 +979,7 @@ instance ToJSON ParamOtherSchema where instance ToJSON Responses where toJSON (Responses def rs) = omitEmpties $ - toJSON (hashMapMapKeys show rs) <+> object [ "default" .= def ] + toJSON (InsOrdHashMap.mapKeys show rs) <+> object [ "default" .= def ] instance ToJSON Response where toJSON = omitEmpties . genericToJSON (jsonPrefix "response") @@ -1071,7 +1078,7 @@ instance FromJSON SecurityScheme where instance FromJSON Schema where parseJSON = genericParseJSONWithSub "paramSchema" (jsonPrefix "schema") - `withDefaults` [ "properties" .= (mempty :: HashMap Text Schema) + `withDefaults` [ "properties" .= (mempty :: InsOrdHashMap Text Schema) , "required" .= ([] :: [ParamName]) ] instance FromJSON Header where @@ -1118,7 +1125,7 @@ instance FromJSON ParamOtherSchema where instance FromJSON Responses where parseJSON (Object o) = Responses <$> o .:? "default" - <*> (parseJSON (Object (HashMap.delete "default" o)) >>= hashMapReadKeys) + <*> (parseJSON (Object (HashMap.delete "default" o))) parseJSON _ = empty instance FromJSON Example where @@ -1128,7 +1135,7 @@ instance FromJSON Example where instance FromJSON Response where parseJSON = genericParseJSON (jsonPrefix "response") - `withDefaults` [ "headers" .= (mempty :: HashMap HeaderName Header) ] + `withDefaults` [ "headers" .= (mempty :: InsOrdHashMap HeaderName Header) ] instance FromJSON Operation where parseJSON = genericParseJSON (jsonPrefix "operation") diff --git a/src/Data/Swagger/Internal/Schema.hs b/src/Data/Swagger/Internal/Schema.hs index b1eb5b7..f012c64 100644 --- a/src/Data/Swagger/Internal/Schema.hs +++ b/src/Data/Swagger/Internal/Schema.hs @@ -25,6 +25,7 @@ import Control.Applicative import Control.Monad import Control.Monad.Writer import Data.Aeson +import qualified Data.Aeson.Types as Aeson import Data.Char import Data.Data (Data) import Data.Foldable (traverse_) @@ -33,6 +34,8 @@ 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.HashMap.Strict.InsOrd (InsOrdHashMap) +import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap import Data.Int import Data.IntSet (IntSet) import Data.IntMap (IntMap) @@ -194,7 +197,7 @@ declareSchemaRef proxy = do -- have already declared it. -- If we have, we don't need to declare anything for -- this schema this time and thus simply return the reference. - known <- looks (HashMap.member name) + known <- looks (InsOrdHashMap.member name) when (not known) $ do declare [(name, schema)] void $ declareNamedSchema proxy @@ -213,7 +216,7 @@ inlineSchemasWhen p defs = template %~ deref where deref r@(Ref (Reference name)) | p name = - case HashMap.lookup name defs of + case InsOrdHashMap.lookup name defs of Just schema -> Inline (inlineSchemasWhen p defs schema) Nothing -> r | otherwise = r @@ -255,7 +258,7 @@ inlineNonRecursiveSchemas :: Data s => (Definitions Schema) -> s -> s inlineNonRecursiveSchemas defs = inlineSchemasWhen nonRecursive defs where nonRecursive name = - case HashMap.lookup name defs of + case InsOrdHashMap.lookup name defs of Just schema -> name `notElem` execDeclare (usedNames schema) mempty Nothing -> False @@ -267,7 +270,7 @@ inlineNonRecursiveSchemas defs = inlineSchemasWhen nonRecursive defs seen <- looks (name `elem`) when (not seen) $ do declare [name] - traverse_ usedNames (HashMap.lookup name defs) + traverse_ usedNames (InsOrdHashMap.lookup name defs) Inline subschema -> usedNames subschema -- | Default schema for binary data (any sequence of octets). @@ -331,7 +334,7 @@ sketchSchema = sketch . toJSON go js@(Object o) = mempty & type_ .~ SwaggerObject & required .~ HashMap.keys o - & properties .~ fmap (Inline . go) o + & properties .~ fmap (Inline . go) (InsOrdHashMap.fromHashMap o) -- | Make a restrictive sketch of a @'Schema'@ based on a @'ToJSON'@ instance. -- Produced schema uses as much constraints as possible. @@ -381,7 +384,7 @@ sketchStrictSchema = go . toJSON go js@(Object o) = mempty & type_ .~ SwaggerObject & required .~ names - & properties .~ fmap (Inline . go) o + & properties .~ fmap (Inline . go) (InsOrdHashMap.fromHashMap o) & maxProperties ?~ fromIntegral (length names) & minProperties ?~ fromIntegral (length names) & enum_ ?~ [js] @@ -605,7 +608,7 @@ gdeclareSchemaRef opts proxy = do -- have already declared it. -- If we have, we don't need to declare anything for -- this schema this time and thus simply return the reference. - known <- looks (HashMap.member name) + known <- looks (InsOrdHashMap.member name) when (not known) $ do declare [(name, schema)] void $ gdeclareNamedSchema opts proxy mempty @@ -662,7 +665,7 @@ gdeclareNamedSumSchema opts proxy s toStringTag schema = mempty & type_ .~ SwaggerString - & enum_ ?~ map toJSON (schema ^.. properties.ifolded.asIndex) + & enum_ ?~ map toJSON (schema ^.. properties.ifolded.asIndex) type AllNullary = All diff --git a/src/Data/Swagger/Internal/Schema/Validation.hs b/src/Data/Swagger/Internal/Schema/Validation.hs index 22e5eab..e548fd1 100644 --- a/src/Data/Swagger/Internal/Schema/Validation.hs +++ b/src/Data/Swagger/Internal/Schema/Validation.hs @@ -30,6 +30,8 @@ import Data.Foldable (traverse_, for_, sequenceA_) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap import qualified "unordered-containers" Data.HashSet as HashSet +import Data.HashMap.Strict.InsOrd (InsOrdHashMap) +import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap import Data.Monoid import Data.Proxy import Data.Scientific (Scientific, isInteger) @@ -174,7 +176,7 @@ sub_ = lmap . view -- | Validate value against a schema given schema reference and validation function. withRef :: Reference -> (Schema -> Validation s a) -> Validation s a withRef (Reference ref) f = withConfig $ \cfg -> - case HashMap.lookup ref (configDefinitions cfg) of + case InsOrdHashMap.lookup ref (configDefinitions cfg) of Nothing -> invalid $ "unknown schema " ++ show ref Just s -> f s @@ -290,7 +292,7 @@ validateObject o = withSchema $ \schema -> case v of Null | not (k `elem` (schema ^. required)) -> valid -- null is fine for non-required property _ -> - case HashMap.lookup k (schema ^. properties) of + case InsOrdHashMap.lookup k (schema ^. properties) of Nothing -> check additionalProperties $ \s -> validateWithSchemaRef s v Just s -> validateWithSchemaRef s v diff --git a/src/Data/Swagger/Internal/Utils.hs b/src/Data/Swagger/Internal/Utils.hs index 7fa6178..fc1b3ad 100644 --- a/src/Data/Swagger/Internal/Utils.hs +++ b/src/Data/Swagger/Internal/Utils.hs @@ -20,6 +20,8 @@ import Data.Data import Data.Hashable (Hashable) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap +import Data.HashMap.Strict.InsOrd (InsOrdHashMap) +import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap import Data.Map (Map) import Data.Monoid import Data.Set (Set) @@ -161,6 +163,10 @@ instance (Eq k, Hashable k) => SwaggerMonoid (HashMap k v) where swaggerMempty = mempty swaggerMappend = HashMap.unionWith (\_old new -> new) +instance (Eq k, Hashable k) => SwaggerMonoid (InsOrdHashMap k v) where + swaggerMempty = mempty + swaggerMappend = InsOrdHashMap.unionWith (\_old new -> new) + instance SwaggerMonoid Text where swaggerMempty = mempty swaggerMappend x "" = x diff --git a/src/Data/Swagger/Operation.hs b/src/Data/Swagger/Operation.hs index bda9597..6717b70 100644 --- a/src/Data/Swagger/Operation.hs +++ b/src/Data/Swagger/Operation.hs @@ -46,6 +46,9 @@ import Data.Swagger.Internal import Data.Swagger.Lens import Data.Swagger.Schema +import Data.HashMap.Strict.InsOrd (InsOrdHashMap) +import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap + -- $setup -- >>> import Data.Aeson -- >>> import Data.Proxy @@ -58,10 +61,8 @@ import Data.Swagger.Schema -- >>> encode $ prependPath "user/{user_id}" api ^. paths -- "{\"/user/{user_id}/info\":{}}" prependPath :: FilePath -> Swagger -> Swagger -prependPath path = paths %~ mapKeys (path ) +prependPath path = paths %~ InsOrdHashMap.mapKeys (path ) where - mapKeys f = HashMap.fromList . map (first f) . HashMap.toList - x y = case trim y of "" -> "/" <> trim x y' -> "/" <> trim x <> "/" <> y' @@ -88,7 +89,7 @@ operationsOf sub = paths.itraversed.withIndex.subops where -- | Traverse operations that correspond to paths and methods of the sub API. subops :: Traversal' (FilePath, PathItem) Operation - subops f (path, item) = case HashMap.lookup path (sub ^. paths) of + subops f (path, item) = case InsOrdHashMap.lookup path (sub ^. paths) of Just subitem -> (,) path <$> methodsOf subitem f item Nothing -> pure (path, item) diff --git a/test/Data/Swagger/SchemaSpec.hs b/test/Data/Swagger/SchemaSpec.hs index 83c7c62..aaaa233 100644 --- a/test/Data/Swagger/SchemaSpec.hs +++ b/test/Data/Swagger/SchemaSpec.hs @@ -17,6 +17,7 @@ import qualified Data.Set as Set import qualified Data.Text as Text import GHC.Generics +import qualified Data.Swagger.OrdHashMap as OrdHashMap import Data.Swagger import Data.Swagger.Declare @@ -34,7 +35,7 @@ checkSchemaName sname proxy = checkDefs :: ToSchema a => Proxy a -> [String] -> Spec checkDefs proxy names = it ("uses these definitions " ++ show names) $ - Set.fromList (HashMap.keys defs) `shouldBe` Set.fromList (map Text.pack names) + Set.fromList (OrdHashMap.keys defs) `shouldBe` Set.fromList (map Text.pack names) where defs = execDeclare (declareNamedSchema proxy) mempty From 2a46257cb1e5fc548cdfbb6212a0b0b3cf82d2ac Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Fri, 4 Mar 2016 14:17:59 +0200 Subject: [PATCH 3/9] Tests' changes - make checkDefs stricter (tests) - add multiple-fields tests --- src/Data/Swagger/Internal/Schema.hs | 10 +++--- swagger2.cabal | 1 + test/Data/Swagger/SchemaSpec.hs | 50 +++++++++++++++++++++++++++-- 3 files changed, 54 insertions(+), 7 deletions(-) diff --git a/src/Data/Swagger/Internal/Schema.hs b/src/Data/Swagger/Internal/Schema.hs index f012c64..e3a4c08 100644 --- a/src/Data/Swagger/Internal/Schema.hs +++ b/src/Data/Swagger/Internal/Schema.hs @@ -567,8 +567,8 @@ gdeclareSchema opts proxy = _namedSchemaSchema <$> gdeclareNamedSchema opts prox instance (GToSchema f, GToSchema g) => GToSchema (f :*: g) where gdeclareNamedSchema opts _ schema = do - NamedSchema _ gschema <- gdeclareNamedSchema opts (Proxy :: Proxy g) schema - gdeclareNamedSchema opts (Proxy :: Proxy f) gschema + NamedSchema _ gschema <- gdeclareNamedSchema opts (Proxy :: Proxy f) schema + gdeclareNamedSchema opts (Proxy :: Proxy g) gschema instance (Datatype d, GToSchema f) => GToSchema (D1 d f) where gdeclareNamedSchema opts _ s = rename name <$> gdeclareNamedSchema opts (Proxy :: Proxy f) s @@ -617,7 +617,7 @@ gdeclareSchemaRef opts proxy = do appendItem :: Referenced Schema -> Maybe (SwaggerItems Schema) -> Maybe (SwaggerItems Schema) appendItem x Nothing = Just (SwaggerItemsArray [x]) -appendItem x (Just (SwaggerItemsArray xs)) = Just (SwaggerItemsArray (x:xs)) +appendItem x (Just (SwaggerItemsArray xs)) = Just (SwaggerItemsArray (xs ++ [x])) appendItem _ _ = error "GToSchema.appendItem: cannot append to SwaggerItemsObject" withFieldSchema :: forall proxy s f. (Selector s, GToSchema f) => @@ -633,7 +633,7 @@ withFieldSchema opts _ isRequiredField schema = do & type_ .~ SwaggerObject & properties . at fname ?~ ref & if isRequiredField - then required %~ (fname :) + then required %~ (++ [fname]) else id where fname = T.pack (fieldLabelModifier opts (selName (Proxy3 :: Proxy3 s f p))) @@ -673,7 +673,7 @@ class GSumToSchema f where gsumToSchema :: SchemaOptions -> proxy f -> Schema -> WriterT AllNullary (Declare (Definitions Schema)) Schema instance (GSumToSchema f, GSumToSchema g) => GSumToSchema (f :+: g) where - gsumToSchema opts _ = gsumToSchema opts (Proxy :: Proxy f) <=< gsumToSchema opts (Proxy :: Proxy g) + gsumToSchema opts _ = gsumToSchema opts (Proxy :: Proxy f) >=> gsumToSchema opts (Proxy :: Proxy g) gsumConToSchemaWith :: forall c f proxy. (GToSchema (C1 c f), Constructor c) => Referenced Schema -> SchemaOptions -> proxy (C1 c f) -> Schema -> Schema diff --git a/swagger2.cabal b/swagger2.cabal index 5c47638..e167947 100644 --- a/swagger2.cabal +++ b/swagger2.cabal @@ -68,6 +68,7 @@ test-suite spec , containers , hashable , hspec + , insert-ordered-containers , HUnit , mtl , QuickCheck diff --git a/test/Data/Swagger/SchemaSpec.hs b/test/Data/Swagger/SchemaSpec.hs index aaaa233..87e75c5 100644 --- a/test/Data/Swagger/SchemaSpec.hs +++ b/test/Data/Swagger/SchemaSpec.hs @@ -7,17 +7,18 @@ module Data.Swagger.SchemaSpec where import Prelude () import Prelude.Compat +import Control.Lens ((^.)) import Data.Aeson import Data.Aeson.QQ import Data.Char import qualified Data.HashMap.Strict as HashMap +import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap import Data.Proxy import Data.Set (Set) import qualified Data.Set as Set import qualified Data.Text as Text import GHC.Generics -import qualified Data.Swagger.OrdHashMap as OrdHashMap import Data.Swagger import Data.Swagger.Declare @@ -35,10 +36,17 @@ checkSchemaName sname proxy = checkDefs :: ToSchema a => Proxy a -> [String] -> Spec checkDefs proxy names = it ("uses these definitions " ++ show names) $ - Set.fromList (OrdHashMap.keys defs) `shouldBe` Set.fromList (map Text.pack names) + InsOrdHashMap.keys defs `shouldBe` map Text.pack names where defs = execDeclare (declareNamedSchema proxy) mempty +checkProperties :: ToSchema a => Proxy a -> [String] -> Spec +checkProperties proxy names = + it ("has these fields in order " ++ show names) $ + InsOrdHashMap.keys fields `shouldBe` map Text.pack names + where + fields = toSchema proxy ^. properties + checkInlinedSchema :: ToSchema a => Proxy a -> Value -> Spec checkInlinedSchema proxy js = toInlinedSchema proxy <=> js @@ -59,6 +67,9 @@ spec = do context "Person" $ checkToSchema (Proxy :: Proxy Person) personSchemaJSON context "ISPair" $ checkToSchema (Proxy :: Proxy ISPair) ispairSchemaJSON context "Point (fieldLabelModifier)" $ checkToSchema (Proxy :: Proxy Point) pointSchemaJSON + context "Point5 (many field record)" $ do + checkToSchema (Proxy :: Proxy Point5) point5SchemaJSON + checkProperties (Proxy :: Proxy Point5) point5Properties context "Color (bounded enum)" $ checkToSchema (Proxy :: Proxy Color) colorSchemaJSON context "Shade (paramSchemaToNamedSchema)" $ checkToSchema (Proxy :: Proxy Shade) shadeSchemaJSON context "Paint (record with bounded enum field)" $ checkToSchema (Proxy :: Proxy Paint) paintSchemaJSON @@ -144,6 +155,7 @@ ispairSchemaJSON = [aesonQQ| -- ======================================================================== -- Point (record data type with custom fieldLabelModifier) -- ======================================================================== + data Point = Point { pointX :: Double , pointY :: Double @@ -166,6 +178,40 @@ pointSchemaJSON = [aesonQQ| } |] +-- ======================================================================== +-- Point (record data type with multiple fields) +-- ======================================================================== + +data Point5 = Point5 + { point5X :: Double + , point5Y :: Double + , point5Z :: Double + , point5U :: Double + , point5V :: Double -- 5 dimensional! + } deriving (Generic) + +instance ToSchema Point5 where + declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions + { fieldLabelModifier = map toLower . drop (length "point5") } + +point5SchemaJSON :: Value +point5SchemaJSON = [aesonQQ| +{ + "type": "object", + "properties": + { + "x": { "type": "number", "format": "double" }, + "y": { "type": "number", "format": "double" }, + "z": { "type": "number", "format": "double" }, + "u": { "type": "number", "format": "double" }, + "v": { "type": "number", "format": "double" } + }, + "required": ["x", "y", "z", "u", "v"] +} +|] + +point5Properties :: [String] +point5Properties = ["x", "y", "z", "u", "v"] -- ======================================================================== -- Color (enum) From b982c7dd1fe8fb007d25a5b56114fe62d48b745a Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Tue, 8 Mar 2016 09:04:15 +0200 Subject: [PATCH 4/9] Simplify ToJSON Responses --- src/Data/Swagger/Internal.hs | 3 +-- src/Data/Swagger/Internal/Utils.hs | 2 +- 2 files changed, 2 insertions(+), 3 deletions(-) diff --git a/src/Data/Swagger/Internal.hs b/src/Data/Swagger/Internal.hs index f658bef..d095be5 100644 --- a/src/Data/Swagger/Internal.hs +++ b/src/Data/Swagger/Internal.hs @@ -978,8 +978,7 @@ instance ToJSON ParamOtherSchema where toJSON = genericToJSONWithSub "paramSchema" (jsonPrefix "paramOtherSchema") instance ToJSON Responses where - toJSON (Responses def rs) = omitEmpties $ - toJSON (InsOrdHashMap.mapKeys show rs) <+> object [ "default" .= def ] + toJSON = omitEmpties . genericToJSONWithSub "responses" (jsonPrefix "responses") instance ToJSON Response where toJSON = omitEmpties . genericToJSON (jsonPrefix "response") diff --git a/src/Data/Swagger/Internal/Utils.hs b/src/Data/Swagger/Internal/Utils.hs index fc1b3ad..1b51724 100644 --- a/src/Data/Swagger/Internal/Utils.hs +++ b/src/Data/Swagger/Internal/Utils.hs @@ -111,7 +111,7 @@ genericParseJSONWithSub sub opts js@(Object o) <|> genericParseJSON opts js' -- try with subjson where js' = Object (HashMap.insert sub (Object o) o) -genericParseJSONWithSub _ _ _ = error "genericParseJSONWithSub: given json is not an object" +genericParseJSONWithSub _ _ _ = fail "genericParseJSONWithSub: given json is not an object" (<+>) :: Value -> Value -> Value Object x <+> Object y = Object (x <> y) From e2a9cc2a964b98b70ac1d199fe8be60939b657c4 Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Mon, 7 Mar 2016 00:49:23 +0200 Subject: [PATCH 5/9] RFC: using generics-sop to derive some ToJSON instances --- src/Data/Swagger/Internal.hs | 68 ++++++++++++------ src/Data/Swagger/Internal/AesonUtils.hs | 94 +++++++++++++++++++++++++ src/Data/Swagger/Internal/Utils.hs | 21 ++---- swagger2.cabal | 3 + 4 files changed, 149 insertions(+), 37 deletions(-) create mode 100644 src/Data/Swagger/Internal/AesonUtils.hs diff --git a/src/Data/Swagger/Internal.hs b/src/Data/Swagger/Internal.hs index d095be5..c3f5303 100644 --- a/src/Data/Swagger/Internal.hs +++ b/src/Data/Swagger/Internal.hs @@ -12,12 +12,17 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TemplateHaskell #-} #include "overlapping-compat.h" module Data.Swagger.Internal where import Prelude () import Prelude.Compat +import Control.Lens ((&), (.~), (?~)) import Control.Applicative import Control.Monad import Data.Aeson @@ -41,6 +46,11 @@ import Text.Read (readMaybe) import Data.HashMap.Strict.InsOrd (InsOrdHashMap) import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap +import Generics.SOP.TH (deriveGeneric) +import Data.Swagger.Internal.AesonUtils (sopSwaggerGenericToJSON + ,mkSwaggerAesonOptions + ,saoAdditionalPairs + ,saoSubObject) import Data.Swagger.Internal.Utils -- | A list of definitions that can be used in references. @@ -921,7 +931,8 @@ instance ToJSON OAuth2Flow where , "tokenUrl" .= tokenUrl ] instance ToJSON OAuth2Params where - toJSON = omitEmpties . genericToJSONWithSub "flow" (jsonPrefix "oauth2") + toJSON = sopSwaggerGenericToJSON $ mkSwaggerAesonOptions "oauth2" & + saoSubObject ?~ "flow" instance ToJSON SecuritySchemeType where toJSON SecuritySchemeBasic @@ -934,22 +945,20 @@ instance ToJSON SecuritySchemeType where <+> object [ "type" .= ("oauth2" :: Text) ] instance ToJSON Swagger where - toJSON = omitEmpties . addVersion . genericToJSON (jsonPrefix "swagger") - where - addVersion (Object o) = Object (HashMap.insert "swagger" "2.0" o) - addVersion _ = error "impossible" + toJSON = sopSwaggerGenericToJSON $ mkSwaggerAesonOptions "swagger" & + saoAdditionalPairs .~ [("swagger", "2.0")] instance ToJSON SecurityScheme where - toJSON = genericToJSONWithSub "type" (jsonPrefix "securityScheme") + toJSON = sopSwaggerGenericToJSON $ mkSwaggerAesonOptions "securityScheme" & + saoSubObject ?~ "type" instance ToJSON Schema where - toJSON = omitEmptiesExcept f . genericToJSONWithSub "paramSchema" (jsonPrefix "schema") - where - f "items" (Array _) = True - f _ _ = False + toJSON = sopSwaggerGenericToJSON $ mkSwaggerAesonOptions "schema" & + saoSubObject ?~ "paramSchema" instance ToJSON Header where - toJSON = genericToJSONWithSub "paramSchema" (jsonPrefix "header") + toJSON = sopSwaggerGenericToJSON $ mkSwaggerAesonOptions "header" & + saoSubObject ?~ "paramSchema" instance ToJSON (SwaggerItems t) where toJSON (SwaggerItemsPrimitive fmt schema) = object @@ -968,26 +977,29 @@ instance ToJSON MimeList where toJSON (MimeList xs) = toJSON (map show xs) instance ToJSON Param where - toJSON = genericToJSONWithSub "schema" (jsonPrefix "param") + toJSON = sopSwaggerGenericToJSON $ mkSwaggerAesonOptions "param" & + saoSubObject ?~ "schema" instance ToJSON ParamAnySchema where toJSON (ParamBody s) = object [ "in" .= ("body" :: Text), "schema" .= s ] toJSON (ParamOther s) = toJSON s instance ToJSON ParamOtherSchema where - toJSON = genericToJSONWithSub "paramSchema" (jsonPrefix "paramOtherSchema") + toJSON = sopSwaggerGenericToJSON $ mkSwaggerAesonOptions "paramOtherSchema" & + saoSubObject ?~ "paramSchema" instance ToJSON Responses where - toJSON = omitEmpties . genericToJSONWithSub "responses" (jsonPrefix "responses") + toJSON = sopSwaggerGenericToJSON $ mkSwaggerAesonOptions "responses" & + saoSubObject ?~ "responses" instance ToJSON Response where - toJSON = omitEmpties . genericToJSON (jsonPrefix "response") + toJSON = sopSwaggerGenericToJSON $ mkSwaggerAesonOptions "response" instance ToJSON Operation where - toJSON = omitEmpties . genericToJSON (jsonPrefix "operation") + toJSON = sopSwaggerGenericToJSON $ mkSwaggerAesonOptions "operation" instance ToJSON PathItem where - toJSON = omitEmpties . genericToJSON (jsonPrefix "pathItem") + toJSON = sopSwaggerGenericToJSON $ mkSwaggerAesonOptions "pathItem" instance ToJSON Example where toJSON = toJSON . Map.mapKeys show . getExample @@ -1021,10 +1033,8 @@ instance ToJSON (CollectionFormat t) where toJSON CollectionMulti = "multi" instance ToJSON (ParamSchema t) where - toJSON = omitEmptiesExcept f . genericToJSONWithSub "items" (jsonPrefix "paramSchema") - where - f "items" (Array _) = True - f _ _ = False + toJSON = sopSwaggerGenericToJSON $ mkSwaggerAesonOptions "paramSchema" & + saoSubObject ?~ "items" -- ======================================================================= -- Manual FromJSON instances @@ -1193,3 +1203,19 @@ instance FromJSON (CollectionFormat ParamOtherSchema) where instance (FromJSON (SwaggerType t), FromJSON (SwaggerItems t)) => FromJSON (ParamSchema t) where parseJSON = genericParseJSONWithSub "items" (jsonPrefix "ParamSchema") +------------------------------------------------------------------------------- +-- TH splices +------------------------------------------------------------------------------- + +deriveGeneric ''Header +deriveGeneric ''OAuth2Params +deriveGeneric ''Operation +deriveGeneric ''Param +deriveGeneric ''ParamOtherSchema +deriveGeneric ''PathItem +deriveGeneric ''Response +deriveGeneric ''Responses +deriveGeneric ''SecurityScheme +deriveGeneric ''Schema +deriveGeneric ''ParamSchema +deriveGeneric ''Swagger diff --git a/src/Data/Swagger/Internal/AesonUtils.hs b/src/Data/Swagger/Internal/AesonUtils.hs new file mode 100644 index 0000000..00a9634 --- /dev/null +++ b/src/Data/Swagger/Internal/AesonUtils.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE TemplateHaskell #-} +module Data.Swagger.Internal.AesonUtils ( + -- * Generic functions + sopSwaggerGenericToJSON, + -- * Options + SwaggerAesonOptions, + mkSwaggerAesonOptions, + saoPrefix, + saoAdditionalPairs, + saoSubObject, + ) where + +import Prelude () +import Prelude.Compat + +import Control.Lens (makeLenses, (^.)) +import Data.Aeson (ToJSON(..), Value(..), object) +import Data.Text (Text) +import Data.Char (toLower, isUpper) + +import Generics.SOP + +import qualified Data.Text as T +import qualified Data.HashMap.Strict as HM + +------------------------------------------------------------------------------- +-- SwaggerAesonOptions +------------------------------------------------------------------------------- + +data SwaggerAesonOptions = SwaggerAesonOptions + { _saoPrefix :: String + , _saoAdditionalPairs :: [(Text, Value)] + , _saoSubObject :: Maybe String + } + +mkSwaggerAesonOptions + :: String -- ^ prefix + -> SwaggerAesonOptions +mkSwaggerAesonOptions pfx = SwaggerAesonOptions pfx [] Nothing + +makeLenses ''SwaggerAesonOptions + +------------------------------------------------------------------------------- +-- Generics +------------------------------------------------------------------------------- + +-- | Generic serialisation for swagger records. +-- +-- Features +-- +-- * omits nulls, empty objects and empty arrays (configurable) +-- * possible to add fields +-- * possible to merge sub-object +sopSwaggerGenericToJSON + :: forall a xs. (Generic a, HasDatatypeInfo a, All2 ToJSON (Code a), Code a ~ '[xs]) + => SwaggerAesonOptions + -> a + -> Value +sopSwaggerGenericToJSON opts x = + let ps = sopSwaggerGenericToJSON' opts (from x) (datatypeInfo (Proxy :: Proxy a)) + in object (opts ^. saoAdditionalPairs ++ ps) + +sopSwaggerGenericToJSON' :: All2 ToJSON '[xs] => SwaggerAesonOptions -> SOP I '[xs] -> DatatypeInfo '[xs] -> [(Text, Value)] +sopSwaggerGenericToJSON' opts (SOP (Z fields)) (ADT _ _ (Record _ fieldsInfo :* Nil)) = + sopSwaggerGenericToJSON'' opts fields fieldsInfo + +sopSwaggerGenericToJSON'' :: All ToJSON xs => SwaggerAesonOptions -> NP I xs -> NP FieldInfo xs -> [(Text, Value)] +sopSwaggerGenericToJSON'' (SwaggerAesonOptions prefix _ sub) = go + where + go :: All ToJSON ys => NP I ys -> NP FieldInfo ys -> [(Text, Value)] + go Nil Nil = [] + go (I x :* xs) (FieldInfo name :* names) + | Just name' == sub = case json of + Object m -> HM.toList m ++ rest + Null -> rest + _ -> error $ "sopSwaggerGenericToJSON: subjson is not an object: " ++ show json + | json == Null || json == Array mempty || json == Object mempty = + rest + | otherwise = + (T.pack name', json) : rest + where + json = toJSON x + name' = fieldNameModifier name + rest = go xs names + + fieldNameModifier = modifier . drop 1 + modifier = lowerFirstUppers . drop (length prefix) + lowerFirstUppers s = map toLower x ++ y + where (x, y) = span isUpper s diff --git a/src/Data/Swagger/Internal/Utils.hs b/src/Data/Swagger/Internal/Utils.hs index 1b51724..2ac7504 100644 --- a/src/Data/Swagger/Internal/Utils.hs +++ b/src/Data/Swagger/Internal/Utils.hs @@ -87,23 +87,12 @@ parseOneOf xs js = where ys = zip (map toJSON xs) xs -omitEmptiesExcept :: (Text -> Value -> Bool) -> Value -> Value -omitEmptiesExcept f (Object o) = Object (HashMap.filterWithKey nonEmpty o) - where - nonEmpty k js = f k js || (js /= Object mempty) && (js /= Array mempty) && (js /= Null) -omitEmptiesExcept _ js = js - +{-# DEPRECATED omitEmpties "will be removed" #-} omitEmpties :: Value -> Value -omitEmpties = omitEmptiesExcept (\_ _ -> False) - -genericToJSONWithSub :: (Generic a, GToJSON (Rep a)) => Text -> Options -> a -> Value -genericToJSONWithSub sub opts x = - case genericToJSON opts x of - Object o -> - case HashMap.lookup sub o of - Just so -> Object (HashMap.delete sub o) <+> so - Nothing -> Object o -- no subjson, leaving object as is - _ -> error "genericToJSONWithSub: subjson is not an object" +omitEmpties (Object o) = Object (HashMap.filter nonEmpty o) + where + nonEmpty js = (js /= Object mempty) && (js /= Array mempty) && (js /= Null) +omitEmpties js = js genericParseJSONWithSub :: (Generic a, GFromJSON (Rep a)) => Text -> Options -> Value -> Parser a genericParseJSONWithSub sub opts js@(Object o) diff --git a/swagger2.cabal b/swagger2.cabal index e167947..3102ef6 100644 --- a/swagger2.cabal +++ b/swagger2.cabal @@ -38,11 +38,14 @@ library Data.Swagger.Internal.Schema.Validation Data.Swagger.Internal.ParamSchema Data.Swagger.Internal.Utils + Data.Swagger.Internal.AesonUtils build-depends: base >=4.7 && <4.10 , base-compat >=0.6.0 && <0.10 , aeson , containers , hashable + , generics-sop >=0.2 && <0.3 + , generics-sop-lens >=0.1.0.0 && <0.2 , http-media , insert-ordered-containers >=0.1.0.0 && <0.2 , lens From f508aa282933fdf216836a7c743e375b8b9a4449 Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Tue, 8 Mar 2016 11:48:26 +0200 Subject: [PATCH 6/9] Derive FromJSON instances too --- src/Data/Swagger/Internal.hs | 262 +++++++++++++++--------- src/Data/Swagger/Internal/AesonUtils.hs | 180 ++++++++++++++-- src/Data/Swagger/Internal/Schema.hs | 3 +- src/Data/Swagger/Internal/Utils.hs | 31 --- src/Data/Swagger/Lens.hs | 15 +- swagger2.cabal | 1 - test/Data/Swagger/ParamSchemaSpec.hs | 4 +- 7 files changed, 344 insertions(+), 152 deletions(-) diff --git a/src/Data/Swagger/Internal.hs b/src/Data/Swagger/Internal.hs index c3f5303..59443a7 100644 --- a/src/Data/Swagger/Internal.hs +++ b/src/Data/Swagger/Internal.hs @@ -8,6 +8,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} @@ -48,6 +49,10 @@ import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap import Generics.SOP.TH (deriveGeneric) import Data.Swagger.Internal.AesonUtils (sopSwaggerGenericToJSON + ,sopSwaggerGenericToJSONWithOpts + ,sopSwaggerGenericParseJSON + ,HasSwaggerAesonOptions(..) + ,AesonDefaultValue(..) ,mkSwaggerAesonOptions ,saoAdditionalPairs ,saoSubObject) @@ -343,8 +348,8 @@ data ParamOtherSchema = ParamOtherSchema -- Default value is @False@. , _paramOtherSchemaAllowEmptyValue :: Maybe Bool - , _paramOtherSchemaParamSchema :: ParamSchema ParamOtherSchema - } deriving (Eq, Show, Generic, Data, Typeable) + , _paramOtherSchemaParamSchema :: ParamSchema SwaggerKindParamOtherSchema + } deriving (Eq, Show, Generic, Typeable, Data) -- | Items for @'SwaggerArray'@ schemas. -- @@ -357,9 +362,9 @@ data ParamOtherSchema = ParamOtherSchema -- -- @'SwaggerItemsArray'@ should be used to specify tuple @'Schema'@s. data SwaggerItems t where - SwaggerItemsPrimitive :: Maybe (CollectionFormat t) -> ParamSchema t -> SwaggerItems t - SwaggerItemsObject :: Referenced Schema -> SwaggerItems Schema - SwaggerItemsArray :: [Referenced Schema] -> SwaggerItems Schema + SwaggerItemsPrimitive :: Maybe (CollectionFormat k) -> ParamSchema k-> SwaggerItems k + SwaggerItemsObject :: Referenced Schema -> SwaggerItems SwaggerKindSchema + SwaggerItemsArray :: [Referenced Schema] -> SwaggerItems SwaggerKindSchema deriving (Typeable) deriving instance Eq (SwaggerItems t) @@ -369,17 +374,66 @@ deriving instance Show (SwaggerItems t) swaggerItemsPrimitiveConstr :: Constr swaggerItemsPrimitiveConstr = mkConstr swaggerItemsDataType "SwaggerItemsPrimitive" [] Prefix +swaggerItemsObjectConstr :: Constr +swaggerItemsObjectConstr = mkConstr swaggerItemsDataType "SwaggerItemsObject" [] Prefix + +swaggerItemsArrayConstr :: Constr +swaggerItemsArrayConstr = mkConstr swaggerItemsDataType "SwaggerItemsArray" [] Prefix + swaggerItemsDataType :: DataType swaggerItemsDataType = mkDataType "Data.Swagger.SwaggerItems" [swaggerItemsPrimitiveConstr] -instance OVERLAPPABLE_ Data t => Data (SwaggerItems t) where +-- Note: unfortunately we have to write these Data instances by hand, +-- to get better contexts / avoid duplicate name when using standalone deriving + +instance Data t => Data (SwaggerItems (SwaggerKindNormal t)) where + -- TODO: define gfoldl gunfold k z c = case constrIndex c of 1 -> k (k (z SwaggerItemsPrimitive)) _ -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type (SwaggerItems t)." toConstr _ = swaggerItemsPrimitiveConstr dataTypeOf _ = swaggerItemsDataType -deriving instance Data (SwaggerItems Schema) +-- SwaggerItems SwaggerKindParamOtherSchema can be constructed using SwaggerItemsPrimitive only +instance Data (SwaggerItems SwaggerKindParamOtherSchema) where + -- TODO: define gfoldl + gunfold k z c = case constrIndex c of + 1 -> k (k (z SwaggerItemsPrimitive)) + _ -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type (SwaggerItems SwaggerKindParamOtherSchema)." + toConstr _ = swaggerItemsPrimitiveConstr + dataTypeOf _ = swaggerItemsDataType + +instance Data (SwaggerItems SwaggerKindSchema) where + gfoldl _ _ (SwaggerItemsPrimitive _ _) = error $ " Data.Data.gfoldl: Constructor SwaggerItemsPrimitive used to construct SwaggerItems SwaggerKindSchema" + gfoldl k z (SwaggerItemsObject ref) = z SwaggerItemsObject `k` ref + gfoldl k z (SwaggerItemsArray ref) = z SwaggerItemsArray `k` ref + + gunfold k z c = case constrIndex c of + 1 -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type (SwaggerItems SwaggerKindSchema)" + 2 -> k (z SwaggerItemsObject) + 3 -> k (z SwaggerItemsArray) + + toConstr (SwaggerItemsObject _) = swaggerItemsObjectConstr + toConstr (SwaggerItemsArray _) = swaggerItemsArrayConstr + + dataTypeOf _ = swaggerItemsDataType + +-- | Type used as a kind to avoid overlapping instances. +data SwaggerKind t + = SwaggerKindNormal t + | SwaggerKindParamOtherSchema + | SwaggerKindSchema + +#if __GLASGLOW_HASKELL__ < 710 +deriving instance Typeable 'SwaggerKindNormal +deriving instance Typeable 'SwaggerKindParamOtherSchema +deriving instance Typeable 'SwaggerKindSchema +#endif + +type family SwaggerKindType (k :: SwaggerKind *) :: * +type instance SwaggerKindType (SwaggerKindNormal t) = t +type instance SwaggerKindType SwaggerKindSchema = Schema +type instance SwaggerKindType SwaggerKindParamOtherSchema = ParamOtherSchema data SwaggerType t where SwaggerString :: SwaggerType t @@ -387,9 +441,9 @@ data SwaggerType t where SwaggerInteger :: SwaggerType t SwaggerBoolean :: SwaggerType t SwaggerArray :: SwaggerType t - SwaggerFile :: SwaggerType ParamOtherSchema - SwaggerNull :: SwaggerType Schema - SwaggerObject :: SwaggerType Schema + SwaggerFile :: SwaggerType SwaggerKindParamOtherSchema + SwaggerNull :: SwaggerType SwaggerKindSchema + SwaggerObject :: SwaggerType SwaggerKindSchema deriving (Typeable) deriving instance Eq (SwaggerType t) @@ -401,30 +455,30 @@ swaggerTypeConstr t = mkConstr (dataTypeOf t) (show t) [] Prefix swaggerTypeDataType :: Data (SwaggerType t) => SwaggerType t -> DataType swaggerTypeDataType _ = mkDataType "Data.Swagger.SwaggerType" swaggerTypeConstrs -swaggerCommonTypes :: [SwaggerType t] +swaggerCommonTypes :: [SwaggerType k] swaggerCommonTypes = [SwaggerString, SwaggerNumber, SwaggerInteger, SwaggerBoolean, SwaggerArray] -swaggerParamTypes :: [SwaggerType ParamOtherSchema] +swaggerParamTypes :: [SwaggerType SwaggerKindParamOtherSchema] swaggerParamTypes = swaggerCommonTypes ++ [SwaggerFile] -swaggerSchemaTypes :: [SwaggerType Schema] +swaggerSchemaTypes :: [SwaggerType SwaggerKindSchema] swaggerSchemaTypes = swaggerCommonTypes ++ [error "SwaggerFile is invalid SwaggerType Schema", SwaggerNull, SwaggerObject] swaggerTypeConstrs :: [Constr] -swaggerTypeConstrs = map swaggerTypeConstr (swaggerCommonTypes :: [SwaggerType Schema]) +swaggerTypeConstrs = map swaggerTypeConstr (swaggerCommonTypes :: [SwaggerType SwaggerKindSchema]) ++ [swaggerTypeConstr SwaggerFile, swaggerTypeConstr SwaggerNull, swaggerTypeConstr SwaggerObject] -instance OVERLAPPABLE_ Typeable t => Data (SwaggerType t) where +instance Typeable t => Data (SwaggerType (SwaggerKindNormal t)) where gunfold = gunfoldEnum "SwaggerType" swaggerCommonTypes toConstr = swaggerTypeConstr dataTypeOf = swaggerTypeDataType -instance OVERLAPPABLE_ Data (SwaggerType ParamOtherSchema) where +instance Data (SwaggerType SwaggerKindParamOtherSchema) where gunfold = gunfoldEnum "SwaggerType ParamOtherSchema" swaggerParamTypes toConstr = swaggerTypeConstr dataTypeOf = swaggerTypeDataType -instance OVERLAPPABLE_ Data (SwaggerType Schema) where +instance Data (SwaggerType SwaggerKindSchema) where gunfold = gunfoldEnum "SwaggerType Schema" swaggerSchemaTypes toConstr = swaggerTypeConstr dataTypeOf = swaggerTypeDataType @@ -464,7 +518,7 @@ data CollectionFormat t where -- Corresponds to multiple parameter instances -- instead of multiple values for a single instance @foo=bar&foo=baz@. -- This is valid only for parameters in @'ParamQuery'@ or @'ParamFormData'@. - CollectionMulti :: CollectionFormat ParamOtherSchema + CollectionMulti :: CollectionFormat SwaggerKindParamOtherSchema deriving (Typeable) deriving instance Eq (CollectionFormat t) @@ -480,12 +534,12 @@ collectionFormatDataType = mkDataType "Data.Swagger.CollectionFormat" $ collectionCommonFormats :: [CollectionFormat t] collectionCommonFormats = [ CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes ] -instance OVERLAPPABLE_ Data t => Data (CollectionFormat t) where +instance Data t => Data (CollectionFormat (SwaggerKindNormal t)) where gunfold = gunfoldEnum "CollectionFormat" collectionCommonFormats toConstr = collectionFormatConstr dataTypeOf _ = collectionFormatDataType -deriving instance OVERLAPPABLE_ Data (CollectionFormat ParamOtherSchema) +deriving instance Data (CollectionFormat SwaggerKindParamOtherSchema) type ParamName = Text @@ -507,7 +561,7 @@ data Schema = Schema , _schemaMaxProperties :: Maybe Integer , _schemaMinProperties :: Maybe Integer - , _schemaParamSchema :: ParamSchema Schema + , _schemaParamSchema :: ParamSchema SwaggerKindSchema } deriving (Eq, Show, Generic, Data, Typeable) -- | A @'Schema'@ with an optional name. @@ -520,7 +574,7 @@ data NamedSchema = NamedSchema -- | Regex pattern for @string@ type. type Pattern = Text -data ParamSchema t = ParamSchema +data ParamSchema (t :: SwaggerKind *) = ParamSchema { -- | Declares the value of the parameter that the server will use if none is provided, -- for example a @"count"@ to control the number of results per page might default to @100@ -- if not supplied by the client in the request. @@ -545,7 +599,7 @@ data ParamSchema t = ParamSchema , _paramSchemaMultipleOf :: Maybe Scientific } deriving (Eq, Show, Generic, Typeable) -deriving instance (Data t, Data (SwaggerType t), Data (SwaggerItems t)) => Data (ParamSchema t) +deriving instance (Typeable k, Data (SwaggerKindType k), Data (SwaggerType k), Data (SwaggerItems k)) => Data (ParamSchema k) data Xml = Xml { -- | Replaces the name of the element/attribute used for the described schema property. @@ -621,7 +675,7 @@ data Header = Header { -- | A short description of the header. _headerDescription :: Maybe Text - , _headerParamSchema :: ParamSchema Header + , _headerParamSchema :: ParamSchema (SwaggerKindNormal Header) } deriving (Eq, Show, Generic, Data, Typeable) data Example = Example { getExample :: Map MediaType Value } @@ -827,10 +881,6 @@ instance SwaggerMonoid ParamLocation where swaggerMempty = ParamQuery swaggerMappend _ y = y -instance OVERLAPPING_ SwaggerMonoid (HashMap FilePath PathItem) where - swaggerMempty = HashMap.empty - swaggerMappend = HashMap.unionWith mappend - instance OVERLAPPING_ SwaggerMonoid (InsOrdHashMap FilePath PathItem) where swaggerMempty = InsOrdHashMap.empty swaggerMappend = InsOrdHashMap.unionWith mappend @@ -931,8 +981,7 @@ instance ToJSON OAuth2Flow where , "tokenUrl" .= tokenUrl ] instance ToJSON OAuth2Params where - toJSON = sopSwaggerGenericToJSON $ mkSwaggerAesonOptions "oauth2" & - saoSubObject ?~ "flow" + toJSON = sopSwaggerGenericToJSON instance ToJSON SecuritySchemeType where toJSON SecuritySchemeBasic @@ -945,22 +994,18 @@ instance ToJSON SecuritySchemeType where <+> object [ "type" .= ("oauth2" :: Text) ] instance ToJSON Swagger where - toJSON = sopSwaggerGenericToJSON $ mkSwaggerAesonOptions "swagger" & - saoAdditionalPairs .~ [("swagger", "2.0")] + toJSON = sopSwaggerGenericToJSON instance ToJSON SecurityScheme where - toJSON = sopSwaggerGenericToJSON $ mkSwaggerAesonOptions "securityScheme" & - saoSubObject ?~ "type" + toJSON = sopSwaggerGenericToJSON instance ToJSON Schema where - toJSON = sopSwaggerGenericToJSON $ mkSwaggerAesonOptions "schema" & - saoSubObject ?~ "paramSchema" + toJSON = sopSwaggerGenericToJSON instance ToJSON Header where - toJSON = sopSwaggerGenericToJSON $ mkSwaggerAesonOptions "header" & - saoSubObject ?~ "paramSchema" + toJSON = sopSwaggerGenericToJSON -instance ToJSON (SwaggerItems t) where +instance ToJSON (ParamSchema t) => ToJSON (SwaggerItems t) where toJSON (SwaggerItemsPrimitive fmt schema) = object [ "collectionFormat" .= fmt , "items" .= schema ] @@ -977,29 +1022,26 @@ instance ToJSON MimeList where toJSON (MimeList xs) = toJSON (map show xs) instance ToJSON Param where - toJSON = sopSwaggerGenericToJSON $ mkSwaggerAesonOptions "param" & - saoSubObject ?~ "schema" + toJSON = sopSwaggerGenericToJSON instance ToJSON ParamAnySchema where toJSON (ParamBody s) = object [ "in" .= ("body" :: Text), "schema" .= s ] toJSON (ParamOther s) = toJSON s instance ToJSON ParamOtherSchema where - toJSON = sopSwaggerGenericToJSON $ mkSwaggerAesonOptions "paramOtherSchema" & - saoSubObject ?~ "paramSchema" + toJSON = sopSwaggerGenericToJSON instance ToJSON Responses where - toJSON = sopSwaggerGenericToJSON $ mkSwaggerAesonOptions "responses" & - saoSubObject ?~ "responses" + toJSON = sopSwaggerGenericToJSON instance ToJSON Response where - toJSON = sopSwaggerGenericToJSON $ mkSwaggerAesonOptions "response" + toJSON = sopSwaggerGenericToJSON instance ToJSON Operation where - toJSON = sopSwaggerGenericToJSON $ mkSwaggerAesonOptions "operation" + toJSON = sopSwaggerGenericToJSON instance ToJSON PathItem where - toJSON = sopSwaggerGenericToJSON $ mkSwaggerAesonOptions "pathItem" + toJSON = sopSwaggerGenericToJSON instance ToJSON Example where toJSON = toJSON . Map.mapKeys show . getExample @@ -1032,9 +1074,10 @@ instance ToJSON (CollectionFormat t) where toJSON CollectionPipes = "pipes" toJSON CollectionMulti = "multi" -instance ToJSON (ParamSchema t) where - toJSON = sopSwaggerGenericToJSON $ mkSwaggerAesonOptions "paramSchema" & - saoSubObject ?~ "items" +instance ToJSON (ParamSchema k) where + -- TODO: this is a bit fishy, why we need sub object only in `ToJSON`? + toJSON = sopSwaggerGenericToJSONWithOpts $ + mkSwaggerAesonOptions "paramSchema" & saoSubObject ?~ "items" -- ======================================================================= -- Manual FromJSON instances @@ -1054,7 +1097,7 @@ instance FromJSON OAuth2Flow where parseJSON _ = empty instance FromJSON OAuth2Params where - parseJSON = genericParseJSONWithSub "flow" (jsonPrefix "oauth2") + parseJSON = sopSwaggerGenericParseJSON instance FromJSON SecuritySchemeType where parseJSON js@(Object o) = do @@ -1067,38 +1110,28 @@ instance FromJSON SecuritySchemeType where parseJSON _ = empty instance FromJSON Swagger where - parseJSON js@(Object o) = do - (version :: Text) <- o .: "swagger" - when (version /= "2.0") empty - (genericParseJSON (jsonPrefix "swagger") - `withDefaults` [ "consumes" .= (mempty :: MimeList) - , "produces" .= (mempty :: MimeList) - , "security" .= ([] :: [SecurityRequirement]) - , "tags" .= ([] :: [Tag]) - , "definitions" .= (mempty :: Definitions Schema) - , "parameters" .= (mempty :: Definitions Param) - , "responses" .= (mempty :: Definitions Response) - , "securityDefinitions" .= (mempty :: Definitions SecurityScheme) - ] ) js - parseJSON _ = empty + parseJSON = sopSwaggerGenericParseJSON instance FromJSON SecurityScheme where - parseJSON = genericParseJSONWithSub "type" (jsonPrefix "securityScheme") + parseJSON = sopSwaggerGenericParseJSON instance FromJSON Schema where - parseJSON = genericParseJSONWithSub "paramSchema" (jsonPrefix "schema") - `withDefaults` [ "properties" .= (mempty :: InsOrdHashMap Text Schema) - , "required" .= ([] :: [ParamName]) ] + parseJSON = sopSwaggerGenericParseJSON instance FromJSON Header where - parseJSON = genericParseJSONWithSub "paramSchema" (jsonPrefix "header") + parseJSON = sopSwaggerGenericParseJSON -instance OVERLAPPABLE_ (FromJSON (CollectionFormat t), FromJSON (ParamSchema t)) => FromJSON (SwaggerItems t) where +instance (FromJSON (CollectionFormat (SwaggerKindNormal t)), FromJSON (ParamSchema (SwaggerKindNormal t))) => FromJSON (SwaggerItems (SwaggerKindNormal t)) where parseJSON = withObject "SwaggerItemsPrimitive" $ \o -> SwaggerItemsPrimitive <$> o .:? "collectionFormat" <*> (o .: "items" >>= parseJSON) -instance OVERLAPPABLE_ FromJSON (SwaggerItems Schema) where +instance FromJSON (SwaggerItems SwaggerKindParamOtherSchema) where + parseJSON = withObject "SwaggerItemsPrimitive" $ \o -> SwaggerItemsPrimitive + <$> o .:? "collectionFormat" + <*> ((o .: "items" >>= parseJSON) <|> fail ("foo" ++ show o)) + +instance FromJSON (SwaggerItems SwaggerKindSchema) where parseJSON js@(Object _) = SwaggerItemsObject <$> parseJSON js parseJSON js@(Array _) = SwaggerItemsArray <$> parseJSON js parseJSON _ = empty @@ -1116,7 +1149,7 @@ instance FromJSON MimeList where parseJSON js = (MimeList . map fromString) <$> parseJSON js instance FromJSON Param where - parseJSON = genericParseJSONWithSub "schema" (jsonPrefix "param") + parseJSON = sopSwaggerGenericParseJSON instance FromJSON ParamAnySchema where parseJSON js@(Object o) = do @@ -1129,7 +1162,7 @@ instance FromJSON ParamAnySchema where parseJSON _ = empty instance FromJSON ParamOtherSchema where - parseJSON = genericParseJSONWithSub "paramSchema" (jsonPrefix "paramOtherSchema") + parseJSON = sopSwaggerGenericParseJSON instance FromJSON Responses where parseJSON (Object o) = Responses @@ -1143,18 +1176,13 @@ instance FromJSON Example where pure $ Example (Map.mapKeys fromString m) instance FromJSON Response where - parseJSON = genericParseJSON (jsonPrefix "response") - `withDefaults` [ "headers" .= (mempty :: InsOrdHashMap HeaderName Header) ] + parseJSON = sopSwaggerGenericParseJSON instance FromJSON Operation where - parseJSON = genericParseJSON (jsonPrefix "operation") - `withDefaults` [ "security" .= ([] :: [SecurityRequirement]) - , "tags" .= ([] :: [Tag]) - , "parameters" .= ([] :: [Referenced Param]) ] + parseJSON = sopSwaggerGenericParseJSON instance FromJSON PathItem where - parseJSON = genericParseJSON (jsonPrefix "pathItem") - `withDefaults` [ "parameters" .= ([] :: [Param]) ] + parseJSON = sopSwaggerGenericParseJSON instance FromJSON Reference where parseJSON (Object o) = Reference <$> o .: "$ref" @@ -1180,28 +1208,31 @@ instance FromJSON (Referenced Response) where parseJSON = referencedParseJSON "# instance FromJSON Xml where parseJSON = genericParseJSON (jsonPrefix "xml") -instance FromJSON (SwaggerType Schema) where +instance FromJSON (SwaggerType SwaggerKindSchema) where parseJSON = parseOneOf [SwaggerString, SwaggerInteger, SwaggerNumber, SwaggerBoolean, SwaggerArray, SwaggerNull, SwaggerObject] -instance FromJSON (SwaggerType ParamOtherSchema) where +instance FromJSON (SwaggerType SwaggerKindParamOtherSchema) where parseJSON = parseOneOf [SwaggerString, SwaggerInteger, SwaggerNumber, SwaggerBoolean, SwaggerArray, SwaggerFile] -instance OVERLAPPABLE_ FromJSON (SwaggerType t) where +instance FromJSON (SwaggerType (SwaggerKindNormal t)) where parseJSON = parseOneOf [SwaggerString, SwaggerInteger, SwaggerNumber, SwaggerBoolean, SwaggerArray] -instance OVERLAPPABLE_ FromJSON (CollectionFormat t) where +instance FromJSON (CollectionFormat (SwaggerKindNormal t)) where parseJSON = parseOneOf [CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes] -instance FromJSON (CollectionFormat ParamOtherSchema) where +-- NOTE: There aren't collections of 'Schema' +--instance FromJSON (CollectionFormat (SwaggerKindSchema)) where +-- parseJSON = parseOneOf [CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes] + +instance FromJSON (CollectionFormat SwaggerKindParamOtherSchema) where parseJSON = parseOneOf [CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes, CollectionMulti] --- NOTE: The constraints @FromJSON (SwaggerType t)@ and --- @FromJSON (SwaggerItems t)@ are necessary here! --- Without the constraint the general instance will be used --- that only accepts common types (i.e. NOT object, null or file) --- and primitive array items. -instance (FromJSON (SwaggerType t), FromJSON (SwaggerItems t)) => FromJSON (ParamSchema t) where - parseJSON = genericParseJSONWithSub "items" (jsonPrefix "ParamSchema") +instance (FromJSON (SwaggerType (SwaggerKindNormal t)), FromJSON (SwaggerItems (SwaggerKindNormal t))) => FromJSON (ParamSchema (SwaggerKindNormal t)) where + parseJSON = sopSwaggerGenericParseJSON +instance FromJSON (ParamSchema SwaggerKindParamOtherSchema) where + parseJSON = sopSwaggerGenericParseJSON +instance FromJSON (ParamSchema SwaggerKindSchema) where + parseJSON = sopSwaggerGenericParseJSON ------------------------------------------------------------------------------- -- TH splices @@ -1219,3 +1250,44 @@ deriveGeneric ''SecurityScheme deriveGeneric ''Schema deriveGeneric ''ParamSchema deriveGeneric ''Swagger + +instance HasSwaggerAesonOptions Header where + swaggerAesonOptions _ = mkSwaggerAesonOptions "header" & saoSubObject ?~ "paramSchema" +instance HasSwaggerAesonOptions OAuth2Params where + swaggerAesonOptions _ = mkSwaggerAesonOptions "oauth2" & saoSubObject ?~ "flow" +instance HasSwaggerAesonOptions Operation where + swaggerAesonOptions _ = mkSwaggerAesonOptions "operation" +instance HasSwaggerAesonOptions Param where + swaggerAesonOptions _ = mkSwaggerAesonOptions "param" & saoSubObject ?~ "schema" +instance HasSwaggerAesonOptions ParamOtherSchema where + swaggerAesonOptions _ = mkSwaggerAesonOptions "paramOtherSchema" & saoSubObject ?~ "paramSchema" +instance HasSwaggerAesonOptions PathItem where + swaggerAesonOptions _ = mkSwaggerAesonOptions "pathItem" +instance HasSwaggerAesonOptions Response where + swaggerAesonOptions _ = mkSwaggerAesonOptions "response" +instance HasSwaggerAesonOptions Responses where + swaggerAesonOptions _ = mkSwaggerAesonOptions "responses" & saoSubObject ?~ "responses" +instance HasSwaggerAesonOptions SecurityScheme where + swaggerAesonOptions _ = mkSwaggerAesonOptions "securityScheme" & saoSubObject ?~ "type" +instance HasSwaggerAesonOptions Schema where + swaggerAesonOptions _ = mkSwaggerAesonOptions "schema" & saoSubObject ?~ "paramSchema" +instance HasSwaggerAesonOptions Swagger where + swaggerAesonOptions _ = mkSwaggerAesonOptions "swagger" & saoAdditionalPairs .~ [("swagger", "2.0")] + +instance HasSwaggerAesonOptions (ParamSchema (SwaggerKindNormal t)) where + swaggerAesonOptions _ = mkSwaggerAesonOptions "paramSchema" & saoSubObject ?~ "items" +instance HasSwaggerAesonOptions (ParamSchema SwaggerKindParamOtherSchema) where + swaggerAesonOptions _ = mkSwaggerAesonOptions "paramSchema" & saoSubObject ?~ "items" +-- NOTE: Schema doesn't have 'items' sub object! +instance HasSwaggerAesonOptions (ParamSchema SwaggerKindSchema) where + swaggerAesonOptions _ = mkSwaggerAesonOptions "paramSchema" + +instance AesonDefaultValue (ParamSchema s) +instance AesonDefaultValue OAuth2Flow +instance AesonDefaultValue Responses +instance AesonDefaultValue ParamAnySchema +instance AesonDefaultValue SecuritySchemeType +instance AesonDefaultValue (SwaggerType a) +instance AesonDefaultValue MimeList where defaultValue = Just mempty +instance AesonDefaultValue Info +instance AesonDefaultValue ParamLocation diff --git a/src/Data/Swagger/Internal/AesonUtils.hs b/src/Data/Swagger/Internal/AesonUtils.hs index 00a9634..a84ba82 100644 --- a/src/Data/Swagger/Internal/AesonUtils.hs +++ b/src/Data/Swagger/Internal/AesonUtils.hs @@ -6,8 +6,12 @@ {-# LANGUAGE TemplateHaskell #-} module Data.Swagger.Internal.AesonUtils ( -- * Generic functions + AesonDefaultValue(..), sopSwaggerGenericToJSON, + sopSwaggerGenericToJSONWithOpts, + sopSwaggerGenericParseJSON, -- * Options + HasSwaggerAesonOptions(..), SwaggerAesonOptions, mkSwaggerAesonOptions, saoPrefix, @@ -18,15 +22,20 @@ module Data.Swagger.Internal.AesonUtils ( import Prelude () import Prelude.Compat -import Control.Lens (makeLenses, (^.)) -import Data.Aeson (ToJSON(..), Value(..), object) -import Data.Text (Text) -import Data.Char (toLower, isUpper) +import Control.Applicative ((<|>)) +import Control.Lens (makeLenses, (^.)) +import Control.Monad (unless) +import Data.Aeson (ToJSON(..), FromJSON(..), Value(..), Object, object, (.:), (.:?), (.!=), withObject) +import Data.Aeson.Types (Parser) +import Data.Char (toLower, isUpper) +import Data.Text (Text) import Generics.SOP import qualified Data.Text as T import qualified Data.HashMap.Strict as HM +import qualified Data.Set as Set +import qualified Data.HashMap.Strict.InsOrd as InsOrd ------------------------------------------------------------------------------- -- SwaggerAesonOptions @@ -45,10 +54,31 @@ mkSwaggerAesonOptions pfx = SwaggerAesonOptions pfx [] Nothing makeLenses ''SwaggerAesonOptions +class (Generic a, All2 AesonDefaultValue (Code a)) => HasSwaggerAesonOptions a where + swaggerAesonOptions :: proxy a -> SwaggerAesonOptions + + -- So far we use only default definitions + aesonDefaults :: proxy a -> POP Maybe (Code a) + aesonDefaults _ = hcpure (Proxy :: Proxy AesonDefaultValue) defaultValue + ------------------------------------------------------------------------------- -- Generics ------------------------------------------------------------------------------- +class AesonDefaultValue a where + defaultValue :: Maybe a + defaultValue = Nothing + +instance AesonDefaultValue Text where defaultValue = Nothing +instance AesonDefaultValue (Maybe a) where defaultValue = Just Nothing +instance AesonDefaultValue [a] where defaultValue = Just [] +instance AesonDefaultValue (Set.Set a) where defaultValue = Just Set.empty +instance AesonDefaultValue (InsOrd.InsOrdHashMap k v) where defaultValue = Just InsOrd.empty + +------------------------------------------------------------------------------- +-- ToJSON +------------------------------------------------------------------------------- + -- | Generic serialisation for swagger records. -- -- Features @@ -57,36 +87,154 @@ makeLenses ''SwaggerAesonOptions -- * possible to add fields -- * possible to merge sub-object sopSwaggerGenericToJSON - :: forall a xs. (Generic a, HasDatatypeInfo a, All2 ToJSON (Code a), Code a ~ '[xs]) + :: forall a xs. + ( Generic a + , HasDatatypeInfo a + , HasSwaggerAesonOptions a + , All2 ToJSON (Code a) + , All2 Eq (Code a) + , Code a ~ '[xs] + ) + => a + -> Value +sopSwaggerGenericToJSON x = + let ps = sopSwaggerGenericToJSON' opts (from x) (datatypeInfo proxy) (aesonDefaults proxy) + in object (opts ^. saoAdditionalPairs ++ ps) + where + proxy = Proxy :: Proxy a + opts = swaggerAesonOptions proxy + +-- | *TODO:* This is only used by ToJSON (ParamSchema SwaggerKindSchema) +-- +-- Also uses default `aesonDefaults` +sopSwaggerGenericToJSONWithOpts + :: forall a xs. + ( Generic a + , All2 AesonDefaultValue (Code a) + , HasDatatypeInfo a + , All2 ToJSON (Code a) + , All2 Eq (Code a) + , Code a ~ '[xs] + ) => SwaggerAesonOptions -> a -> Value -sopSwaggerGenericToJSON opts x = - let ps = sopSwaggerGenericToJSON' opts (from x) (datatypeInfo (Proxy :: Proxy a)) +sopSwaggerGenericToJSONWithOpts opts x = + let ps = sopSwaggerGenericToJSON' opts (from x) (datatypeInfo proxy) defs in object (opts ^. saoAdditionalPairs ++ ps) + where + proxy = Proxy :: Proxy a + defs = hcpure (Proxy :: Proxy AesonDefaultValue) defaultValue -sopSwaggerGenericToJSON' :: All2 ToJSON '[xs] => SwaggerAesonOptions -> SOP I '[xs] -> DatatypeInfo '[xs] -> [(Text, Value)] -sopSwaggerGenericToJSON' opts (SOP (Z fields)) (ADT _ _ (Record _ fieldsInfo :* Nil)) = - sopSwaggerGenericToJSON'' opts fields fieldsInfo +sopSwaggerGenericToJSON' + :: (All2 ToJSON '[xs], All2 Eq '[xs]) + => SwaggerAesonOptions + -> SOP I '[xs] + -> DatatypeInfo '[xs] + -> POP Maybe '[xs] + -> [(Text, Value)] +sopSwaggerGenericToJSON' opts (SOP (Z fields)) (ADT _ _ (Record _ fieldsInfo :* Nil)) (POP (defs :* Nil)) = + sopSwaggerGenericToJSON'' opts fields fieldsInfo defs -sopSwaggerGenericToJSON'' :: All ToJSON xs => SwaggerAesonOptions -> NP I xs -> NP FieldInfo xs -> [(Text, Value)] +sopSwaggerGenericToJSON'' + :: (All ToJSON xs, All Eq xs) + => SwaggerAesonOptions + -> NP I xs + -> NP FieldInfo xs + -> NP Maybe xs + -> [(Text, Value)] sopSwaggerGenericToJSON'' (SwaggerAesonOptions prefix _ sub) = go where - go :: All ToJSON ys => NP I ys -> NP FieldInfo ys -> [(Text, Value)] - go Nil Nil = [] - go (I x :* xs) (FieldInfo name :* names) + go :: (All ToJSON ys, All Eq ys) => NP I ys -> NP FieldInfo ys -> NP Maybe ys -> [(Text, Value)] + go Nil Nil Nil = [] + go (I x :* xs) (FieldInfo name :* names) (def :* defs) | Just name' == sub = case json of Object m -> HM.toList m ++ rest Null -> rest _ -> error $ "sopSwaggerGenericToJSON: subjson is not an object: " ++ show json - | json == Null || json == Array mempty || json == Object mempty = + -- If default value: omit it. + | Just x == def = rest | otherwise = (T.pack name', json) : rest where json = toJSON x name' = fieldNameModifier name - rest = go xs names + rest = go xs names defs + + fieldNameModifier = modifier . drop 1 + modifier = lowerFirstUppers . drop (length prefix) + lowerFirstUppers s = map toLower x ++ y + where (x, y) = span isUpper s + +------------------------------------------------------------------------------- +-- FromJSON +------------------------------------------------------------------------------- + +sopSwaggerGenericParseJSON + :: forall a xs. + ( Generic a + , HasDatatypeInfo a + , HasSwaggerAesonOptions a + , All2 FromJSON (Code a) + , All2 Eq (Code a) + , Code a ~ '[xs] + ) + => Value + -> Parser a +sopSwaggerGenericParseJSON = withObject "Swagger Record Object" $ \obj -> + let ps = sopSwaggerGenericParseJSON' opts obj (datatypeInfo proxy) (aesonDefaults proxy) + in do + traverse (parseAdditionalField obj) (opts ^. saoAdditionalPairs) + to <$> ps + where + proxy = Proxy :: Proxy a + opts = swaggerAesonOptions proxy + + parseAdditionalField :: Object -> (Text, Value) -> Parser () + parseAdditionalField obj (k, v) = do + v' <- obj .: k + unless (v == v') $ fail $ + "Additonal field don't match for key " ++ T.unpack k + ++ ": " ++ show v + ++ " /= " ++ show v' + +sopSwaggerGenericParseJSON' + :: (All2 FromJSON '[xs], All2 Eq '[xs]) + => SwaggerAesonOptions + -> Object + -> DatatypeInfo '[xs] + -> POP Maybe '[xs] + -> Parser (SOP I '[xs]) +sopSwaggerGenericParseJSON' opts obj (ADT _ _ (Record _ fieldsInfo :* Nil)) (POP (defs :* Nil)) = + SOP . Z <$> sopSwaggerGenericParseJSON'' opts obj fieldsInfo defs + +sopSwaggerGenericParseJSON'' + :: (All FromJSON xs, All Eq xs) + => SwaggerAesonOptions + -> Object + -> NP FieldInfo xs + -> NP Maybe xs + -> Parser (NP I xs) +sopSwaggerGenericParseJSON'' (SwaggerAesonOptions prefix _ sub) obj = go + where + go :: (All FromJSON ys, All Eq ys) => NP FieldInfo ys -> NP Maybe ys -> Parser (NP I ys) + go Nil Nil = pure Nil + go (FieldInfo name :* names) (def :* defs) + | Just name' == sub = + -- Note: we might strip fields of outer structure. + cons <$> (withDef $ parseJSON $ Object obj) <*> rest + | otherwise = case def of + Just def' -> cons <$> obj .:? T.pack name' .!= def' <*> rest + Nothing -> cons <$> obj .: T.pack name' <*> rest + where + cons h t = I h :* t + name' = fieldNameModifier name + rest = go names defs + + withDef = case def of + Just def' -> (<|> pure def') + Nothing -> id fieldNameModifier = modifier . drop 1 modifier = lowerFirstUppers . drop (length prefix) diff --git a/src/Data/Swagger/Internal/Schema.hs b/src/Data/Swagger/Internal/Schema.hs index e3a4c08..e211d8f 100644 --- a/src/Data/Swagger/Internal/Schema.hs +++ b/src/Data/Swagger/Internal/Schema.hs @@ -3,6 +3,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE KindSignatures #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PackageImports #-} @@ -615,7 +616,7 @@ gdeclareSchemaRef opts proxy = do return $ Ref (Reference name) _ -> Inline <$> gdeclareSchema opts proxy -appendItem :: Referenced Schema -> Maybe (SwaggerItems Schema) -> Maybe (SwaggerItems Schema) +appendItem :: Referenced Schema -> Maybe (SwaggerItems SwaggerKindSchema) -> Maybe (SwaggerItems SwaggerKindSchema) appendItem x Nothing = Just (SwaggerItemsArray [x]) appendItem x (Just (SwaggerItemsArray xs)) = Just (SwaggerItemsArray (xs ++ [x])) appendItem _ _ = error "GToSchema.appendItem: cannot append to SwaggerItemsObject" diff --git a/src/Data/Swagger/Internal/Utils.hs b/src/Data/Swagger/Internal/Utils.hs index 2ac7504..a41f488 100644 --- a/src/Data/Swagger/Internal/Utils.hs +++ b/src/Data/Swagger/Internal/Utils.hs @@ -55,17 +55,6 @@ gunfoldEnum tname xs _k z c = case lookup (constrIndex c) (zip [1..] xs) of Just x -> z x Nothing -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type " ++ tname ++ "." -hashMapMapKeys :: (Eq k', Hashable k') => (k -> k') -> HashMap k v -> HashMap k' v -hashMapMapKeys f = HashMap.fromList . map (first f) . HashMap.toList - -hashMapTraverseKeys :: (Eq k', Hashable k', Applicative f) => (k -> f k') -> HashMap k v -> f (HashMap k' v) -hashMapTraverseKeys f = fmap HashMap.fromList . traverse g . HashMap.toList - where - g (x, y) = (\a -> (a, y)) <$> f x - -hashMapReadKeys :: (Eq k, Read k, Hashable k, Alternative f) => HashMap String v -> f (HashMap k v) -hashMapReadKeys = hashMapTraverseKeys (maybe empty pure . readMaybe) - jsonPrefix :: String -> Options jsonPrefix prefix = defaultOptions { fieldLabelModifier = modifier . drop 1 @@ -87,29 +76,10 @@ parseOneOf xs js = where ys = zip (map toJSON xs) xs -{-# DEPRECATED omitEmpties "will be removed" #-} -omitEmpties :: Value -> Value -omitEmpties (Object o) = Object (HashMap.filter nonEmpty o) - where - nonEmpty js = (js /= Object mempty) && (js /= Array mempty) && (js /= Null) -omitEmpties js = js - -genericParseJSONWithSub :: (Generic a, GFromJSON (Rep a)) => Text -> Options -> Value -> Parser a -genericParseJSONWithSub sub opts js@(Object o) - = genericParseJSON opts js -- try without subjson - <|> genericParseJSON opts js' -- try with subjson - where - js' = Object (HashMap.insert sub (Object o) o) -genericParseJSONWithSub _ _ _ = fail "genericParseJSONWithSub: given json is not an object" - (<+>) :: Value -> Value -> Value Object x <+> Object y = Object (x <> y) _ <+> _ = error "<+>: merging non-objects" -withDefaults :: (Value -> Parser a) -> [Pair] -> Value -> Parser a -withDefaults parser defs js@(Object _) = parser (js <+> object defs) -withDefaults _ _ _ = empty - genericMempty :: (Generic a, GMonoid (Rep a)) => a genericMempty = to gmempty @@ -165,4 +135,3 @@ instance SwaggerMonoid (Maybe a) where swaggerMempty = Nothing swaggerMappend x Nothing = x swaggerMappend _ y = y - diff --git a/src/Data/Swagger/Lens.hs b/src/Data/Swagger/Lens.hs index 2a6cb15..f6991a5 100644 --- a/src/Data/Swagger/Lens.hs +++ b/src/Data/Swagger/Lens.hs @@ -7,6 +7,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} #include "overlapping-compat.h" @@ -59,14 +60,14 @@ makePrisms ''Referenced -- ** 'SwaggerItems' prisms -_SwaggerItemsArray :: forall t. (t ~ Schema) => Review (SwaggerItems t) [Referenced Schema] +_SwaggerItemsArray :: Review (SwaggerItems SwaggerKindSchema) [Referenced Schema] _SwaggerItemsArray = prism (\x -> SwaggerItemsArray x) $ \x -> case x of SwaggerItemsPrimitive c p -> Left (SwaggerItemsPrimitive c p) SwaggerItemsObject o -> Left (SwaggerItemsObject o) SwaggerItemsArray a -> Right a -_SwaggerItemsObject :: forall t. (t ~ Schema) => Review (SwaggerItems t) (Referenced Schema) +_SwaggerItemsObject :: Review (SwaggerItems SwaggerKindSchema) (Referenced Schema) _SwaggerItemsObject = prism (\x -> SwaggerItemsObject x) $ \x -> case x of SwaggerItemsPrimitive c p -> Left (SwaggerItemsPrimitive c p) @@ -91,13 +92,13 @@ instance At Responses where at n = responses . at n instance Ixed Operation where ix n = responses . ix n instance At Operation where at n = responses . at n -instance HasParamSchema NamedSchema (ParamSchema Schema) where paramSchema = schema.paramSchema +instance HasParamSchema NamedSchema (ParamSchema SwaggerKindSchema) where paramSchema = schema.paramSchema -- HasType instances -instance HasType Header (SwaggerType Header) where type_ = paramSchema.type_ -instance HasType Schema (SwaggerType Schema) where type_ = paramSchema.type_ -instance HasType NamedSchema (SwaggerType Schema) where type_ = paramSchema.type_ -instance HasType ParamOtherSchema (SwaggerType ParamOtherSchema) where type_ = paramSchema.type_ +instance HasType Header (SwaggerType (SwaggerKindNormal Header)) where type_ = paramSchema.type_ +instance HasType Schema (SwaggerType SwaggerKindSchema) where type_ = paramSchema.type_ +instance HasType NamedSchema (SwaggerType SwaggerKindSchema) where type_ = paramSchema.type_ +instance HasType ParamOtherSchema (SwaggerType SwaggerKindParamOtherSchema) where type_ = paramSchema.type_ -- HasDefault instances instance HasDefault Header (Maybe Value) where default_ = paramSchema.default_ diff --git a/swagger2.cabal b/swagger2.cabal index 3102ef6..f1c9571 100644 --- a/swagger2.cabal +++ b/swagger2.cabal @@ -45,7 +45,6 @@ library , containers , hashable , generics-sop >=0.2 && <0.3 - , generics-sop-lens >=0.1.0.0 && <0.2 , http-media , insert-ordered-containers >=0.1.0.0 && <0.2 , lens diff --git a/test/Data/Swagger/ParamSchemaSpec.hs b/test/Data/Swagger/ParamSchemaSpec.hs index 394cff1..d63e59f 100644 --- a/test/Data/Swagger/ParamSchemaSpec.hs +++ b/test/Data/Swagger/ParamSchemaSpec.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE QuasiQuotes #-} @@ -11,12 +12,13 @@ import Data.Proxy import GHC.Generics import Data.Swagger +import Data.Swagger.Internal (SwaggerKind(..)) import SpecCommon import Test.Hspec checkToParamSchema :: ToParamSchema a => Proxy a -> Value -> Spec -checkToParamSchema proxy js = (toParamSchema proxy :: ParamSchema Param) <=> js +checkToParamSchema proxy js = (toParamSchema proxy :: ParamSchema (SwaggerKindNormal Param)) <=> js spec :: Spec spec = do From 15541f1bb294e3cf05ab25b1238773a34ae2dfe6 Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Tue, 8 Mar 2016 19:55:31 +0200 Subject: [PATCH 7/9] toEncoding via sopSwaggerGenericToEncoding --- src/Data/Swagger.hs | 6 +- src/Data/Swagger/Internal.hs | 18 +++++ src/Data/Swagger/Internal/AesonUtils.hs | 87 +++++++++++++++++++++++-- src/Data/Swagger/Internal/Schema.hs | 4 +- src/Data/Swagger/Operation.hs | 8 +-- swagger2.cabal | 4 +- test/SpecCommon.hs | 9 ++- 7 files changed, 120 insertions(+), 16 deletions(-) diff --git a/src/Data/Swagger.hs b/src/Data/Swagger.hs index 0f204d2..7a82783 100644 --- a/src/Data/Swagger.hs +++ b/src/Data/Swagger.hs @@ -186,7 +186,7 @@ import Data.Swagger.Internal -- & at 200 ?~ ("OK" & _Inline.schema ?~ Ref (Reference "User")) -- & at 404 ?~ "User info not found")) ] -- :} --- "{\"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\"]}}}}" +-- "{\"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\"}}}" -- -- In the snippet above we declare an API with a single path @/user@. This path provides method @GET@ -- which produces @application/json@ output. It should respond with code @200@ and body specified @@ -205,7 +205,7 @@ import Data.Swagger.Internal -- & type_ .~ SwaggerBoolean -- & description ?~ "To be or not to be" -- :} --- "{\"type\":\"boolean\",\"description\":\"To be or not to be\"}" +-- "{\"description\":\"To be or not to be\",\"type\":\"boolean\"}" -- -- @'ParamSchema'@ is basically the /base schema specification/ and many types contain it (see @'HasParamSchema'@). -- So for convenience, all @'ParamSchema'@ fields are transitively made fields of the type that has it. @@ -271,7 +271,7 @@ import Data.Swagger.Internal -- >>> encode (Person "David" 28) -- "{\"age\":28,\"name\":\"David\"}" -- >>> encode $ toSchema (Proxy :: Proxy Person) --- "{\"required\":[\"name\",\"age\"],\"type\":\"object\",\"properties\":{\"age\":{\"type\":\"integer\"},\"name\":{\"type\":\"string\"}}}" +-- "{\"required\":[\"name\",\"age\"],\"properties\":{\"name\":{\"type\":\"string\"},\"age\":{\"type\":\"integer\"}},\"type\":\"object\"}" -- $manipulation -- Sometimes you have to work with an imported or generated @'Swagger'@. diff --git a/src/Data/Swagger/Internal.hs b/src/Data/Swagger/Internal.hs index 59443a7..ec4f54a 100644 --- a/src/Data/Swagger/Internal.hs +++ b/src/Data/Swagger/Internal.hs @@ -58,6 +58,13 @@ import Data.Swagger.Internal.AesonUtils (sopSwaggerGenericToJSON ,saoSubObject) import Data.Swagger.Internal.Utils +#if MIN_VERSION_aeson(0,10,0) +import Data.Swagger.Internal.AesonUtils (sopSwaggerGenericToEncoding) +#define DEFINE_TOENCODING toEncoding = sopSwaggerGenericToEncoding +#else +#define DEFINE_TOENCODING +#endif + -- | A list of definitions that can be used in references. type Definitions = InsOrdHashMap Text @@ -982,6 +989,7 @@ instance ToJSON OAuth2Flow where instance ToJSON OAuth2Params where toJSON = sopSwaggerGenericToJSON + DEFINE_TOENCODING instance ToJSON SecuritySchemeType where toJSON SecuritySchemeBasic @@ -995,15 +1003,19 @@ instance ToJSON SecuritySchemeType where instance ToJSON Swagger where toJSON = sopSwaggerGenericToJSON + DEFINE_TOENCODING instance ToJSON SecurityScheme where toJSON = sopSwaggerGenericToJSON + DEFINE_TOENCODING instance ToJSON Schema where toJSON = sopSwaggerGenericToJSON + DEFINE_TOENCODING instance ToJSON Header where toJSON = sopSwaggerGenericToJSON + DEFINE_TOENCODING instance ToJSON (ParamSchema t) => ToJSON (SwaggerItems t) where toJSON (SwaggerItemsPrimitive fmt schema) = object @@ -1023,6 +1035,7 @@ instance ToJSON MimeList where instance ToJSON Param where toJSON = sopSwaggerGenericToJSON + DEFINE_TOENCODING instance ToJSON ParamAnySchema where toJSON (ParamBody s) = object [ "in" .= ("body" :: Text), "schema" .= s ] @@ -1030,18 +1043,23 @@ instance ToJSON ParamAnySchema where instance ToJSON ParamOtherSchema where toJSON = sopSwaggerGenericToJSON + DEFINE_TOENCODING instance ToJSON Responses where toJSON = sopSwaggerGenericToJSON + DEFINE_TOENCODING instance ToJSON Response where toJSON = sopSwaggerGenericToJSON + DEFINE_TOENCODING instance ToJSON Operation where toJSON = sopSwaggerGenericToJSON + DEFINE_TOENCODING instance ToJSON PathItem where toJSON = sopSwaggerGenericToJSON + DEFINE_TOENCODING instance ToJSON Example where toJSON = toJSON . Map.mapKeys show . getExample diff --git a/src/Data/Swagger/Internal/AesonUtils.hs b/src/Data/Swagger/Internal/AesonUtils.hs index a84ba82..f2fd950 100644 --- a/src/Data/Swagger/Internal/AesonUtils.hs +++ b/src/Data/Swagger/Internal/AesonUtils.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} @@ -8,6 +9,9 @@ module Data.Swagger.Internal.AesonUtils ( -- * Generic functions AesonDefaultValue(..), sopSwaggerGenericToJSON, +#if MIN_VERSION_aeson(0,10,0) + sopSwaggerGenericToEncoding, +#endif sopSwaggerGenericToJSONWithOpts, sopSwaggerGenericParseJSON, -- * Options @@ -26,7 +30,7 @@ import Control.Applicative ((<|>)) import Control.Lens (makeLenses, (^.)) import Control.Monad (unless) import Data.Aeson (ToJSON(..), FromJSON(..), Value(..), Object, object, (.:), (.:?), (.!=), withObject) -import Data.Aeson.Types (Parser) +import Data.Aeson.Types (Parser, Pair) import Data.Char (toLower, isUpper) import Data.Text (Text) @@ -37,6 +41,12 @@ import qualified Data.HashMap.Strict as HM import qualified Data.Set as Set import qualified Data.HashMap.Strict.InsOrd as InsOrd +#if MIN_VERSION_aeson(0,10,0) +import Data.Aeson (Encoding, pairs, (.=), Series) +import Data.Monoid ((<>)) +import Data.Foldable (foldMap) +#endif + ------------------------------------------------------------------------------- -- SwaggerAesonOptions ------------------------------------------------------------------------------- @@ -132,7 +142,7 @@ sopSwaggerGenericToJSON' -> SOP I '[xs] -> DatatypeInfo '[xs] -> POP Maybe '[xs] - -> [(Text, Value)] + -> [Pair] sopSwaggerGenericToJSON' opts (SOP (Z fields)) (ADT _ _ (Record _ fieldsInfo :* Nil)) (POP (defs :* Nil)) = sopSwaggerGenericToJSON'' opts fields fieldsInfo defs @@ -142,10 +152,10 @@ sopSwaggerGenericToJSON'' -> NP I xs -> NP FieldInfo xs -> NP Maybe xs - -> [(Text, Value)] + -> [Pair] sopSwaggerGenericToJSON'' (SwaggerAesonOptions prefix _ sub) = go where - go :: (All ToJSON ys, All Eq ys) => NP I ys -> NP FieldInfo ys -> NP Maybe ys -> [(Text, Value)] + go :: (All ToJSON ys, All Eq ys) => NP I ys -> NP FieldInfo ys -> NP Maybe ys -> [Pair] go Nil Nil Nil = [] go (I x :* xs) (FieldInfo name :* names) (def :* defs) | Just name' == sub = case json of @@ -240,3 +250,72 @@ sopSwaggerGenericParseJSON'' (SwaggerAesonOptions prefix _ sub) obj = go modifier = lowerFirstUppers . drop (length prefix) lowerFirstUppers s = map toLower x ++ y where (x, y) = span isUpper s + +------------------------------------------------------------------------------- +-- ToEncoding +------------------------------------------------------------------------------- + +#if MIN_VERSION_aeson(0,10,0) + +sopSwaggerGenericToEncoding + :: forall a xs. + ( Generic a + , HasDatatypeInfo a + , HasSwaggerAesonOptions a + , All2 ToJSON (Code a) + , All2 Eq (Code a) + , Code a ~ '[xs] + ) + => a + -> Encoding +sopSwaggerGenericToEncoding x = + let ps = sopSwaggerGenericToEncoding' opts (from x) (datatypeInfo proxy) (aesonDefaults proxy) + in pairs (pairsToSeries (opts ^. saoAdditionalPairs) <> ps) + where + proxy = Proxy :: Proxy a + opts = swaggerAesonOptions proxy + +pairsToSeries :: [Pair] -> Series +pairsToSeries = foldMap (\(k, v) -> (k .= v)) + +sopSwaggerGenericToEncoding' + :: (All2 ToJSON '[xs], All2 Eq '[xs]) + => SwaggerAesonOptions + -> SOP I '[xs] + -> DatatypeInfo '[xs] + -> POP Maybe '[xs] + -> Series +sopSwaggerGenericToEncoding' opts (SOP (Z fields)) (ADT _ _ (Record _ fieldsInfo :* Nil)) (POP (defs :* Nil)) = + sopSwaggerGenericToEncoding'' opts fields fieldsInfo defs + +sopSwaggerGenericToEncoding'' + :: (All ToJSON xs, All Eq xs) + => SwaggerAesonOptions + -> NP I xs + -> NP FieldInfo xs + -> NP Maybe xs + -> Series +sopSwaggerGenericToEncoding'' (SwaggerAesonOptions prefix _ sub) = go + where + go :: (All ToJSON ys, All Eq ys) => NP I ys -> NP FieldInfo ys -> NP Maybe ys -> Series + go Nil Nil Nil = mempty + go (I x :* xs) (FieldInfo name :* names) (def :* defs) + | Just name' == sub = case toJSON x of + Object m -> pairsToSeries (HM.toList m) <> rest + Null -> rest + _ -> error $ "sopSwaggerGenericToJSON: subjson is not an object: " ++ show (toJSON x) + -- If default value: omit it. + | Just x == def = + rest + | otherwise = + (T.pack name' .= x) <> rest + where + name' = fieldNameModifier name + rest = go xs names defs + + fieldNameModifier = modifier . drop 1 + modifier = lowerFirstUppers . drop (length prefix) + lowerFirstUppers s = map toLower x ++ y + where (x, y) = span isUpper s + +#endif diff --git a/src/Data/Swagger/Internal/Schema.hs b/src/Data/Swagger/Internal/Schema.hs index e211d8f..158165a 100644 --- a/src/Data/Swagger/Internal/Schema.hs +++ b/src/Data/Swagger/Internal/Schema.hs @@ -308,7 +308,7 @@ passwordSchema = mempty -- >>> data Person = Person { name :: String, age :: Int } deriving (Generic) -- >>> instance ToJSON Person -- >>> encode $ sketchSchema (Person "Jack" 25) --- "{\"example\":{\"age\":25,\"name\":\"Jack\"},\"required\":[\"age\",\"name\"],\"type\":\"object\",\"properties\":{\"age\":{\"type\":\"number\"},\"name\":{\"type\":\"string\"}}}" +-- "{\"required\":[\"age\",\"name\"],\"properties\":{\"age\":{\"type\":\"number\"},\"name\":{\"type\":\"string\"}},\"example\":{\"age\":25,\"name\":\"Jack\"},\"type\":\"object\"}" sketchSchema :: ToJSON a => a -> Schema sketchSchema = sketch . toJSON where @@ -352,7 +352,7 @@ sketchSchema = sketch . toJSON -- >>> data Person = Person { name :: String, age :: Int } deriving (Generic) -- >>> instance ToJSON Person -- >>> encode $ sketchStrictSchema (Person "Jack" 25) --- "{\"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\"]}}}" +-- "{\"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\"}]}" sketchStrictSchema :: ToJSON a => a -> Schema sketchStrictSchema = go . toJSON where diff --git a/src/Data/Swagger/Operation.hs b/src/Data/Swagger/Operation.hs index 6717b70..5948789 100644 --- a/src/Data/Swagger/Operation.hs +++ b/src/Data/Swagger/Operation.hs @@ -81,9 +81,9 @@ allOperations = paths.traverse.template -- >>> let api = (mempty :: Swagger) & paths .~ [("/user", mempty & get ?~ ok & post ?~ ok)] -- >>> let sub = (mempty :: Swagger) & paths .~ [("/user", mempty & get ?~ mempty)] -- >>> encode api --- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"paths\":{\"/user\":{\"post\":{\"responses\":{\"200\":{\"description\":\"OK\"}}},\"get\":{\"responses\":{\"200\":{\"description\":\"OK\"}}}}}}" +-- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"paths\":{\"/user\":{\"get\":{\"responses\":{\"200\":{\"description\":\"OK\"}}},\"post\":{\"responses\":{\"200\":{\"description\":\"OK\"}}}}}}" -- >>> encode $ api & operationsOf sub . at 404 ?~ "Not found" --- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"paths\":{\"/user\":{\"post\":{\"responses\":{\"200\":{\"description\":\"OK\"}}},\"get\":{\"responses\":{\"404\":{\"description\":\"Not found\"},\"200\":{\"description\":\"OK\"}}}}}}" +-- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"paths\":{\"/user\":{\"get\":{\"responses\":{\"404\":{\"description\":\"Not found\"},\"200\":{\"description\":\"OK\"}}},\"post\":{\"responses\":{\"200\":{\"description\":\"OK\"}}}}}}" operationsOf :: Swagger -> Traversal' Swagger Operation operationsOf sub = paths.itraversed.withIndex.subops where @@ -120,7 +120,7 @@ applyTagsFor ops ts swag = swag -- necessary schema definitions. -- -- >>> encode $ runDeclare (declareResponse (Proxy :: Proxy Day)) mempty --- "[{\"Day\":{\"format\":\"date\",\"type\":\"string\"}},{\"schema\":{\"$ref\":\"#/definitions/Day\"},\"description\":\"\"}]" +-- "[{\"Day\":{\"format\":\"date\",\"type\":\"string\"}},{\"description\":\"\",\"schema\":{\"$ref\":\"#/definitions/Day\"}}]" declareResponse :: ToSchema a => proxy a -> Declare (Definitions Schema) Response declareResponse proxy = do s <- declareSchemaRef proxy @@ -140,7 +140,7 @@ declareResponse proxy = do -- >>> let api = (mempty :: Swagger) & paths .~ [("/user", mempty & get ?~ mempty)] -- >>> let res = declareResponse (Proxy :: Proxy Day) -- >>> encode $ api & setResponse 200 res --- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"definitions\":{\"Day\":{\"format\":\"date\",\"type\":\"string\"}},\"paths\":{\"/user\":{\"get\":{\"responses\":{\"200\":{\"schema\":{\"$ref\":\"#/definitions/Day\"},\"description\":\"\"}}}}}}" +-- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"paths\":{\"/user\":{\"get\":{\"responses\":{\"200\":{\"schema\":{\"$ref\":\"#/definitions/Day\"},\"description\":\"\"}}}}},\"definitions\":{\"Day\":{\"format\":\"date\",\"type\":\"string\"}}}" -- -- See also @'setResponseWith'@. setResponse :: HttpStatusCode -> Declare (Definitions Schema) Response -> Swagger -> Swagger diff --git a/swagger2.cabal b/swagger2.cabal index f1c9571..5f2e451 100644 --- a/swagger2.cabal +++ b/swagger2.cabal @@ -63,10 +63,12 @@ test-suite spec type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Spec.hs + -- We need aeson's toEncoding for doctests too build-depends: base , base-compat - , aeson + , aeson >=0.10.0.0 , aeson-qq + , bytestring , containers , hashable , hspec diff --git a/test/SpecCommon.hs b/test/SpecCommon.hs index 368285c..c8c2e96 100644 --- a/test/SpecCommon.hs +++ b/test/SpecCommon.hs @@ -1,6 +1,7 @@ module SpecCommon where import Data.Aeson +import Data.ByteString.Builder (toLazyByteString) import qualified Data.Foldable as F import qualified Data.HashMap.Strict as HashMap import qualified Data.Vector as Vector @@ -21,5 +22,9 @@ x <=> js = do toJSON x `shouldBe` js it "decodes correctly" $ do fromJSON js `shouldBe` Success x - - + it "roundtrips: eitherDecode . encode" $ do + eitherDecode (encode x) `shouldBe` Right x + it "roundtrips with toJSON" $ do + eitherDecode (encode $ toJSON x) `shouldBe` Right x + it "roundtrips with toEncoding" $ do + eitherDecode (toLazyByteString $ fromEncoding $ toEncoding x) `shouldBe` Right x From b2dbef8392b52aa99a72eb1ce0d3850436bf486a Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Wed, 9 Mar 2016 11:08:47 +0200 Subject: [PATCH 8/9] Update stack-lts-2.yaml --- stack-lts-2.yaml | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/stack-lts-2.yaml b/stack-lts-2.yaml index 809bd2e..55ed704 100644 --- a/stack-lts-2.yaml +++ b/stack-lts-2.yaml @@ -1,5 +1,8 @@ flags: {} packages: - '.' -extra-deps: [] +extra-deps: +- generics-sop-0.2.1.0 +- insert-ordered-containers-0.1.0.1 +- unordered-containers-0.2.7.0 resolver: lts-2.22 From 1d25fb12c2a1d2e516d2d57dcb6c3590d5f4da8b Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Wed, 9 Mar 2016 11:48:09 +0200 Subject: [PATCH 9/9] Fix compilation issues and warnings --- src/Data/Swagger/Internal.hs | 97 ++++++++++++------------- src/Data/Swagger/Internal/AesonUtils.hs | 16 +++- src/Data/Swagger/Internal/Utils.hs | 3 - src/Data/Swagger/Lens.hs | 14 ++-- 4 files changed, 69 insertions(+), 61 deletions(-) diff --git a/src/Data/Swagger/Internal.hs b/src/Data/Swagger/Internal.hs index ec4f54a..2e304b7 100644 --- a/src/Data/Swagger/Internal.hs +++ b/src/Data/Swagger/Internal.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} @@ -8,15 +9,15 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE UndecidableInstances #-} - -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +#if __GLASGOW_HASKELL__ <710 +{-# LANGUAGE PolyKinds #-} +#endif #include "overlapping-compat.h" module Data.Swagger.Internal where @@ -25,11 +26,9 @@ import Prelude.Compat import Control.Lens ((&), (.~), (?~)) import Control.Applicative -import Control.Monad import Data.Aeson import qualified Data.Aeson.Types as JSON import Data.Data (Data(..), Typeable, mkConstr, mkDataType, Fixity(..), Constr, DataType, constrIndex) -import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap import Data.Map (Map) import qualified Data.Map as Map @@ -355,7 +354,7 @@ data ParamOtherSchema = ParamOtherSchema -- Default value is @False@. , _paramOtherSchemaAllowEmptyValue :: Maybe Bool - , _paramOtherSchemaParamSchema :: ParamSchema SwaggerKindParamOtherSchema + , _paramOtherSchemaParamSchema :: ParamSchema 'SwaggerKindParamOtherSchema } deriving (Eq, Show, Generic, Typeable, Data) -- | Items for @'SwaggerArray'@ schemas. @@ -370,8 +369,8 @@ data ParamOtherSchema = ParamOtherSchema -- @'SwaggerItemsArray'@ should be used to specify tuple @'Schema'@s. data SwaggerItems t where SwaggerItemsPrimitive :: Maybe (CollectionFormat k) -> ParamSchema k-> SwaggerItems k - SwaggerItemsObject :: Referenced Schema -> SwaggerItems SwaggerKindSchema - SwaggerItemsArray :: [Referenced Schema] -> SwaggerItems SwaggerKindSchema + SwaggerItemsObject :: Referenced Schema -> SwaggerItems 'SwaggerKindSchema + SwaggerItemsArray :: [Referenced Schema] -> SwaggerItems 'SwaggerKindSchema deriving (Typeable) deriving instance Eq (SwaggerItems t) @@ -393,7 +392,7 @@ swaggerItemsDataType = mkDataType "Data.Swagger.SwaggerItems" [swaggerItemsPrimi -- Note: unfortunately we have to write these Data instances by hand, -- to get better contexts / avoid duplicate name when using standalone deriving -instance Data t => Data (SwaggerItems (SwaggerKindNormal t)) where +instance Data t => Data (SwaggerItems ('SwaggerKindNormal t)) where -- TODO: define gfoldl gunfold k z c = case constrIndex c of 1 -> k (k (z SwaggerItemsPrimitive)) @@ -402,7 +401,7 @@ instance Data t => Data (SwaggerItems (SwaggerKindNormal t)) where dataTypeOf _ = swaggerItemsDataType -- SwaggerItems SwaggerKindParamOtherSchema can be constructed using SwaggerItemsPrimitive only -instance Data (SwaggerItems SwaggerKindParamOtherSchema) where +instance Data (SwaggerItems 'SwaggerKindParamOtherSchema) where -- TODO: define gfoldl gunfold k z c = case constrIndex c of 1 -> k (k (z SwaggerItemsPrimitive)) @@ -410,18 +409,19 @@ instance Data (SwaggerItems SwaggerKindParamOtherSchema) where toConstr _ = swaggerItemsPrimitiveConstr dataTypeOf _ = swaggerItemsDataType -instance Data (SwaggerItems SwaggerKindSchema) where +instance Data (SwaggerItems 'SwaggerKindSchema) where gfoldl _ _ (SwaggerItemsPrimitive _ _) = error $ " Data.Data.gfoldl: Constructor SwaggerItemsPrimitive used to construct SwaggerItems SwaggerKindSchema" gfoldl k z (SwaggerItemsObject ref) = z SwaggerItemsObject `k` ref gfoldl k z (SwaggerItemsArray ref) = z SwaggerItemsArray `k` ref gunfold k z c = case constrIndex c of - 1 -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type (SwaggerItems SwaggerKindSchema)" 2 -> k (z SwaggerItemsObject) 3 -> k (z SwaggerItemsArray) + _ -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type (SwaggerItems SwaggerKindSchema)." - toConstr (SwaggerItemsObject _) = swaggerItemsObjectConstr - toConstr (SwaggerItemsArray _) = swaggerItemsArrayConstr + toConstr (SwaggerItemsPrimitive _ _) = error "Not supported" + toConstr (SwaggerItemsObject _) = swaggerItemsObjectConstr + toConstr (SwaggerItemsArray _) = swaggerItemsArrayConstr dataTypeOf _ = swaggerItemsDataType @@ -430,17 +430,16 @@ data SwaggerKind t = SwaggerKindNormal t | SwaggerKindParamOtherSchema | SwaggerKindSchema + deriving (Typeable) -#if __GLASGLOW_HASKELL__ < 710 deriving instance Typeable 'SwaggerKindNormal deriving instance Typeable 'SwaggerKindParamOtherSchema deriving instance Typeable 'SwaggerKindSchema -#endif type family SwaggerKindType (k :: SwaggerKind *) :: * -type instance SwaggerKindType (SwaggerKindNormal t) = t -type instance SwaggerKindType SwaggerKindSchema = Schema -type instance SwaggerKindType SwaggerKindParamOtherSchema = ParamOtherSchema +type instance SwaggerKindType ('SwaggerKindNormal t) = t +type instance SwaggerKindType 'SwaggerKindSchema = Schema +type instance SwaggerKindType 'SwaggerKindParamOtherSchema = ParamOtherSchema data SwaggerType t where SwaggerString :: SwaggerType t @@ -448,9 +447,9 @@ data SwaggerType t where SwaggerInteger :: SwaggerType t SwaggerBoolean :: SwaggerType t SwaggerArray :: SwaggerType t - SwaggerFile :: SwaggerType SwaggerKindParamOtherSchema - SwaggerNull :: SwaggerType SwaggerKindSchema - SwaggerObject :: SwaggerType SwaggerKindSchema + SwaggerFile :: SwaggerType 'SwaggerKindParamOtherSchema + SwaggerNull :: SwaggerType 'SwaggerKindSchema + SwaggerObject :: SwaggerType 'SwaggerKindSchema deriving (Typeable) deriving instance Eq (SwaggerType t) @@ -465,27 +464,27 @@ swaggerTypeDataType _ = mkDataType "Data.Swagger.SwaggerType" swaggerTypeConstrs swaggerCommonTypes :: [SwaggerType k] swaggerCommonTypes = [SwaggerString, SwaggerNumber, SwaggerInteger, SwaggerBoolean, SwaggerArray] -swaggerParamTypes :: [SwaggerType SwaggerKindParamOtherSchema] +swaggerParamTypes :: [SwaggerType 'SwaggerKindParamOtherSchema] swaggerParamTypes = swaggerCommonTypes ++ [SwaggerFile] -swaggerSchemaTypes :: [SwaggerType SwaggerKindSchema] +swaggerSchemaTypes :: [SwaggerType 'SwaggerKindSchema] swaggerSchemaTypes = swaggerCommonTypes ++ [error "SwaggerFile is invalid SwaggerType Schema", SwaggerNull, SwaggerObject] swaggerTypeConstrs :: [Constr] -swaggerTypeConstrs = map swaggerTypeConstr (swaggerCommonTypes :: [SwaggerType SwaggerKindSchema]) +swaggerTypeConstrs = map swaggerTypeConstr (swaggerCommonTypes :: [SwaggerType 'SwaggerKindSchema]) ++ [swaggerTypeConstr SwaggerFile, swaggerTypeConstr SwaggerNull, swaggerTypeConstr SwaggerObject] -instance Typeable t => Data (SwaggerType (SwaggerKindNormal t)) where +instance Typeable t => Data (SwaggerType ('SwaggerKindNormal t)) where gunfold = gunfoldEnum "SwaggerType" swaggerCommonTypes toConstr = swaggerTypeConstr dataTypeOf = swaggerTypeDataType -instance Data (SwaggerType SwaggerKindParamOtherSchema) where +instance Data (SwaggerType 'SwaggerKindParamOtherSchema) where gunfold = gunfoldEnum "SwaggerType ParamOtherSchema" swaggerParamTypes toConstr = swaggerTypeConstr dataTypeOf = swaggerTypeDataType -instance Data (SwaggerType SwaggerKindSchema) where +instance Data (SwaggerType 'SwaggerKindSchema) where gunfold = gunfoldEnum "SwaggerType Schema" swaggerSchemaTypes toConstr = swaggerTypeConstr dataTypeOf = swaggerTypeDataType @@ -525,7 +524,7 @@ data CollectionFormat t where -- Corresponds to multiple parameter instances -- instead of multiple values for a single instance @foo=bar&foo=baz@. -- This is valid only for parameters in @'ParamQuery'@ or @'ParamFormData'@. - CollectionMulti :: CollectionFormat SwaggerKindParamOtherSchema + CollectionMulti :: CollectionFormat 'SwaggerKindParamOtherSchema deriving (Typeable) deriving instance Eq (CollectionFormat t) @@ -541,12 +540,12 @@ collectionFormatDataType = mkDataType "Data.Swagger.CollectionFormat" $ collectionCommonFormats :: [CollectionFormat t] collectionCommonFormats = [ CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes ] -instance Data t => Data (CollectionFormat (SwaggerKindNormal t)) where +instance Data t => Data (CollectionFormat ('SwaggerKindNormal t)) where gunfold = gunfoldEnum "CollectionFormat" collectionCommonFormats toConstr = collectionFormatConstr dataTypeOf _ = collectionFormatDataType -deriving instance Data (CollectionFormat SwaggerKindParamOtherSchema) +deriving instance Data (CollectionFormat 'SwaggerKindParamOtherSchema) type ParamName = Text @@ -568,7 +567,7 @@ data Schema = Schema , _schemaMaxProperties :: Maybe Integer , _schemaMinProperties :: Maybe Integer - , _schemaParamSchema :: ParamSchema SwaggerKindSchema + , _schemaParamSchema :: ParamSchema 'SwaggerKindSchema } deriving (Eq, Show, Generic, Data, Typeable) -- | A @'Schema'@ with an optional name. @@ -682,7 +681,7 @@ data Header = Header { -- | A short description of the header. _headerDescription :: Maybe Text - , _headerParamSchema :: ParamSchema (SwaggerKindNormal Header) + , _headerParamSchema :: ParamSchema ('SwaggerKindNormal Header) } deriving (Eq, Show, Generic, Data, Typeable) data Example = Example { getExample :: Map MediaType Value } @@ -1139,17 +1138,17 @@ instance FromJSON Schema where instance FromJSON Header where parseJSON = sopSwaggerGenericParseJSON -instance (FromJSON (CollectionFormat (SwaggerKindNormal t)), FromJSON (ParamSchema (SwaggerKindNormal t))) => FromJSON (SwaggerItems (SwaggerKindNormal t)) where +instance (FromJSON (CollectionFormat ('SwaggerKindNormal t)), FromJSON (ParamSchema ('SwaggerKindNormal t))) => FromJSON (SwaggerItems ('SwaggerKindNormal t)) where parseJSON = withObject "SwaggerItemsPrimitive" $ \o -> SwaggerItemsPrimitive <$> o .:? "collectionFormat" <*> (o .: "items" >>= parseJSON) -instance FromJSON (SwaggerItems SwaggerKindParamOtherSchema) where +instance FromJSON (SwaggerItems 'SwaggerKindParamOtherSchema) where parseJSON = withObject "SwaggerItemsPrimitive" $ \o -> SwaggerItemsPrimitive <$> o .:? "collectionFormat" <*> ((o .: "items" >>= parseJSON) <|> fail ("foo" ++ show o)) -instance FromJSON (SwaggerItems SwaggerKindSchema) where +instance FromJSON (SwaggerItems 'SwaggerKindSchema) where parseJSON js@(Object _) = SwaggerItemsObject <$> parseJSON js parseJSON js@(Array _) = SwaggerItemsArray <$> parseJSON js parseJSON _ = empty @@ -1226,30 +1225,30 @@ instance FromJSON (Referenced Response) where parseJSON = referencedParseJSON "# instance FromJSON Xml where parseJSON = genericParseJSON (jsonPrefix "xml") -instance FromJSON (SwaggerType SwaggerKindSchema) where +instance FromJSON (SwaggerType 'SwaggerKindSchema) where parseJSON = parseOneOf [SwaggerString, SwaggerInteger, SwaggerNumber, SwaggerBoolean, SwaggerArray, SwaggerNull, SwaggerObject] -instance FromJSON (SwaggerType SwaggerKindParamOtherSchema) where +instance FromJSON (SwaggerType 'SwaggerKindParamOtherSchema) where parseJSON = parseOneOf [SwaggerString, SwaggerInteger, SwaggerNumber, SwaggerBoolean, SwaggerArray, SwaggerFile] -instance FromJSON (SwaggerType (SwaggerKindNormal t)) where +instance FromJSON (SwaggerType ('SwaggerKindNormal t)) where parseJSON = parseOneOf [SwaggerString, SwaggerInteger, SwaggerNumber, SwaggerBoolean, SwaggerArray] -instance FromJSON (CollectionFormat (SwaggerKindNormal t)) where +instance FromJSON (CollectionFormat ('SwaggerKindNormal t)) where parseJSON = parseOneOf [CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes] -- NOTE: There aren't collections of 'Schema' --instance FromJSON (CollectionFormat (SwaggerKindSchema)) where -- parseJSON = parseOneOf [CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes] -instance FromJSON (CollectionFormat SwaggerKindParamOtherSchema) where +instance FromJSON (CollectionFormat 'SwaggerKindParamOtherSchema) where parseJSON = parseOneOf [CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes, CollectionMulti] -instance (FromJSON (SwaggerType (SwaggerKindNormal t)), FromJSON (SwaggerItems (SwaggerKindNormal t))) => FromJSON (ParamSchema (SwaggerKindNormal t)) where +instance (FromJSON (SwaggerType ('SwaggerKindNormal t)), FromJSON (SwaggerItems ('SwaggerKindNormal t))) => FromJSON (ParamSchema ('SwaggerKindNormal t)) where parseJSON = sopSwaggerGenericParseJSON -instance FromJSON (ParamSchema SwaggerKindParamOtherSchema) where +instance FromJSON (ParamSchema 'SwaggerKindParamOtherSchema) where parseJSON = sopSwaggerGenericParseJSON -instance FromJSON (ParamSchema SwaggerKindSchema) where +instance FromJSON (ParamSchema 'SwaggerKindSchema) where parseJSON = sopSwaggerGenericParseJSON ------------------------------------------------------------------------------- @@ -1292,12 +1291,12 @@ instance HasSwaggerAesonOptions Schema where instance HasSwaggerAesonOptions Swagger where swaggerAesonOptions _ = mkSwaggerAesonOptions "swagger" & saoAdditionalPairs .~ [("swagger", "2.0")] -instance HasSwaggerAesonOptions (ParamSchema (SwaggerKindNormal t)) where +instance HasSwaggerAesonOptions (ParamSchema ('SwaggerKindNormal t)) where swaggerAesonOptions _ = mkSwaggerAesonOptions "paramSchema" & saoSubObject ?~ "items" -instance HasSwaggerAesonOptions (ParamSchema SwaggerKindParamOtherSchema) where +instance HasSwaggerAesonOptions (ParamSchema 'SwaggerKindParamOtherSchema) where swaggerAesonOptions _ = mkSwaggerAesonOptions "paramSchema" & saoSubObject ?~ "items" -- NOTE: Schema doesn't have 'items' sub object! -instance HasSwaggerAesonOptions (ParamSchema SwaggerKindSchema) where +instance HasSwaggerAesonOptions (ParamSchema 'SwaggerKindSchema) where swaggerAesonOptions _ = mkSwaggerAesonOptions "paramSchema" instance AesonDefaultValue (ParamSchema s) diff --git a/src/Data/Swagger/Internal/AesonUtils.hs b/src/Data/Swagger/Internal/AesonUtils.hs index f2fd950..68dba92 100644 --- a/src/Data/Swagger/Internal/AesonUtils.hs +++ b/src/Data/Swagger/Internal/AesonUtils.hs @@ -32,6 +32,7 @@ import Control.Monad (unless) import Data.Aeson (ToJSON(..), FromJSON(..), Value(..), Object, object, (.:), (.:?), (.!=), withObject) import Data.Aeson.Types (Parser, Pair) import Data.Char (toLower, isUpper) +import Data.Foldable (traverse_) import Data.Text (Text) import Generics.SOP @@ -44,7 +45,6 @@ import qualified Data.HashMap.Strict.InsOrd as InsOrd #if MIN_VERSION_aeson(0,10,0) import Data.Aeson (Encoding, pairs, (.=), Series) import Data.Monoid ((<>)) -import Data.Foldable (foldMap) #endif ------------------------------------------------------------------------------- @@ -145,6 +145,7 @@ sopSwaggerGenericToJSON' -> [Pair] sopSwaggerGenericToJSON' opts (SOP (Z fields)) (ADT _ _ (Record _ fieldsInfo :* Nil)) (POP (defs :* Nil)) = sopSwaggerGenericToJSON'' opts fields fieldsInfo defs +sopSwaggerGenericToJSON' _ _ _ _ = error "sopSwaggerGenericToJSON: unsupported type" sopSwaggerGenericToJSON'' :: (All ToJSON xs, All Eq xs) @@ -171,6 +172,9 @@ sopSwaggerGenericToJSON'' (SwaggerAesonOptions prefix _ sub) = go json = toJSON x name' = fieldNameModifier name rest = go xs names defs +#if __GLASGOW_HASKELL__ < 800 + go _ _ _ = error "not empty" +#endif fieldNameModifier = modifier . drop 1 modifier = lowerFirstUppers . drop (length prefix) @@ -195,7 +199,7 @@ sopSwaggerGenericParseJSON sopSwaggerGenericParseJSON = withObject "Swagger Record Object" $ \obj -> let ps = sopSwaggerGenericParseJSON' opts obj (datatypeInfo proxy) (aesonDefaults proxy) in do - traverse (parseAdditionalField obj) (opts ^. saoAdditionalPairs) + traverse_ (parseAdditionalField obj) (opts ^. saoAdditionalPairs) to <$> ps where proxy = Proxy :: Proxy a @@ -218,6 +222,7 @@ sopSwaggerGenericParseJSON' -> Parser (SOP I '[xs]) sopSwaggerGenericParseJSON' opts obj (ADT _ _ (Record _ fieldsInfo :* Nil)) (POP (defs :* Nil)) = SOP . Z <$> sopSwaggerGenericParseJSON'' opts obj fieldsInfo defs +sopSwaggerGenericParseJSON' _ _ _ _ = error "sopSwaggerGenericParseJSON: unsupported type" sopSwaggerGenericParseJSON'' :: (All FromJSON xs, All Eq xs) @@ -245,6 +250,9 @@ sopSwaggerGenericParseJSON'' (SwaggerAesonOptions prefix _ sub) obj = go withDef = case def of Just def' -> (<|> pure def') Nothing -> id +#if __GLASGOW_HASKELL__ < 800 + go _ _ = error "not empty" +#endif fieldNameModifier = modifier . drop 1 modifier = lowerFirstUppers . drop (length prefix) @@ -287,6 +295,7 @@ sopSwaggerGenericToEncoding' -> Series sopSwaggerGenericToEncoding' opts (SOP (Z fields)) (ADT _ _ (Record _ fieldsInfo :* Nil)) (POP (defs :* Nil)) = sopSwaggerGenericToEncoding'' opts fields fieldsInfo defs +sopSwaggerGenericToEncoding' _ _ _ _ = error "sopSwaggerGenericToEncoding: unsupported type" sopSwaggerGenericToEncoding'' :: (All ToJSON xs, All Eq xs) @@ -312,6 +321,9 @@ sopSwaggerGenericToEncoding'' (SwaggerAesonOptions prefix _ sub) = go where name' = fieldNameModifier name rest = go xs names defs +#if __GLASGOW_HASKELL__ < 800 + go _ _ _ = error "not empty" +#endif fieldNameModifier = modifier . drop 1 modifier = lowerFirstUppers . drop (length prefix) diff --git a/src/Data/Swagger/Internal/Utils.hs b/src/Data/Swagger/Internal/Utils.hs index a41f488..5327f71 100644 --- a/src/Data/Swagger/Internal/Utils.hs +++ b/src/Data/Swagger/Internal/Utils.hs @@ -9,8 +9,6 @@ module Data.Swagger.Internal.Utils where import Prelude () import Prelude.Compat -import Control.Arrow (first) -import Control.Applicative import Control.Lens ((&), (%~)) import Control.Lens.TH import Data.Aeson @@ -28,7 +26,6 @@ import Data.Set (Set) import Data.Text (Text) import GHC.Generics import Language.Haskell.TH (mkName) -import Text.Read (readMaybe) swaggerFieldRules :: LensRules swaggerFieldRules = defaultFieldRules & lensField %~ swaggerFieldNamer diff --git a/src/Data/Swagger/Lens.hs b/src/Data/Swagger/Lens.hs index f6991a5..6b22661 100644 --- a/src/Data/Swagger/Lens.hs +++ b/src/Data/Swagger/Lens.hs @@ -60,14 +60,14 @@ makePrisms ''Referenced -- ** 'SwaggerItems' prisms -_SwaggerItemsArray :: Review (SwaggerItems SwaggerKindSchema) [Referenced Schema] +_SwaggerItemsArray :: Review (SwaggerItems 'SwaggerKindSchema) [Referenced Schema] _SwaggerItemsArray = prism (\x -> SwaggerItemsArray x) $ \x -> case x of SwaggerItemsPrimitive c p -> Left (SwaggerItemsPrimitive c p) SwaggerItemsObject o -> Left (SwaggerItemsObject o) SwaggerItemsArray a -> Right a -_SwaggerItemsObject :: Review (SwaggerItems SwaggerKindSchema) (Referenced Schema) +_SwaggerItemsObject :: Review (SwaggerItems 'SwaggerKindSchema) (Referenced Schema) _SwaggerItemsObject = prism (\x -> SwaggerItemsObject x) $ \x -> case x of SwaggerItemsPrimitive c p -> Left (SwaggerItemsPrimitive c p) @@ -92,13 +92,13 @@ instance At Responses where at n = responses . at n instance Ixed Operation where ix n = responses . ix n instance At Operation where at n = responses . at n -instance HasParamSchema NamedSchema (ParamSchema SwaggerKindSchema) where paramSchema = schema.paramSchema +instance HasParamSchema NamedSchema (ParamSchema 'SwaggerKindSchema) where paramSchema = schema.paramSchema -- HasType instances -instance HasType Header (SwaggerType (SwaggerKindNormal Header)) where type_ = paramSchema.type_ -instance HasType Schema (SwaggerType SwaggerKindSchema) where type_ = paramSchema.type_ -instance HasType NamedSchema (SwaggerType SwaggerKindSchema) where type_ = paramSchema.type_ -instance HasType ParamOtherSchema (SwaggerType SwaggerKindParamOtherSchema) where type_ = paramSchema.type_ +instance HasType Header (SwaggerType ('SwaggerKindNormal Header)) where type_ = paramSchema.type_ +instance HasType Schema (SwaggerType 'SwaggerKindSchema) where type_ = paramSchema.type_ +instance HasType NamedSchema (SwaggerType 'SwaggerKindSchema) where type_ = paramSchema.type_ +instance HasType ParamOtherSchema (SwaggerType 'SwaggerKindParamOtherSchema) where type_ = paramSchema.type_ -- HasDefault instances instance HasDefault Header (Maybe Value) where default_ = paramSchema.default_