git.iko.soy/typeable/swagger2
on master help sign in
RFC: using generics-sop to derive some ToJSON instances
e2a9cc2Oleg Grenrus
src/Data/Swagger/Internal.hs+47−21
compare with master
unifiedsplit
@@ -12,12 +12,17 @@
12{-# LANGUAGE ScopedTypeVariables #-}
12{-# LANGUAGE ScopedTypeVariables #-}
13{-# LANGUAGE StandaloneDeriving #-}
13{-# LANGUAGE StandaloneDeriving #-}
14{-# LANGUAGE UndecidableInstances #-}
14{-# LANGUAGE UndecidableInstances #-}
15+
16+{-# LANGUAGE DataKinds #-}
17+{-# LANGUAGE TypeFamilies #-}
18+{-# LANGUAGE TemplateHaskell #-}
15#include "overlapping-compat.h"
19#include "overlapping-compat.h"
16module Data.Swagger.Internal where
20module Data.Swagger.Internal where
17
21
18import Prelude ()
22import Prelude ()
19import Prelude.Compat
23import Prelude.Compat
20
24
25+import Control.Lens ((&), (.~), (?~))
21import Control.Applicative
26import Control.Applicative
22import Control.Monad
27import Control.Monad
23import Data.Aeson
28import Data.Aeson
@@ -41,6 +46,11 @@ import Text.Read (readMaybe)
41import Data.HashMap.Strict.InsOrd (InsOrdHashMap)
46import Data.HashMap.Strict.InsOrd (InsOrdHashMap)
42import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
47import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
43
48
49+import Generics.SOP.TH (deriveGeneric)
50+import Data.Swagger.Internal.AesonUtils (sopSwaggerGenericToJSON
51+ ,mkSwaggerAesonOptions
52+ ,saoAdditionalPairs
53+ ,saoSubObject)
44import Data.Swagger.Internal.Utils
54import Data.Swagger.Internal.Utils
45
55
46-- | A list of definitions that can be used in references.
56-- | A list of definitions that can be used in references.
@@ -921,7 +931,8 @@ instance ToJSON OAuth2Flow where
921 , "tokenUrl" .= tokenUrl ]
931 , "tokenUrl" .= tokenUrl ]
922
932
923instance ToJSON OAuth2Params where
933instance ToJSON OAuth2Params where
924− toJSON = omitEmpties . genericToJSONWithSub "flow" (jsonPrefix "oauth2")
934+ toJSON = sopSwaggerGenericToJSON $ mkSwaggerAesonOptions "oauth2" &
935+ saoSubObject ?~ "flow"
925
936
926instance ToJSON SecuritySchemeType where
937instance ToJSON SecuritySchemeType where
927 toJSON SecuritySchemeBasic
938 toJSON SecuritySchemeBasic
@@ -934,22 +945,20 @@ instance ToJSON SecuritySchemeType where
934 <+> object [ "type" .= ("oauth2" :: Text) ]
945 <+> object [ "type" .= ("oauth2" :: Text) ]
935
946
936instance ToJSON Swagger where
947instance ToJSON Swagger where
937− toJSON = omitEmpties . addVersion . genericToJSON (jsonPrefix "swagger")
948+ toJSON = sopSwaggerGenericToJSON $ mkSwaggerAesonOptions "swagger" &
938− where
949+ saoAdditionalPairs .~ [("swagger", "2.0")]
939− addVersion (Object o) = Object (HashMap.insert "swagger" "2.0" o)
940− addVersion _ = error "impossible"
941
950
942instance ToJSON SecurityScheme where
951instance ToJSON SecurityScheme where
943− toJSON = genericToJSONWithSub "type" (jsonPrefix "securityScheme")
952+ toJSON = sopSwaggerGenericToJSON $ mkSwaggerAesonOptions "securityScheme" &
953+ saoSubObject ?~ "type"
944
954
945instance ToJSON Schema where
955instance ToJSON Schema where
946− toJSON = omitEmptiesExcept f . genericToJSONWithSub "paramSchema" (jsonPrefix "schema")
956+ toJSON = sopSwaggerGenericToJSON $ mkSwaggerAesonOptions "schema" &
947− where
957+ saoSubObject ?~ "paramSchema"
948− f "items" (Array _) = True
949− f _ _ = False
950
958
951instance ToJSON Header where
959instance ToJSON Header where
952− toJSON = genericToJSONWithSub "paramSchema" (jsonPrefix "header")
960+ toJSON = sopSwaggerGenericToJSON $ mkSwaggerAesonOptions "header" &
961+ saoSubObject ?~ "paramSchema"
953
962
954instance ToJSON (SwaggerItems t) where
963instance ToJSON (SwaggerItems t) where
955 toJSON (SwaggerItemsPrimitive fmt schema) = object
964 toJSON (SwaggerItemsPrimitive fmt schema) = object
@@ -968,26 +977,29 @@ instance ToJSON MimeList where
968 toJSON (MimeList xs) = toJSON (map show xs)
977 toJSON (MimeList xs) = toJSON (map show xs)
969
978
970instance ToJSON Param where
979instance ToJSON Param where
971− toJSON = genericToJSONWithSub "schema" (jsonPrefix "param")
980+ toJSON = sopSwaggerGenericToJSON $ mkSwaggerAesonOptions "param" &
981+ saoSubObject ?~ "schema"
972
982
973instance ToJSON ParamAnySchema where
983instance ToJSON ParamAnySchema where
974 toJSON (ParamBody s) = object [ "in" .= ("body" :: Text), "schema" .= s ]
984 toJSON (ParamBody s) = object [ "in" .= ("body" :: Text), "schema" .= s ]
975 toJSON (ParamOther s) = toJSON s
985 toJSON (ParamOther s) = toJSON s
976
986
977instance ToJSON ParamOtherSchema where
987instance ToJSON ParamOtherSchema where
978− toJSON = genericToJSONWithSub "paramSchema" (jsonPrefix "paramOtherSchema")
988+ toJSON = sopSwaggerGenericToJSON $ mkSwaggerAesonOptions "paramOtherSchema" &
989+ saoSubObject ?~ "paramSchema"
979
990
980instance ToJSON Responses where
991instance ToJSON Responses where
981− toJSON = omitEmpties . genericToJSONWithSub "responses" (jsonPrefix "responses")
992+ toJSON = sopSwaggerGenericToJSON $ mkSwaggerAesonOptions "responses" &
993+ saoSubObject ?~ "responses"
982
994
983instance ToJSON Response where
995instance ToJSON Response where
984− toJSON = omitEmpties . genericToJSON (jsonPrefix "response")
996+ toJSON = sopSwaggerGenericToJSON $ mkSwaggerAesonOptions "response"
985
997
986instance ToJSON Operation where
998instance ToJSON Operation where
987− toJSON = omitEmpties . genericToJSON (jsonPrefix "operation")
999+ toJSON = sopSwaggerGenericToJSON $ mkSwaggerAesonOptions "operation"
988
1000
989instance ToJSON PathItem where
1001instance ToJSON PathItem where
990− toJSON = omitEmpties . genericToJSON (jsonPrefix "pathItem")
1002+ toJSON = sopSwaggerGenericToJSON $ mkSwaggerAesonOptions "pathItem"
991
1003
992instance ToJSON Example where
1004instance ToJSON Example where
993 toJSON = toJSON . Map.mapKeys show . getExample
1005 toJSON = toJSON . Map.mapKeys show . getExample
@@ -1021,10 +1033,8 @@ instance ToJSON (CollectionFormat t) where
1021 toJSON CollectionMulti = "multi"
1033 toJSON CollectionMulti = "multi"
1022
1034
1023instance ToJSON (ParamSchema t) where
1035instance ToJSON (ParamSchema t) where
1024− toJSON = omitEmptiesExcept f . genericToJSONWithSub "items" (jsonPrefix "paramSchema")
1036+ toJSON = sopSwaggerGenericToJSON $ mkSwaggerAesonOptions "paramSchema" &
1025− where
1037+ saoSubObject ?~ "items"
1026− f "items" (Array _) = True
1027− f _ _ = False
1028
1038
1029-- =======================================================================
1039-- =======================================================================
1030-- Manual FromJSON instances
1040-- Manual FromJSON instances
@@ -1193,3 +1203,19 @@ instance FromJSON (CollectionFormat ParamOtherSchema) where
1193instance (FromJSON (SwaggerType t), FromJSON (SwaggerItems t)) => FromJSON (ParamSchema t) where
1203instance (FromJSON (SwaggerType t), FromJSON (SwaggerItems t)) => FromJSON (ParamSchema t) where
1194 parseJSON = genericParseJSONWithSub "items" (jsonPrefix "ParamSchema")
1204 parseJSON = genericParseJSONWithSub "items" (jsonPrefix "ParamSchema")
1195
1205
1206+-------------------------------------------------------------------------------
1207+-- TH splices
1208+-------------------------------------------------------------------------------
1209+
1210+deriveGeneric ''Header
1211+deriveGeneric ''OAuth2Params
1212+deriveGeneric ''Operation
1213+deriveGeneric ''Param
1214+deriveGeneric ''ParamOtherSchema
1215+deriveGeneric ''PathItem
1216+deriveGeneric ''Response
1217+deriveGeneric ''Responses
1218+deriveGeneric ''SecurityScheme
1219+deriveGeneric ''Schema
1220+deriveGeneric ''ParamSchema
1221+deriveGeneric ''Swagger
src/Data/Swagger/Internal/AesonUtils.hsnew file+94
@@ -0,0 +1,94 @@
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE FlexibleContexts #-}
3+{-# LANGUAGE GADTs #-}
4+{-# LANGUAGE ScopedTypeVariables #-}
5+{-# LANGUAGE ExplicitForAll #-}
6+{-# LANGUAGE TemplateHaskell #-}
7+module Data.Swagger.Internal.AesonUtils (
8+ -- * Generic functions
9+ sopSwaggerGenericToJSON,
10+ -- * Options
11+ SwaggerAesonOptions,
12+ mkSwaggerAesonOptions,
13+ saoPrefix,
14+ saoAdditionalPairs,
15+ saoSubObject,
16+ ) where
17+
18+import Prelude ()
19+import Prelude.Compat
20+
21+import Control.Lens (makeLenses, (^.))
22+import Data.Aeson (ToJSON(..), Value(..), object)
23+import Data.Text (Text)
24+import Data.Char (toLower, isUpper)
25+
26+import Generics.SOP
27+
28+import qualified Data.Text as T
29+import qualified Data.HashMap.Strict as HM
30+
31+-------------------------------------------------------------------------------
32+-- SwaggerAesonOptions
33+-------------------------------------------------------------------------------
34+
35+data SwaggerAesonOptions = SwaggerAesonOptions
36+ { _saoPrefix :: String
37+ , _saoAdditionalPairs :: [(Text, Value)]
38+ , _saoSubObject :: Maybe String
39+ }
40+
41+mkSwaggerAesonOptions
42+ :: String -- ^ prefix
43+ -> SwaggerAesonOptions
44+mkSwaggerAesonOptions pfx = SwaggerAesonOptions pfx [] Nothing
45+
46+makeLenses ''SwaggerAesonOptions
47+
48+-------------------------------------------------------------------------------
49+-- Generics
50+-------------------------------------------------------------------------------
51+
52+-- | Generic serialisation for swagger records.
53+--
54+-- Features
55+--
56+-- * omits nulls, empty objects and empty arrays (configurable)
57+-- * possible to add fields
58+-- * possible to merge sub-object
59+sopSwaggerGenericToJSON
60+ :: forall a xs. (Generic a, HasDatatypeInfo a, All2 ToJSON (Code a), Code a ~ '[xs])
61+ => SwaggerAesonOptions
62+ -> a
63+ -> Value
64+sopSwaggerGenericToJSON opts x =
65+ let ps = sopSwaggerGenericToJSON' opts (from x) (datatypeInfo (Proxy :: Proxy a))
66+ in object (opts ^. saoAdditionalPairs ++ ps)
67+
68+sopSwaggerGenericToJSON' :: All2 ToJSON '[xs] => SwaggerAesonOptions -> SOP I '[xs] -> DatatypeInfo '[xs] -> [(Text, Value)]
69+sopSwaggerGenericToJSON' opts (SOP (Z fields)) (ADT _ _ (Record _ fieldsInfo :* Nil)) =
70+ sopSwaggerGenericToJSON'' opts fields fieldsInfo
71+
72+sopSwaggerGenericToJSON'' :: All ToJSON xs => SwaggerAesonOptions -> NP I xs -> NP FieldInfo xs -> [(Text, Value)]
73+sopSwaggerGenericToJSON'' (SwaggerAesonOptions prefix _ sub) = go
74+ where
75+ go :: All ToJSON ys => NP I ys -> NP FieldInfo ys -> [(Text, Value)]
76+ go Nil Nil = []
77+ go (I x :* xs) (FieldInfo name :* names)
78+ | Just name' == sub = case json of
79+ Object m -> HM.toList m ++ rest
80+ Null -> rest
81+ _ -> error $ "sopSwaggerGenericToJSON: subjson is not an object: " ++ show json
82+ | json == Null || json == Array mempty || json == Object mempty =
83+ rest
84+ | otherwise =
85+ (T.pack name', json) : rest
86+ where
87+ json = toJSON x
88+ name' = fieldNameModifier name
89+ rest = go xs names
90+
91+ fieldNameModifier = modifier . drop 1
92+ modifier = lowerFirstUppers . drop (length prefix)
93+ lowerFirstUppers s = map toLower x ++ y
94+ where (x, y) = span isUpper s
src/Data/Swagger/Internal/Utils.hs+5−16
@@ -87,23 +87,12 @@ parseOneOf xs js =
87 where
87 where
88 ys = zip (map toJSON xs) xs
88 ys = zip (map toJSON xs) xs
89
89
90−omitEmptiesExcept :: (Text -> Value -> Bool) -> Value -> Value
90+{-# DEPRECATED omitEmpties "will be removed" #-}
91−omitEmptiesExcept f (Object o) = Object (HashMap.filterWithKey nonEmpty o)
92− where
93− nonEmpty k js = f k js || (js /= Object mempty) && (js /= Array mempty) && (js /= Null)
94−omitEmptiesExcept _ js = js
95−
96omitEmpties :: Value -> Value
91omitEmpties :: Value -> Value
97−omitEmpties = omitEmptiesExcept (\_ _ -> False)
92+omitEmpties (Object o) = Object (HashMap.filter nonEmpty o)
98−
93+ where
99−genericToJSONWithSub :: (Generic a, GToJSON (Rep a)) => Text -> Options -> a -> Value
94+ nonEmpty js = (js /= Object mempty) && (js /= Array mempty) && (js /= Null)
100−genericToJSONWithSub sub opts x =
95+omitEmpties js = js
101− case genericToJSON opts x of
102− Object o ->
103− case HashMap.lookup sub o of
104− Just so -> Object (HashMap.delete sub o) <+> so
105− Nothing -> Object o -- no subjson, leaving object as is
106− _ -> error "genericToJSONWithSub: subjson is not an object"
107
96
108genericParseJSONWithSub :: (Generic a, GFromJSON (Rep a)) => Text -> Options -> Value -> Parser a
97genericParseJSONWithSub :: (Generic a, GFromJSON (Rep a)) => Text -> Options -> Value -> Parser a
109genericParseJSONWithSub sub opts js@(Object o)
98genericParseJSONWithSub sub opts js@(Object o)
swagger2.cabal+3
@@ -38,11 +38,14 @@ library
38 Data.Swagger.Internal.Schema.Validation
38 Data.Swagger.Internal.Schema.Validation
39 Data.Swagger.Internal.ParamSchema
39 Data.Swagger.Internal.ParamSchema
40 Data.Swagger.Internal.Utils
40 Data.Swagger.Internal.Utils
41+ Data.Swagger.Internal.AesonUtils
41 build-depends: base >=4.7 && <4.10
42 build-depends: base >=4.7 && <4.10
42 , base-compat >=0.6.0 && <0.10
43 , base-compat >=0.6.0 && <0.10
43 , aeson
44 , aeson
44 , containers
45 , containers
45 , hashable
46 , hashable
47+ , generics-sop >=0.2 && <0.3
48+ , generics-sop-lens >=0.1.0.0 && <0.2
46 , http-media
49 , http-media
47 , insert-ordered-containers >=0.1.0.0 && <0.2
50 , insert-ordered-containers >=0.1.0.0 && <0.2
48 , lens
51 , lens