@@ -21,15 +21,18 @@ import Prelude.Compat
2121import Control.Lens
2222import Data.Data.Lens (template)
2323
24+import Control.Applicative
2425import Control.Monad
2526import Control.Monad.Writer
2627import Data.Aeson
2728import Data.Char
2829import Data.Data (Data)
2930import Data.Foldable (traverse_)
31+import Data.Function (on)
3032import Data.HashMap.Strict (HashMap)
3133import 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
3336import Data.Int
3437import Data.IntSet (IntSet)
3538import Data.IntMap (IntMap)
@@ -286,6 +289,105 @@ passwordSchema = mempty
286289 & type_ .~ SwaggerString
287290 & format ?~ "password"
288291
292+-- | Make an unrestrictive sketch of a @'Schema'@ based on a @'ToJSON'@ instance.
293+-- Produced schema can be used for further refinement.
294+--
295+-- >>> encode $ sketchSchema "hello"
296+-- "{\"example\":\"hello\",\"type\":\"string\"}"
297+--
298+-- >>> encode $ sketchSchema (1, 2, 3)
299+-- "{\"example\":[1,2,3],\"items\":{\"type\":\"number\"},\"type\":\"array\"}"
300+--
301+-- >>> encode $ sketchSchema ("Jack", 25)
302+-- "{\"example\":[\"Jack\",25],\"items\":[{\"type\":\"string\"},{\"type\":\"number\"}],\"type\":\"array\"}"
303+--
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
310+ where
311+ sketch Null = go Null
312+ sketch js@(Bool _) = go js
313+ sketch js = go js & example ?~ js
314+
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)
324+ where
325+ ys = map go (V.toList xs)
326+ allSame = and ((zipWith (==)) ys (tail ys))
327+
328+ ischema = case ys of
329+ (z:zs) | allSame -> Just z
330+ _ -> Nothing
331+ go js@(Object o) = mempty
332+ & type_ .~ SwaggerObject
333+ & required .~ HashMap.keys o
334+ & properties .~ fmap (Inline . go) o
335+
336+-- | Make a restrictive sketch of a @'Schema'@ based on a @'ToJSON'@ instance.
337+-- Produced schema uses as much constraints as possible.
338+--
339+-- >>> encode $ sketchStrictSchema "hello"
340+-- "{\"maxLength\":5,\"pattern\":\"hello\",\"minLength\":5,\"type\":\"string\",\"enum\":[\"hello\"]}"
341+--
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]]}"
344+--
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]]}"
347+--
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
354+ where
355+ go Null = mempty & type_ .~ SwaggerNull
356+ go js@(Bool _) = mempty
357+ & type_ .~ SwaggerBoolean
358+ & enum_ ?~ [js]
359+ go js@(String s) = mempty
360+ & type_ .~ SwaggerString
361+ & maxLength ?~ fromIntegral (T.length s)
362+ & minLength ?~ fromIntegral (T.length s)
363+ & pattern ?~ s
364+ & enum_ ?~ [js]
365+ go js@(Number n) = mempty
366+ & type_ .~ SwaggerNumber
367+ & maximum_ ?~ n
368+ & minimum_ ?~ n
369+ & multipleOf ?~ n
370+ & enum_ ?~ [js]
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
377+ & enum_ ?~ [js]
378+ where
379+ sz = length xs
380+ allUnique = sz == HashSet.size (HashSet.fromList (V.toList xs))
381+ go js@(Object o) = mempty
382+ & type_ .~ SwaggerObject
383+ & required .~ names
384+ & properties .~ fmap (Inline . go) o
385+ & maxProperties ?~ fromIntegral (length names)
386+ & minProperties ?~ fromIntegral (length names)
387+ & enum_ ?~ [js]
388+ where
389+ names = HashMap.keys o
390+
289391class GToSchema (f :: * -> *) where
290392 gdeclareNamedSchema :: SchemaOptions -> proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
291393