@@ -21,15 +21,18 @@ import Prelude.Compat
21import Control.Lens
21import Control.Lens
22import Data.Data.Lens (template)
22import Data.Data.Lens (template)
24+import Control.Applicative
24import Control.Monad
25import Control.Monad
25import Control.Monad.Writer
26import Control.Monad.Writer
26import Data.Aeson
27import Data.Aeson
27import Data.Char
28import Data.Char
28import Data.Data (Data)
29import Data.Data (Data)
29import Data.Foldable (traverse_)
30import Data.Foldable (traverse_)
31+import Data.Function (on)
30import Data.HashMap.Strict (HashMap)
32import Data.HashMap.Strict (HashMap)
31import qualified Data.HashMap.Strict as HashMap
33import qualified Data.HashMap.Strict as HashMap
32−import "unordered-containers" Data.HashSet (HashSet)
34+import "unordered-containers" Data.HashSet (HashSet)
35+import qualified "unordered-containers" Data.HashSet as HashSet
33import Data.Int
36import Data.Int
34import Data.IntSet (IntSet)
37import Data.IntSet (IntSet)
35import Data.IntMap (IntMap)
38import Data.IntMap (IntMap)
@@ -286,6 +289,105 @@ passwordSchema = mempty
286 & type_ .~ SwaggerString
289 & type_ .~ SwaggerString
287 & format ?~ "password"
290 & format ?~ "password"
292+-- | Make an unrestrictive sketch of a @'Schema'@ based on a @'ToJSON'@ instance.
293+-- Produced schema can be used for further refinement.
295+-- >>> encode $ sketchSchema "hello"
296+-- "{\"example\":\"hello\",\"type\":\"string\"}"
298+-- >>> encode $ sketchSchema (1, 2, 3)
299+-- "{\"example\":[1,2,3],\"items\":{\"type\":\"number\"},\"type\":\"array\"}"
301+-- >>> encode $ sketchSchema ("Jack", 25)
302+-- "{\"example\":[\"Jack\",25],\"items\":[{\"type\":\"string\"},{\"type\":\"number\"}],\"type\":\"array\"}"
304+-- >>> data Person = Person { name :: String, age :: Int } deriving (Generic)
305+-- >>> instance ToJSON Person
306+-- >>> encode $ sketchSchema (Person "Jack" 25)
307+-- "{\"example\":{\"age\":25,\"name\":\"Jack\"},\"required\":[\"age\",\"name\"],\"type\":\"object\",\"properties\":{\"age\":{\"type\":\"number\"},\"name\":{\"type\":\"string\"}}}"
308+sketchSchema :: ToJSON a => a -> Schema
309+sketchSchema = sketch . toJSON
311+ sketch Null = go Null
312+ sketch js@(Bool _) = go js
313+ sketch js = go js & example ?~ js
315+ go Null = mempty & type_ .~ SwaggerNull
316+ go js@(Bool _) = mempty & type_ .~ SwaggerBoolean
317+ go js@(String s) = mempty & type_ .~ SwaggerString
318+ go js@(Number n) = mempty & type_ .~ SwaggerNumber
319+ go js@(Array xs) = mempty
320+ & type_ .~ SwaggerArray
321+ & items ?~ case ischema of
322+ Just s -> SwaggerItemsObject (Inline s)
323+ _ -> SwaggerItemsArray (map Inline ys)
325+ ys = map go (V.toList xs)
326+ allSame = and ((zipWith (==)) ys (tail ys))
328+ ischema = case ys of
329+ (z:zs) | allSame -> Just z
331+ go js@(Object o) = mempty
332+ & type_ .~ SwaggerObject
333+ & required .~ HashMap.keys o
334+ & properties .~ fmap (Inline . go) o
336+-- | Make a restrictive sketch of a @'Schema'@ based on a @'ToJSON'@ instance.
337+-- Produced schema uses as much constraints as possible.
339+-- >>> encode $ sketchStrictSchema "hello"
340+-- "{\"maxLength\":5,\"pattern\":\"hello\",\"minLength\":5,\"type\":\"string\",\"enum\":[\"hello\"]}"
342+-- >>> encode $ sketchStrictSchema (1, 2, 3)
343+-- "{\"minItems\":3,\"uniqueItems\":true,\"items\":[{\"maximum\":1,\"minimum\":1,\"multipleOf\":1,\"type\":\"number\",\"enum\":[1]},{\"maximum\":2,\"minimum\":2,\"multipleOf\":2,\"type\":\"number\",\"enum\":[2]},{\"maximum\":3,\"minimum\":3,\"multipleOf\":3,\"type\":\"number\",\"enum\":[3]}],\"maxItems\":3,\"type\":\"array\",\"enum\":[[1,2,3]]}"
345+-- >>> encode $ sketchStrictSchema ("Jack", 25)
346+-- "{\"minItems\":2,\"uniqueItems\":true,\"items\":[{\"maxLength\":4,\"pattern\":\"Jack\",\"minLength\":4,\"type\":\"string\",\"enum\":[\"Jack\"]},{\"maximum\":25,\"minimum\":25,\"multipleOf\":25,\"type\":\"number\",\"enum\":[25]}],\"maxItems\":2,\"type\":\"array\",\"enum\":[[\"Jack\",25]]}"
348+-- >>> data Person = Person { name :: String, age :: Int } deriving (Generic)
349+-- >>> instance ToJSON Person
350+-- >>> encode $ sketchStrictSchema (Person "Jack" 25)
351+-- "{\"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\"]}}}"
352+sketchStrictSchema :: ToJSON a => a -> Schema
353+sketchStrictSchema = go . toJSON
355+ go Null = mempty & type_ .~ SwaggerNull
356+ go js@(Bool _) = mempty
357+ & type_ .~ SwaggerBoolean
359+ go js@(String s) = mempty
360+ & type_ .~ SwaggerString
361+ & maxLength ?~ fromIntegral (T.length s)
362+ & minLength ?~ fromIntegral (T.length s)
365+ go js@(Number n) = mempty
366+ & type_ .~ SwaggerNumber
371+ go js@(Array xs) = mempty
372+ & type_ .~ SwaggerArray
373+ & maxItems ?~ fromIntegral sz
374+ & minItems ?~ fromIntegral sz
375+ & items ?~ SwaggerItemsArray (map (Inline . go) (V.toList xs))
376+ & uniqueItems ?~ allUnique
380+ allUnique = sz == HashSet.size (HashSet.fromList (V.toList xs))
381+ go js@(Object o) = mempty
382+ & type_ .~ SwaggerObject
384+ & properties .~ fmap (Inline . go) o
385+ & maxProperties ?~ fromIntegral (length names)
386+ & minProperties ?~ fromIntegral (length names)
389+ names = HashMap.keys o
289class GToSchema (f :: * -> *) where
391class GToSchema (f :: * -> *) where
290 gdeclareNamedSchema :: SchemaOptions -> proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
392 gdeclareNamedSchema :: SchemaOptions -> proxy f -> Schema -> Declare (Definitions Schema) NamedSchema