Skip to content

Commit

Permalink
Add ToSchema Object instance (for aeson's Object)
Browse files Browse the repository at this point in the history
  • Loading branch information
@fizruk
fizruk committed Aug 1, 2018
1 parent 4cb12af commit d72466a
Show file tree
Hide file tree
Showing 4 changed files with 77 additions and 57 deletions.
8 changes: 7 additions & 1 deletion src/Data/Swagger/Internal/Schema.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -32,7 +32,7 @@ import Data.Data.Lens (template)

import Control.Monad
import Control.Monad.Writer
import Data.Aeson (ToJSON (..), ToJSONKey (..), ToJSONKeyFunction (..), Value (..))
import Data.Aeson (ToJSON (..), ToJSONKey (..), ToJSONKeyFunction (..), Value (..), Object(..))
import Data.Char
import Data.Data (Data)
import Data.Foldable (traverse_)
Expand Down Expand Up @@ -552,6 +552,12 @@ instance ToSchema a => ToSchema (HashMap TL.Text a) where declareNamedSchema _ =

#endif

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

instance ToSchema a => ToSchema (V.Vector a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a])
instance ToSchema a => ToSchema (VU.Vector a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a])
instance ToSchema a => ToSchema (VS.Vector a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a])
Expand Down
3 changes: 1 addition & 2 deletions stack.yaml
View file
Original file line number Diff line number Diff line change
@@ -1,8 +1,7 @@
resolver: lts-11.4
resolver: lts-11.14
packages:
- '.'
extra-deps:
- aeson-1.3.1.0
- base-compat-0.10.1
- base-compat-batteries-0.10.1
- insert-ordered-containers-0.2.1.0
36 changes: 18 additions & 18 deletions test/Data/Swagger/CommonTestTypes.hs
View file
Original file line number Diff line number Diff line change
@@ -1,25 +1,25 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE QuasiQuotes #-}

module Data.Swagger.CommonTestTypes where

import Prelude ()
import Prelude.Compat

import Data.Aeson (Value, ToJSON(..), ToJSONKey(..))
import Data.Aeson.Types (toJSONKeyText)
import Data.Aeson.QQ
import Data.Char
import Data.Proxy
import Data.Set (Set)
import Data.Map (Map)
import qualified Data.Text as Text
import GHC.Generics

import Data.Swagger
import Data.Swagger.Declare
import Data.Swagger.Internal (SwaggerKind(..))
import Prelude ()
import Prelude.Compat

import Data.Aeson (ToJSON (..), ToJSONKey (..), Value)
import Data.Aeson.QQ
import Data.Aeson.Types (toJSONKeyText)
import Data.Char
import Data.Map (Map)
import Data.Proxy
import Data.Set (Set)
import qualified Data.Text as Text
import GHC.Generics

import Data.Swagger
import Data.Swagger.Declare
import Data.Swagger.Internal (SwaggerKind (..))

-- ========================================================================
-- Unit type
Expand Down
87 changes: 51 additions & 36 deletions test/Data/Swagger/Schema/ValidationSpec.hs
View file
Original file line number Diff line number Diff line change
@@ -1,41 +1,41 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Data.Swagger.Schema.ValidationSpec where

import Control.Applicative
import Control.Lens ((&), (.~), (?~))
import Data.Aeson
import Data.Aeson.Types
import Data.Int
import Data.IntMap (IntMap)
import Data.Hashable (Hashable)
import "unordered-containers" Data.HashSet (HashSet)
import Control.Applicative
import Control.Lens ((&), (.~), (?~))
import Data.Aeson
import Data.Aeson.Types
import Data.Hashable (Hashable)
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import "unordered-containers" Data.HashSet (HashSet)
import qualified "unordered-containers" Data.HashSet as HashSet
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.List.NonEmpty.Compat (NonEmpty(..), nonEmpty)
import Data.Map (Map, fromList)
import Data.Monoid (mempty)
import Data.Proxy
import Data.Time
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import Data.Version (Version)
import Data.Set (Set)
import Data.Word
import GHC.Generics

import Data.Swagger
import Data.Swagger.Declare

import Test.Hspec
import Test.Hspec.QuickCheck
import Test.QuickCheck
import Test.QuickCheck.Instances ()
import Data.Int
import Data.IntMap (IntMap)
import Data.List.NonEmpty.Compat (NonEmpty (..), nonEmpty)
import Data.Map (Map, fromList)
import Data.Monoid (mempty)
import Data.Proxy
import Data.Set (Set)
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import Data.Time
import Data.Version (Version)
import Data.Word
import GHC.Generics

import Data.Swagger
import Data.Swagger.Declare

import Test.Hspec
import Test.Hspec.QuickCheck
import Test.QuickCheck
import Test.QuickCheck.Instances ()

shouldValidate :: (ToJSON a, ToSchema a) => Proxy a -> a -> Bool
shouldValidate _ x = validateToJSON x == []
Expand Down Expand Up @@ -83,6 +83,7 @@ spec = do
prop "(HashMap String Int)" $ shouldValidate (Proxy :: Proxy (HashMap String Int))
prop "(HashMap T.Text Int)" $ shouldValidate (Proxy :: Proxy (HashMap T.Text Int))
prop "(HashMap TL.Text Bool)" $ shouldValidate (Proxy :: Proxy (HashMap TL.Text Bool))
prop "Object" $ shouldValidate (Proxy :: Proxy Object)
prop "(Int, String, Double)" $ shouldValidate (Proxy :: Proxy (Int, String, Double))
prop "(Int, String, Double, [Int])" $ shouldValidate (Proxy :: Proxy (Int, String, Double, [Int]))
prop "(Int, String, Double, [Int], Int)" $ shouldValidate (Proxy :: Proxy (Int, String, Double, [Int], Int))
Expand Down Expand Up @@ -139,9 +140,9 @@ instance Arbitrary Color where
arbitrary = arbitraryBoundedEnum

invalidColorToJSON :: Color -> Value
invalidColorToJSON Red = toJSON "red"
invalidColorToJSON Green = toJSON "green"
invalidColorToJSON Blue = toJSON "blue"
invalidColorToJSON Red = toJSON "red"
invalidColorToJSON Green = toJSON "green"
invalidColorToJSON Blue = toJSON "blue"

-- ========================================================================
-- Paint (record with bounded enum property)
Expand Down Expand Up @@ -261,3 +262,17 @@ instance Arbitrary FreeForm where
instance Eq ZonedTime where
ZonedTime t (TimeZone x _ _) == ZonedTime t' (TimeZone y _ _) = t == t' && x == y

-- ========================================================================
-- Arbitrary instance for Data.Aeson.Value
-- ========================================================================

instance Arbitrary Value where
-- Weights are almost random
-- Uniform oneof tends not to build complex objects cause of recursive call.
arbitrary = resize 4 $ frequency

This comment has been minimized.

Sign in to view

Copy link
@phadej

phadej Aug 1, 2018

Collaborator

this is bad. One should use

scale (`div` 2) $ sized $ \n ->
    if n == 0
    then frequency _leafs
    else frequency $ _compound ++ _leafs

Then the internal size of Gen will decrease on each recursive call to arbitrary, and for zero size, we won't recurse at all

This comment has been minimized.

Sign in to view

Copy link
@fizruk

fizruk Aug 2, 2018

Author Member

@phadej I see, so is it okay to use something like this then? https://gist.github.com/chrisdone/7b0c4ebb5b9b94514959206df8992076

This comment has been minimized.

Sign in to view

Copy link
@phadej

phadej Aug 2, 2018

Collaborator

@fizruk yeah, that's essentially what I showed, and differs frequency vs. oneof
[ (3, Object <$> arbitrary)
, (3, Array <$> arbitrary)
, (3, String <$> arbitrary)
, (3, Number <$> arbitrary)
, (3, Bool <$> arbitrary)
, (1, return Null) ]

0 comments on commit d72466a

Please sign in to comment.