git.iko.soy/typeable/swagger2
on master help sign in
RFC: using generics-sop to derive some ToJSON instances
commite2a9cc2a964b98b70ac1d199fe8be60939b657c4 authorOleg Grenrus <oleg.grenrus@iki.fi> dateMon 7 Mar 2016, 00:49 (11 years ago) parentb982c7d
4 files changed+149−37
compare with master
unifiedsplit
src/Data/Swagger/Internal.hs+47−21 src/Data/Swagger/Internal/AesonUtils.hs+94 src/Data/Swagger/Internal/Utils.hs+5−16 swagger2.cabal+3
src/Data/Swagger/Internal.hs+47−21
@@ -12,12 +12,17 @@
1212{-# LANGUAGE ScopedTypeVariables #-}
1313{-# LANGUAGE StandaloneDeriving #-}
1414{-# LANGUAGE UndecidableInstances #-}
15+
16+{-# LANGUAGE DataKinds #-}
17+{-# LANGUAGE TypeFamilies #-}
18+{-# LANGUAGE TemplateHaskell #-}
1519#include "overlapping-compat.h"
1620module Data.Swagger.Internal where
1721
1822import Prelude ()
1923import Prelude.Compat
2024
25+import Control.Lens ((&), (.~), (?~))
2126import Control.Applicative
2227import Control.Monad
2328import Data.Aeson
@@ -41,6 +46,11 @@ import Text.Read (readMaybe)
4146import Data.HashMap.Strict.InsOrd (InsOrdHashMap)
4247import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
4348
49+import Generics.SOP.TH (deriveGeneric)
50+import Data.Swagger.Internal.AesonUtils (sopSwaggerGenericToJSON
51+ ,mkSwaggerAesonOptions
52+ ,saoAdditionalPairs
53+ ,saoSubObject)
4454import Data.Swagger.Internal.Utils
4555
4656-- | A list of definitions that can be used in references.
@@ -921,7 +931,8 @@ instance ToJSON OAuth2Flow where
921931 , "tokenUrl" .= tokenUrl ]
922932
923933instance ToJSON OAuth2Params where
924− toJSON = omitEmpties . genericToJSONWithSub "flow" (jsonPrefix "oauth2")
934+ toJSON = sopSwaggerGenericToJSON $ mkSwaggerAesonOptions "oauth2" &
935+ saoSubObject ?~ "flow"
925936
926937instance ToJSON SecuritySchemeType where
927938 toJSON SecuritySchemeBasic
@@ -934,22 +945,20 @@ instance ToJSON SecuritySchemeType where
934945 <+> object [ "type" .= ("oauth2" :: Text) ]
935946
936947instance ToJSON Swagger where
937− toJSON = omitEmpties . addVersion . genericToJSON (jsonPrefix "swagger")
938− where
939− addVersion (Object o) = Object (HashMap.insert "swagger" "2.0" o)
940− addVersion _ = error "impossible"
948+ toJSON = sopSwaggerGenericToJSON $ mkSwaggerAesonOptions "swagger" &
949+ saoAdditionalPairs .~ [("swagger", "2.0")]
941950
942951instance ToJSON SecurityScheme where
943− toJSON = genericToJSONWithSub "type" (jsonPrefix "securityScheme")
952+ toJSON = sopSwaggerGenericToJSON $ mkSwaggerAesonOptions "securityScheme" &
953+ saoSubObject ?~ "type"
944954
945955instance ToJSON Schema where
946− toJSON = omitEmptiesExcept f . genericToJSONWithSub "paramSchema" (jsonPrefix "schema")
947− where
948− f "items" (Array _) = True
949− f _ _ = False
956+ toJSON = sopSwaggerGenericToJSON $ mkSwaggerAesonOptions "schema" &
957+ saoSubObject ?~ "paramSchema"
950958
951959instance ToJSON Header where
952− toJSON = genericToJSONWithSub "paramSchema" (jsonPrefix "header")
960+ toJSON = sopSwaggerGenericToJSON $ mkSwaggerAesonOptions "header" &
961+ saoSubObject ?~ "paramSchema"
953962
954963instance ToJSON (SwaggerItems t) where
955964 toJSON (SwaggerItemsPrimitive fmt schema) = object
@@ -968,26 +977,29 @@ instance ToJSON MimeList where
968977 toJSON (MimeList xs) = toJSON (map show xs)
969978
970979instance ToJSON Param where
971− toJSON = genericToJSONWithSub "schema" (jsonPrefix "param")
980+ toJSON = sopSwaggerGenericToJSON $ mkSwaggerAesonOptions "param" &
981+ saoSubObject ?~ "schema"
972982
973983instance ToJSON ParamAnySchema where
974984 toJSON (ParamBody s) = object [ "in" .= ("body" :: Text), "schema" .= s ]
975985 toJSON (ParamOther s) = toJSON s
976986
977987instance ToJSON ParamOtherSchema where
978− toJSON = genericToJSONWithSub "paramSchema" (jsonPrefix "paramOtherSchema")
988+ toJSON = sopSwaggerGenericToJSON $ mkSwaggerAesonOptions "paramOtherSchema" &
989+ saoSubObject ?~ "paramSchema"
979990
980991instance ToJSON Responses where
981− toJSON = omitEmpties . genericToJSONWithSub "responses" (jsonPrefix "responses")
992+ toJSON = sopSwaggerGenericToJSON $ mkSwaggerAesonOptions "responses" &
993+ saoSubObject ?~ "responses"
982994
983995instance ToJSON Response where
984− toJSON = omitEmpties . genericToJSON (jsonPrefix "response")
996+ toJSON = sopSwaggerGenericToJSON $ mkSwaggerAesonOptions "response"
985997
986998instance ToJSON Operation where
987− toJSON = omitEmpties . genericToJSON (jsonPrefix "operation")
999+ toJSON = sopSwaggerGenericToJSON $ mkSwaggerAesonOptions "operation"
9881000
9891001instance ToJSON PathItem where
990− toJSON = omitEmpties . genericToJSON (jsonPrefix "pathItem")
1002+ toJSON = sopSwaggerGenericToJSON $ mkSwaggerAesonOptions "pathItem"
9911003
9921004instance ToJSON Example where
9931005 toJSON = toJSON . Map.mapKeys show . getExample
@@ -1021,10 +1033,8 @@ instance ToJSON (CollectionFormat t) where
10211033 toJSON CollectionMulti = "multi"
10221034
10231035instance ToJSON (ParamSchema t) where
1024− toJSON = omitEmptiesExcept f . genericToJSONWithSub "items" (jsonPrefix "paramSchema")
1025− where
1026− f "items" (Array _) = True
1027− f _ _ = False
1036+ toJSON = sopSwaggerGenericToJSON $ mkSwaggerAesonOptions "paramSchema" &
1037+ saoSubObject ?~ "items"
10281038
10291039-- =======================================================================
10301040-- Manual FromJSON instances
@@ -1193,3 +1203,19 @@ instance FromJSON (CollectionFormat ParamOtherSchema) where
11931203instance (FromJSON (SwaggerType t), FromJSON (SwaggerItems t)) => FromJSON (ParamSchema t) where
11941204 parseJSON = genericParseJSONWithSub "items" (jsonPrefix "ParamSchema")
11951205
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 =
8787 where
8888 ys = zip (map toJSON xs) xs
8989
90−omitEmptiesExcept :: (Text -> Value -> Bool) -> Value -> Value
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−
90+{-# DEPRECATED omitEmpties "will be removed" #-}
9691omitEmpties :: Value -> Value
97−omitEmpties = omitEmptiesExcept (\_ _ -> False)
98−
99−genericToJSONWithSub :: (Generic a, GToJSON (Rep a)) => Text -> Options -> a -> Value
100−genericToJSONWithSub sub opts x =
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"
92+omitEmpties (Object o) = Object (HashMap.filter nonEmpty o)
93+ where
94+ nonEmpty js = (js /= Object mempty) && (js /= Array mempty) && (js /= Null)
95+omitEmpties js = js
10796
10897genericParseJSONWithSub :: (Generic a, GFromJSON (Rep a)) => Text -> Options -> Value -> Parser a
10998genericParseJSONWithSub sub opts js@(Object o)
swagger2.cabal+3
@@ -38,11 +38,14 @@ library
3838 Data.Swagger.Internal.Schema.Validation
3939 Data.Swagger.Internal.ParamSchema
4040 Data.Swagger.Internal.Utils
41+ Data.Swagger.Internal.AesonUtils
4142 build-depends: base >=4.7 && <4.10
4243 , base-compat >=0.6.0 && <0.10
4344 , aeson
4445 , containers
4546 , hashable
47+ , generics-sop >=0.2 && <0.3
48+ , generics-sop-lens >=0.1.0.0 && <0.2
4649 , http-media
4750 , insert-ordered-containers >=0.1.0.0 && <0.2
4851 , lens