Skip to content

Commit

Permalink
Make schema type optional and infer it when validating
Browse files Browse the repository at this point in the history
  • Loading branch information
@fizruk
fizruk committed Aug 23, 2018
1 parent 8b7bf61 commit 5530096
Show file tree
Hide file tree
Showing 8 changed files with 126 additions and 91 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 @@ -590,7 +590,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
40 changes: 20 additions & 20 deletions src/Data/Swagger/Internal/ParamSchema.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -61,20 +61,20 @@ import GHC.TypeLits (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 @@ -90,7 +90,7 @@ passwordParamSchema = mempty
--
-- instance ToParamSchema Direction where
-- toParamSchema _ = mempty
-- & type_ .~ SwaggerString
-- & type_ ?~ SwaggerString
-- & enum_ ?~ [ \"Up\", \"Down\" ]
-- @
--
Expand Down Expand Up @@ -122,17 +122,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 @@ -158,37 +158,37 @@ instance ToParamSchema Word64 where toParamSchema = toParamSchemaBoundedIntegral
-- "{\"maximum\":127,\"minimum\":-128,\"type\":\"integer\"}"
toParamSchemaBoundedIntegral :: forall proxy 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 @@ -224,7 +224,7 @@ instance ToParamSchema TL.Text where

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

#if __GLASGOW_HASKELL__ < 800
Expand All @@ -251,7 +251,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 @@ -271,12 +271,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 @@ -314,7 +314,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 @@ -117,7 +117,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 @@ -300,20 +300,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 @@ -339,12 +339,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 @@ -356,7 +356,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 @@ -379,24 +379,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 @@ -406,7 +406,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 @@ -422,7 +422,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 @@ -472,7 +472,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 @@ -534,7 +534,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 @@ -546,7 +546,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 @@ -560,7 +560,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 @@ -601,7 +601,7 @@ instance ToSchema a => ToSchema (Identity a) where declareNamedSchema _ = declar
-- "{\"maximum\":32767,\"minimum\":-32768,\"type\":\"integer\"}"
toSchemaBoundedIntegral :: forall a proxy. (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 @@ -647,7 +647,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 @@ -722,7 +722,7 @@ paramSchemaToSchema _ = mempty & paramSchema .~ toParamSchema (Proxy :: Proxy a)

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

gtoNamedSchema :: GToSchema f => SchemaOptions -> proxy f -> NamedSchema
Expand Down Expand Up @@ -793,12 +793,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 @@ -835,7 +835,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 @@ -849,7 +849,7 @@ instance (GSumToSchema f, GSumToSchema g) => GSumToSchema (f :+: g) where
gsumConToSchemaWith :: forall c f proxy. (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 5530096

Please sign in to comment.