Skip to content

Commit

Permalink
Merge pull request #164 from GetShopTV/inferred-schema-type
Browse files Browse the repository at this point in the history 
Allow omitting type and infer it when validating
  • Loading branch information
@phadej
phadej committed Apr 25, 2019
2 parents eaf9fc9 + 3e7b806 commit 6448fcf
Show file tree
Hide file tree
Showing 10 changed files with 217 additions and 139 deletions.
6 changes: 3 additions & 3 deletions src/Data/Swagger.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -181,7 +181,7 @@ import Data.Swagger.Internal
--
-- >>> :{
-- encode $ (mempty :: Swagger)
-- & definitions .~ [ ("User", mempty & type_ .~ SwaggerString) ]
-- & definitions .~ [ ("User", mempty & type_ ?~ SwaggerString) ]
-- & paths .~
-- [ ("/user", mempty & get ?~ (mempty
-- & produces ?~ MimeList ["application/json"]
Expand All @@ -204,7 +204,7 @@ import Data.Swagger.Internal
-- "{\"description\":\"No content\"}"
-- >>> :{
-- encode $ (mempty :: Schema)
-- & type_ .~ SwaggerBoolean
-- & type_ ?~ SwaggerBoolean
-- & description ?~ "To be or not to be"
-- :}
-- "{\"description\":\"To be or not to be\",\"type\":\"boolean\"}"
Expand All @@ -213,7 +213,7 @@ import Data.Swagger.Internal
-- So for convenience, all @'ParamSchema'@ fields are transitively made fields of the type that has it.
-- For example, you can use @'type_'@ to access @'SwaggerType'@ of @'Header'@ schema without having to use @'paramSchema'@:
--
-- >>> encode $ (mempty :: Header) & type_ .~ SwaggerNumber
-- >>> encode $ (mempty :: Header) & type_ ?~ SwaggerNumber
-- "{\"type\":\"number\"}"
--
-- Additionally, to simplify working with @'Response'@, both @'Operation'@ and @'Responses'@
Expand Down
2 changes: 1 addition & 1 deletion src/Data/Swagger/Internal.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -593,7 +593,7 @@ data ParamSchema (t :: SwaggerKind *) = ParamSchema
-- Unlike JSON Schema this value MUST conform to the defined type for this parameter.
_paramSchemaDefault :: Maybe Value

, _paramSchemaType :: SwaggerType t
, _paramSchemaType :: Maybe (SwaggerType t)
, _paramSchemaFormat :: Maybe Format
, _paramSchemaItems :: Maybe (SwaggerItems t)
, _paramSchemaMaximum :: Maybe Scientific
Expand Down
42 changes: 21 additions & 21 deletions src/Data/Swagger/Internal/ParamSchema.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -59,20 +59,20 @@ import GHC.TypeLits (TypeError, ErrorMessage(..))
-- | Default schema for binary data (any sequence of octets).
binaryParamSchema :: ParamSchema t
binaryParamSchema = mempty
& type_ .~ SwaggerString
& type_ ?~ SwaggerString
& format ?~ "binary"

-- | Default schema for binary data (base64 encoded).
byteParamSchema :: ParamSchema t
byteParamSchema = mempty
& type_ .~ SwaggerString
& type_ ?~ SwaggerString
& format ?~ "byte"

-- | Default schema for password string.
-- @"password"@ format is used to hint UIs the input needs to be obscured.
passwordParamSchema :: ParamSchema t
passwordParamSchema = mempty
& type_ .~ SwaggerString
& type_ ?~ SwaggerString
& format ?~ "password"

-- | Convert a type into a plain @'ParamSchema'@.
Expand All @@ -88,7 +88,7 @@ passwordParamSchema = mempty
--
-- instance ToParamSchema Direction where
-- toParamSchema _ = mempty
-- & type_ .~ SwaggerString
-- & type_ ?~ SwaggerString
-- & enum_ ?~ [ \"Up\", \"Down\" ]
-- @
--
Expand Down Expand Up @@ -120,17 +120,17 @@ class ToParamSchema a where
toParamSchema = genericToParamSchema defaultSchemaOptions

instance OVERLAPPING_ ToParamSchema String where
toParamSchema _ = mempty & type_ .~ SwaggerString
toParamSchema _ = mempty & type_ ?~ SwaggerString

instance ToParamSchema Bool where
toParamSchema _ = mempty & type_ .~ SwaggerBoolean
toParamSchema _ = mempty & type_ ?~ SwaggerBoolean

instance ToParamSchema Integer where
toParamSchema _ = mempty & type_ .~ SwaggerInteger
toParamSchema _ = mempty & type_ ?~ SwaggerInteger

instance ToParamSchema Natural where
toParamSchema _ = mempty
& type_ .~ SwaggerInteger
& type_ ?~ SwaggerInteger
& minimum_ ?~ 0
& exclusiveMinimum ?~ False

Expand All @@ -156,37 +156,37 @@ instance ToParamSchema Word64 where toParamSchema = toParamSchemaBoundedIntegral
-- "{\"maximum\":127,\"minimum\":-128,\"type\":\"integer\"}"
toParamSchemaBoundedIntegral :: forall a t. (Bounded a, Integral a) => Proxy a -> ParamSchema t
toParamSchemaBoundedIntegral _ = mempty
& type_ .~ SwaggerInteger
& type_ ?~ SwaggerInteger
& minimum_ ?~ fromInteger (toInteger (minBound :: a))
& maximum_ ?~ fromInteger (toInteger (maxBound :: a))

instance ToParamSchema Char where
toParamSchema _ = mempty
& type_ .~ SwaggerString
& type_ ?~ SwaggerString
& maxLength ?~ 1
& minLength ?~ 1

instance ToParamSchema Scientific where
toParamSchema _ = mempty & type_ .~ SwaggerNumber
toParamSchema _ = mempty & type_ ?~ SwaggerNumber

instance HasResolution a => ToParamSchema (Fixed a) where
toParamSchema _ = mempty
& type_ .~ SwaggerNumber
& type_ ?~ SwaggerNumber
& multipleOf ?~ (recip . fromInteger $ resolution (Proxy :: Proxy a))

instance ToParamSchema Double where
toParamSchema _ = mempty
& type_ .~ SwaggerNumber
& type_ ?~ SwaggerNumber
& format ?~ "double"

instance ToParamSchema Float where
toParamSchema _ = mempty
& type_ .~ SwaggerNumber
& type_ ?~ SwaggerNumber
& format ?~ "float"

timeParamSchema :: String -> ParamSchema t
timeParamSchema fmt = mempty
& type_ .~ SwaggerString
& type_ ?~ SwaggerString
& format ?~ T.pack fmt

-- | Format @"date"@ corresponds to @yyyy-mm-dd@ format.
Expand Down Expand Up @@ -222,12 +222,12 @@ instance ToParamSchema TL.Text where

instance ToParamSchema Version where
toParamSchema _ = mempty
& type_ .~ SwaggerString
& type_ ?~ SwaggerString
& pattern ?~ "^\\d+(\\.\\d+)*$"

instance ToParamSchema SetCookie where
toParamSchema _ = mempty
& type_ .~ SwaggerString
& type_ ?~ SwaggerString


#if __GLASGOW_HASKELL__ < 800
Expand All @@ -254,7 +254,7 @@ instance ToParamSchema a => ToParamSchema (Identity a) where toParamSchema _ = t

instance ToParamSchema a => ToParamSchema [a] where
toParamSchema _ = mempty
& type_ .~ SwaggerArray
& type_ ?~ SwaggerArray
& items ?~ SwaggerItemsPrimitive Nothing (toParamSchema (Proxy :: Proxy a))

instance ToParamSchema a => ToParamSchema (V.Vector a) where toParamSchema _ = toParamSchema (Proxy :: Proxy [a])
Expand All @@ -274,12 +274,12 @@ instance ToParamSchema a => ToParamSchema (HashSet a) where
-- "{\"type\":\"string\",\"enum\":[\"_\"]}"
instance ToParamSchema () where
toParamSchema _ = mempty
& type_ .~ SwaggerString
& type_ ?~ SwaggerString
& enum_ ?~ ["_"]

instance ToParamSchema UUID where
toParamSchema _ = mempty
& type_ .~ SwaggerString
& type_ ?~ SwaggerString
& format ?~ "uuid"

-- | A configurable generic @'ParamSchema'@ creator.
Expand Down Expand Up @@ -317,7 +317,7 @@ instance (GEnumParamSchema f, GEnumParamSchema g) => GEnumParamSchema (f :+: g)

instance Constructor c => GEnumParamSchema (C1 c U1) where
genumParamSchema opts _ s = s
& type_ .~ SwaggerString
& type_ ?~ SwaggerString
& enum_ %~ addEnumValue tag
where
tag = toJSON (constructorTagModifier opts (conName (Proxy3 :: Proxy3 c f p)))
Expand Down
56 changes: 28 additions & 28 deletions src/Data/Swagger/Internal/Schema.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -111,7 +111,7 @@ rename name (NamedSchema _ schema) = NamedSchema name schema
-- declareNamedSchema _ = do
-- doubleSchema <- declareSchemaRef (Proxy :: Proxy Double)
-- return $ NamedSchema (Just \"Coord\") $ mempty
-- & type_ .~ SwaggerObject
-- & type_ ?~ SwaggerObject
-- & properties .~
-- [ (\"x\", doubleSchema)
-- , (\"y\", doubleSchema)
Expand Down Expand Up @@ -294,20 +294,20 @@ inlineNonRecursiveSchemas defs = inlineSchemasWhen nonRecursive defs
-- | Default schema for binary data (any sequence of octets).
binarySchema :: Schema
binarySchema = mempty
& type_ .~ SwaggerString
& type_ ?~ SwaggerString
& format ?~ "binary"

-- | Default schema for binary data (base64 encoded).
byteSchema :: Schema
byteSchema = mempty
& type_ .~ SwaggerString
& type_ ?~ SwaggerString
& format ?~ "byte"

-- | Default schema for password string.
-- @"password"@ format is used to hint UIs the input needs to be obscured.
passwordSchema :: Schema
passwordSchema = mempty
& type_ .~ SwaggerString
& type_ ?~ SwaggerString
& format ?~ "password"

-- | Make an unrestrictive sketch of a @'Schema'@ based on a @'ToJSON'@ instance.
Expand All @@ -333,12 +333,12 @@ sketchSchema = sketch . toJSON
sketch js@(Bool _) = go js
sketch js = go js & example ?~ js

go Null = mempty & type_ .~ SwaggerNull
go (Bool _) = mempty & type_ .~ SwaggerBoolean
go (String _) = mempty & type_ .~ SwaggerString
go (Number _) = mempty & type_ .~ SwaggerNumber
go Null = mempty & type_ ?~ SwaggerNull
go (Bool _) = mempty & type_ ?~ SwaggerBoolean
go (String _) = mempty & type_ ?~ SwaggerString
go (Number _) = mempty & type_ ?~ SwaggerNumber
go (Array xs) = mempty
& type_ .~ SwaggerArray
& type_ ?~ SwaggerArray
& items ?~ case ischema of
Just s -> SwaggerItemsObject (Inline s)
_ -> SwaggerItemsArray (map Inline ys)
Expand All @@ -350,7 +350,7 @@ sketchSchema = sketch . toJSON
(z:_) | allSame -> Just z
_ -> Nothing
go (Object o) = mempty
& type_ .~ SwaggerObject
& type_ ?~ SwaggerObject
& required .~ HashMap.keys o
& properties .~ fmap (Inline . go) (InsOrdHashMap.fromHashMap o)

Expand All @@ -373,24 +373,24 @@ sketchSchema = sketch . toJSON
sketchStrictSchema :: ToJSON a => a -> Schema
sketchStrictSchema = go . toJSON
where
go Null = mempty & type_ .~ SwaggerNull
go Null = mempty & type_ ?~ SwaggerNull
go js@(Bool _) = mempty
& type_ .~ SwaggerBoolean
& type_ ?~ SwaggerBoolean
& enum_ ?~ [js]
go js@(String s) = mempty
& type_ .~ SwaggerString
& type_ ?~ SwaggerString
& maxLength ?~ fromIntegral (T.length s)
& minLength ?~ fromIntegral (T.length s)
& pattern ?~ s
& enum_ ?~ [js]
go js@(Number n) = mempty
& type_ .~ SwaggerNumber
& type_ ?~ SwaggerNumber
& maximum_ ?~ n
& minimum_ ?~ n
& multipleOf ?~ n
& enum_ ?~ [js]
go js@(Array xs) = mempty
& type_ .~ SwaggerArray
& type_ ?~ SwaggerArray
& maxItems ?~ fromIntegral sz
& minItems ?~ fromIntegral sz
& items ?~ SwaggerItemsArray (map (Inline . go) (V.toList xs))
Expand All @@ -400,7 +400,7 @@ sketchStrictSchema = go . toJSON
sz = length xs
allUnique = sz == HashSet.size (HashSet.fromList (V.toList xs))
go js@(Object o) = mempty
& type_ .~ SwaggerObject
& type_ ?~ SwaggerObject
& required .~ names
& properties .~ fmap (Inline . go) (InsOrdHashMap.fromHashMap o)
& maxProperties ?~ fromIntegral (length names)
Expand All @@ -416,7 +416,7 @@ instance OVERLAPPABLE_ ToSchema a => ToSchema [a] where
declareNamedSchema _ = do
ref <- declareSchemaRef (Proxy :: Proxy a)
return $ unnamed $ mempty
& type_ .~ SwaggerArray
& type_ ?~ SwaggerArray
& items ?~ SwaggerItemsObject ref

instance OVERLAPPING_ ToSchema String where declareNamedSchema = plain . paramSchemaToSchema
Expand Down Expand Up @@ -466,7 +466,7 @@ instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f

timeSchema :: T.Text -> Schema
timeSchema fmt = mempty
& type_ .~ SwaggerString
& type_ ?~ SwaggerString
& format ?~ fmt

-- | Format @"date"@ corresponds to @yyyy-mm-dd@ format.
Expand Down Expand Up @@ -528,7 +528,7 @@ instance (ToJSONKey k, ToSchema k, ToSchema v) => ToSchema (Map k v) where
declareObjectMapSchema = do
schema <- declareSchemaRef (Proxy :: Proxy v)
return $ unnamed $ mempty
& type_ .~ SwaggerObject
& type_ ?~ SwaggerObject
& additionalProperties ?~ AdditionalPropertiesSchema schema

instance (ToJSONKey k, ToSchema k, ToSchema v) => ToSchema (HashMap k v) where
Expand All @@ -540,7 +540,7 @@ instance ToSchema a => ToSchema (Map String a) where
declareNamedSchema _ = do
schema <- declareSchemaRef (Proxy :: Proxy a)
return $ unnamed $ mempty
& type_ .~ SwaggerObject
& type_ ?~ SwaggerObject
& additionalProperties ?~ schema

instance ToSchema a => ToSchema (Map T.Text a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map String a))
Expand All @@ -554,7 +554,7 @@ instance ToSchema a => ToSchema (HashMap TL.Text a) where declareNamedSchema _ =

instance OVERLAPPING_ ToSchema Object where
declareNamedSchema _ = pure $ NamedSchema (Just "Object") $ mempty
& type_ .~ SwaggerObject
& type_ ?~ SwaggerObject
& description ?~ "Arbitrary JSON object."
& additionalProperties ?~ AdditionalPropertiesAllowed True

Expand Down Expand Up @@ -595,7 +595,7 @@ instance ToSchema a => ToSchema (Identity a) where declareNamedSchema _ = declar
-- "{\"maximum\":32767,\"minimum\":-32768,\"type\":\"integer\"}"
toSchemaBoundedIntegral :: forall a. (Bounded a, Integral a) => Proxy a -> Schema
toSchemaBoundedIntegral _ = mempty
& type_ .~ SwaggerInteger
& type_ ?~ SwaggerInteger
& minimum_ ?~ fromInteger (toInteger (minBound :: a))
& maximum_ ?~ fromInteger (toInteger (maxBound :: a))

Expand Down Expand Up @@ -641,7 +641,7 @@ declareSchemaBoundedEnumKeyMapping _ = case toJSONKey :: ToJSONKeyFunction key o
let allKeys = [minBound..maxBound :: key]
mkPair k = (keyToText k, valueRef)
return $ mempty
& type_ .~ SwaggerObject
& type_ ?~ SwaggerObject
& properties .~ InsOrdHashMap.fromList (map mkPair allKeys)

-- | A 'Schema' for a mapping with 'Bounded' 'Enum' keys.
Expand Down Expand Up @@ -715,7 +715,7 @@ paramSchemaToSchema proxy = mempty & paramSchema .~ toParamSchema proxy

nullarySchema :: Schema
nullarySchema = mempty
& type_ .~ SwaggerArray
& type_ ?~ SwaggerArray
& items ?~ SwaggerItemsArray []

gtoNamedSchema :: GToSchema f => SchemaOptions -> Proxy f -> NamedSchema
Expand Down Expand Up @@ -786,12 +786,12 @@ withFieldSchema opts _ isRequiredField schema = do
return $
if T.null fname
then schema
& type_ .~ SwaggerArray
& type_ ?~ SwaggerArray
& items %~ appendItem ref
& maxItems %~ Just . maybe 1 (+1) -- increment maxItems
& minItems %~ Just . maybe 1 (+1) -- increment minItems
else schema
& type_ .~ SwaggerObject
& type_ ?~ SwaggerObject
& properties . at fname ?~ ref
& if isRequiredField
then required %~ (++ [fname])
Expand Down Expand Up @@ -828,7 +828,7 @@ gdeclareNamedSumSchema opts proxy s
(sumSchema, All allNullary) = undeclare (runWriterT declareSumSchema)

toStringTag schema = mempty
& type_ .~ SwaggerString
& type_ ?~ SwaggerString
& enum_ ?~ map toJSON (schema ^.. properties.ifolded.asIndex)

type AllNullary = All
Expand All @@ -842,7 +842,7 @@ instance (GSumToSchema f, GSumToSchema g) => GSumToSchema (f :+: g) where
gsumConToSchemaWith :: forall c f. (GToSchema (C1 c f), Constructor c) =>
Referenced Schema -> SchemaOptions -> Proxy (C1 c f) -> Schema -> Schema
gsumConToSchemaWith ref opts _ schema = schema
& type_ .~ SwaggerObject
& type_ ?~ SwaggerObject
& properties . at tag ?~ ref
& maxProperties ?~ 1
& minProperties ?~ 1
Expand Down
Loading

0 comments on commit 6448fcf

Please sign in to comment.