diff --git a/src/Data/Swagger/Internal.hs b/src/Data/Swagger/Internal.hs index 2611b48..2d53112 100644 --- a/src/Data/Swagger/Internal.hs +++ b/src/Data/Swagger/Internal.hs @@ -496,6 +496,9 @@ data NamedSchema = NamedSchema , _namedSchemaSchema :: Schema } deriving (Eq, Show, Generic, Data, Typeable) +-- | Regex pattern for @string@ type. +type Pattern = Text + data ParamSchema t = ParamSchema { -- | Declares the value of the parameter that the server will use if none is provided, -- for example a @"count"@ to control the number of results per page might default to @100@ @@ -513,7 +516,7 @@ data ParamSchema t = ParamSchema , _paramSchemaExclusiveMinimum :: Maybe Bool , _paramSchemaMaxLength :: Maybe Integer , _paramSchemaMinLength :: Maybe Integer - , _paramSchemaPattern :: Maybe Text + , _paramSchemaPattern :: Maybe Pattern , _paramSchemaMaxItems :: Maybe Integer , _paramSchemaMinItems :: Maybe Integer , _paramSchemaUniqueItems :: Maybe Bool diff --git a/src/Data/Swagger/Internal/Schema/Validation.hs b/src/Data/Swagger/Internal/Schema/Validation.hs new file mode 100644 index 0000000..855a6ca --- /dev/null +++ b/src/Data/Swagger/Internal/Schema/Validation.hs @@ -0,0 +1,324 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} +-- | +-- Module: Data.Swagger.Internal.Schema.Validation +-- Copyright: (c) 2015 GetShopTV +-- License: BSD3 +-- Maintainer: Nickolay Kudasov +-- Stability: experimental +-- +-- Validate JSON values with Swagger Schema. +module Data.Swagger.Internal.Schema.Validation where + +import Control.Applicative +import Control.Lens +import Control.Lens.TH +import Control.Monad (when) + +import Data.Aeson hiding (Result) +import Data.Foldable (traverse_, for_, sequenceA_) +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap +import qualified "unordered-containers" Data.HashSet as HashSet +import Data.Monoid +import Data.Proxy +import Data.Scientific (Scientific, isInteger) +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Vector (Vector) +import qualified Data.Vector as Vector + +import Data.Swagger.Declare +import Data.Swagger.Internal +import Data.Swagger.Internal.Schema +import Data.Swagger.Lens + +-- | Validate @'ToJSON'@ instance matches @'ToSchema'@ for a given value. +-- This can be used with QuickCheck to ensure those instances are coherent: +-- +-- prop> validateToJSON (x :: Int) == [] +-- +-- /NOTE:/ @'validateToJSON'@ does not perform string pattern validation. +-- See @'validateToJSONWithPatternChecker'@. +validateToJSON :: forall a. (ToJSON a, ToSchema a) => a -> [ValidationError] +validateToJSON = validateToJSONWithPatternChecker (\_pattern _str -> True) + +-- | Validate @'ToJSON'@ instance matches @'ToSchema'@ for a given value and pattern checker. +-- This can be used with QuickCheck to ensure those instances are coherent. +-- +-- For validation without patterns see @'validateToJSON'@. +validateToJSONWithPatternChecker :: forall a. (ToJSON a, ToSchema a) => + (Pattern -> Text -> Bool) -> a -> [ValidationError] +validateToJSONWithPatternChecker checker x = case runValidation (validateWithSchema js) cfg schema of + Failed xs -> xs + Passed _ -> mempty + where + (defs, schema) = runDeclare (declareSchema (Proxy :: Proxy a)) mempty + js = toJSON x + cfg = defaultConfig + { configPatternChecker = checker + , configDefinitions = defs } + +-- | Validation error message. +type ValidationError = String + +-- | Validation result type. +data Result a + = Failed [ValidationError] -- ^ Validation failed with a list of error messages. + | Passed a -- ^ Validation passed. + deriving (Eq, Show, Functor) + +instance Applicative Result where + pure = Passed + Passed f <*> Passed x = Passed (f x) + Failed xs <*> Failed ys = Failed (xs <> ys) + Failed xs <*> _ = Failed xs + _ <*> Failed ys = Failed ys + +instance Alternative Result where + empty = Failed mempty + Passed x <|> _ = Passed x + _ <|> y = y + +instance Monad Result where + return = pure + Passed x >>= f = f x + Failed xs >>= f = Failed xs + +-- | Validation configuration. +data Config = Config + { -- | Pattern checker for @'_paramSchemaPattern'@ validation. + configPatternChecker :: Pattern -> Text -> Bool + -- | Schema definitions in scope to resolve references. + , configDefinitions :: Definitions Schema + } + +-- | Default @'Config'@: +-- +-- @ +-- defaultConfig = 'Config' +-- { 'configPatternChecker' = \\_pattern _str -> True +-- , 'configDefinitions' = mempty +-- } +-- @ +defaultConfig :: Config +defaultConfig = Config + { configPatternChecker = \_pattern _str -> True + , configDefinitions = mempty + } + +-- | Value validation. +newtype Validation s a = Validation { runValidation :: Config -> s -> Result a } + deriving (Functor) + +instance Applicative (Validation schema) where + pure x = Validation (\_ _ -> pure x) + Validation f <*> Validation x = Validation (\c s -> f c s <*> x c s) + +instance Alternative (Validation schema) where + empty = Validation (\_ _ -> empty) + Validation x <|> Validation y = Validation (\c s -> x c s <|> y c s) + +instance Profunctor Validation where + dimap f g (Validation k) = Validation (\c s -> fmap g (k c (f s))) + +instance Choice Validation where + left' (Validation g) = Validation (\c -> either (fmap Left . g c) (pure . Right)) + right' (Validation g) = Validation (\c -> either (pure . Left) (fmap Right . g c)) + +instance Monad (Validation s) where + return = pure + Validation x >>= f = Validation (\c s -> x c s >>= \x -> runValidation (f x) c s) + (>>) = (*>) + +withConfig :: (Config -> Validation s a) -> Validation s a +withConfig f = Validation (\c -> runValidation (f c) c) + +withSchema :: (s -> Validation s a) -> Validation s a +withSchema f = Validation (\c s -> runValidation (f s) c s) + +-- | Issue an error message. +invalid :: String -> Validation schema a +invalid msg = Validation (\_ _ -> Failed [msg]) + +-- | Validation passed. +valid :: Validation schema () +valid = pure () + +-- | Validate schema's property given a lens into that property +-- and property checker. +check :: Lens' s (Maybe a) -> (a -> Validation s ()) -> Validation s () +check l g = withSchema $ \schema -> + case schema ^. l of + Nothing -> valid + Just x -> g x + +-- | Validate same value with different schema. +sub :: t -> Validation t a -> Validation s a +sub = lmap . const + +-- | Validate same value with a part of the original schema. +sub_ :: Getting a s a -> Validation a r -> Validation s r +sub_ = lmap . view + +-- | Validate value against a schema given schema reference and validation function. +withRef :: Reference -> (Schema -> Validation s a) -> Validation s a +withRef (Reference ref) f = withConfig $ \cfg -> + case HashMap.lookup ref (configDefinitions cfg) of + Nothing -> invalid $ "unknown schema " ++ show ref + Just s -> f s + +validateWithSchemaRef :: Referenced Schema -> Value -> Validation s () +validateWithSchemaRef (Ref ref) js = withRef ref $ \schema -> sub schema (validateWithSchema js) +validateWithSchemaRef (Inline s) js = sub s (validateWithSchema js) + +-- | Validate JSON @'Value'@ with Swagger @'Schema'@. +validateWithSchema :: Value -> Validation Schema () +validateWithSchema value = do + validateSchemaType value + sub_ paramSchema $ validateEnum value + +-- | Validate JSON @'Value'@ with Swagger @'ParamSchema'@. +validateWithParamSchema :: Value -> Validation (ParamSchema t) () +validateWithParamSchema value = do + validateParamSchemaType value + validateEnum value + +validateInteger :: Scientific -> Validation (ParamSchema t) () +validateInteger n = do + when (not (isInteger n)) $ + invalid ("not an integer") + validateNumber n + +validateNumber :: Scientific -> Validation (ParamSchema t) () +validateNumber n = withConfig $ \cfg -> withSchema $ \schema -> do + let exMax = Just True == schema ^. exclusiveMaximum + exMin = Just True == schema ^. exclusiveMinimum + + check maximum_ $ \m -> + when (if exMax then (n >= m) else (n > m)) $ + invalid ("value " ++ show n ++ " exceeds maximum (should be " ++ if exMax then "<" else "<=" ++ show m ++ ")") + + check minimum_ $ \m -> + when (if exMin then (n <= m) else (n < m)) $ + invalid ("value " ++ show n ++ " falls below minimum (should be " ++ if exMin then ">" else ">=" ++ show m ++ ")") + + check multipleOf $ \k -> + when (not (isInteger (n / k))) $ + invalid ("expected a multiple of " ++ show k ++ " but got " ++ show n) + +validateString :: Text -> Validation (ParamSchema t) () +validateString s = do + check maxLength $ \n -> + when (len > fromInteger n) $ + invalid ("string is too long (length should be <=" ++ show n ++ ")") + + check minLength $ \n -> + when (len < fromInteger n) $ + invalid ("string is too short (length should be >=" ++ show n ++ ")") + + check pattern $ \regex -> do + withConfig $ \cfg -> do + when (not (configPatternChecker cfg regex s)) $ + invalid ("string does not match pattern " ++ show regex) + where + len = Text.length s + +validateArray :: Vector Value -> Validation (ParamSchema t) () +validateArray xs = do + check maxItems $ \n -> + when (len > fromInteger n) $ + invalid ("array exceeds maximum size (should be <=" ++ show n ++ ")") + + check minItems $ \n -> + when (len < fromInteger n) $ + invalid ("array is too short (size should be >=" ++ show n ++ ")") + + check items $ \case + SwaggerItemsPrimitive _ itemSchema -> sub itemSchema $ traverse_ validateWithParamSchema xs + SwaggerItemsObject itemSchema -> traverse_ (validateWithSchemaRef itemSchema) xs + SwaggerItemsArray itemSchemas -> do + when (len /= length itemSchemas) $ + invalid ("array size is invalid (should be exactly " ++ show (length itemSchemas) ++ ")") + sequenceA_ (zipWith validateWithSchemaRef itemSchemas (Vector.toList xs)) + + check uniqueItems $ \unique -> + when (unique && not allUnique) $ + invalid ("array is expected to contain unique items, but it does not") + where + len = Vector.length xs + allUnique = len == HashSet.size (HashSet.fromList (Vector.toList xs)) + +validateObject :: HashMap Text Value -> Validation Schema () +validateObject o = withSchema $ \schema -> + case schema ^. discriminator of + Just pname -> case fromJSON <$> HashMap.lookup pname o of + Just (Success ref) -> validateWithSchemaRef ref (Object o) + Just (Error msg) -> invalid ("failed to parse discriminator property " ++ show pname ++ ": " ++ show msg) + Nothing -> invalid ("discriminator property " ++ show pname ++ "is missing") + Nothing -> do + check maxProperties $ \n -> + when (size > n) $ + invalid ("object size exceeds maximum (total number of properties should be <=" ++ show n ++ ")") + + check minProperties $ \n -> + when (size < n) $ + invalid ("object size is too small (total number of properties should be >=" ++ show n ++ ")") + + validateRequired + validateProps + where + size = fromIntegral (HashMap.size o) + + validateRequired = withSchema $ \schema -> traverse_ validateReq (schema ^. required) + validateReq name = + when (not (HashMap.member name o)) $ + invalid ("property " ++ show name ++ " is required, but not found in " ++ show (encode o)) + + validateProps = withSchema $ \schema -> do + for_ (HashMap.toList o) $ \(k, v) -> + case v of + Null | not (k `elem` (schema ^. required)) -> valid -- null is fine for non-required property + _ -> + case HashMap.lookup k (schema ^. properties) of + Nothing -> check additionalProperties $ \s -> sub s $ validateWithSchema v + Just s -> validateWithSchemaRef s v + +validateEnum :: Value -> Validation (ParamSchema t) () +validateEnum value = do + check enum_ $ \xs -> + when (value `notElem` xs) $ + invalid ("expected one of " ++ show (encode xs) ++ " but got " ++ show value) + +validateSchemaType :: Value -> Validation Schema () +validateSchemaType value = withSchema $ \schema -> + case (schema ^. type_, value) of + (SwaggerNull, Null) -> valid + (SwaggerBoolean, Bool _) -> valid + (SwaggerInteger, Number n) -> sub_ paramSchema (validateInteger n) + (SwaggerNumber, Number n) -> sub_ paramSchema (validateNumber n) + (SwaggerString, String s) -> sub_ paramSchema (validateString s) + (SwaggerArray, Array xs) -> sub_ paramSchema (validateArray xs) + (SwaggerObject, Object o) -> validateObject o + (t, _) -> invalid $ "expected JSON value of type " ++ show t + +validateParamSchemaType :: Value -> Validation (ParamSchema t) () +validateParamSchemaType value = withSchema $ \schema -> + case (schema ^. type_, value) of + (SwaggerBoolean, Bool _) -> valid + (SwaggerInteger, Number n) -> validateInteger n + (SwaggerNumber, Number n) -> validateNumber n + (SwaggerString, String s) -> validateString s + (SwaggerArray, Array xs) -> validateArray xs + (t, _) -> invalid $ "expected JSON value of type " ++ show t + diff --git a/src/Data/Swagger/Lens.hs b/src/Data/Swagger/Lens.hs index 748ab03..f049e0b 100644 --- a/src/Data/Swagger/Lens.hs +++ b/src/Data/Swagger/Lens.hs @@ -83,10 +83,12 @@ instance At Responses where at n = responses . at n instance Ixed Operation where ix n = responses . ix n instance At Operation where at n = responses . at n +instance HasParamSchema NamedSchema (ParamSchema Schema) where paramSchema = schema.paramSchema + -- HasType instances instance HasType Header (SwaggerType Header) where type_ = paramSchema.type_ instance HasType Schema (SwaggerType Schema) where type_ = paramSchema.type_ -instance HasType NamedSchema (SwaggerType Schema) where type_ = schema.paramSchema.type_ +instance HasType NamedSchema (SwaggerType Schema) where type_ = paramSchema.type_ instance HasType ParamOtherSchema (SwaggerType ParamOtherSchema) where type_ = paramSchema.type_ -- HasDefault instances diff --git a/src/Data/Swagger/Schema/Validation.hs b/src/Data/Swagger/Schema/Validation.hs new file mode 100644 index 0000000..916a65b --- /dev/null +++ b/src/Data/Swagger/Schema/Validation.hs @@ -0,0 +1,83 @@ +-- | +-- Module: Data.Swagger.Schema.Validation +-- Copyright: (c) 2015 GetShopTV +-- License: BSD3 +-- Maintainer: Nickolay Kudasov +-- Stability: experimental +-- +-- Validate JSON values with Swagger Schema. +module Data.Swagger.Schema.Validation ( + -- * How to use validation + -- $howto + + -- ** Examples + -- $examples + + -- ** Validating @'Maybe'@ + -- $maybe + + -- * JSON validation + validateToJSON, + validateToJSONWithPatternChecker, + ValidationError, +) where + +import Data.Swagger.Internal.Schema.Validation + +-- $setup +-- >>> import Control.Lens +-- >>> import Data.Aeson +-- >>> import Data.Proxy +-- >>> import Data.Swagger +-- >>> import GHC.Generics +-- >>> :set -XDeriveGeneric + +-- $howto +-- +-- This module provides helpful functions for JSON validation. +-- These functions are meant to be used in test suites for your application +-- to ensure that JSON respresentation for your data corresponds to +-- schemas you're using for the Swagger specification. +-- +-- It is recommended to use validation functions as QuickCheck properties +-- (see ). + +-- $examples +-- +-- >>> validateToJSON "hello" +-- [] +-- +-- >>> validateToJSON False +-- [] +-- +-- >>> newtype Nat = Nat Integer deriving Generic +-- >>> instance ToJSON Nat where toJSON (Nat n) = toJSON n +-- >>> instance ToSchema Nat where declareNamedSchema proxy = genericDeclareNamedSchema defaultSchemaOptions proxy & mapped.minimum_ ?~ 0 +-- >>> validateToJSON (Nat 10) +-- [] +-- >>> validateToJSON (Nat (-5)) +-- ["value -5.0 falls below minimum (should be >=0.0)"] + +-- $maybe +-- +-- Because @'Maybe' a@ has the same schema as @a@, validation +-- generally fails for @null@ JSON: +-- +-- >>> validateToJSON (Nothing :: Maybe String) +-- ["expected JSON value of type SwaggerString"] +-- >>> validateToJSON ([Just "hello", Nothing] :: [Maybe String]) +-- ["expected JSON value of type SwaggerString"] +-- >>> validateToJSON (123, Nothing :: Maybe String) +-- ["expected JSON value of type SwaggerString"] +-- +-- However, when @'Maybe' a@ is a type of a record field, +-- validation takes @'required'@ property of the @'Schema'@ +-- into account: +-- +-- >>> data Person = Person { name :: String, age :: Maybe Int } deriving Generic +-- >>> instance ToJSON Person +-- >>> instance ToSchema Person +-- >>> validateToJSON (Person "John" (Just 25)) +-- [] +-- >>> validateToJSON (Person "John" Nothing) +-- [] diff --git a/stack.yaml b/stack.yaml index 2936480..1472a8d 100644 --- a/stack.yaml +++ b/stack.yaml @@ -2,4 +2,4 @@ flags: {} packages: - '.' extra-deps: [] -resolver: lts-3.22 +resolver: nightly-2016-01-26 diff --git a/swagger2.cabal b/swagger2.cabal index 72f900e..5bf3b19 100644 --- a/swagger2.cabal +++ b/swagger2.cabal @@ -28,11 +28,13 @@ library Data.Swagger.Lens Data.Swagger.ParamSchema Data.Swagger.Schema + Data.Swagger.Schema.Validation Data.Swagger.SchemaOptions -- internal modules Data.Swagger.Internal Data.Swagger.Internal.Schema + Data.Swagger.Internal.Schema.Validation Data.Swagger.Internal.ParamSchema Data.Swagger.Internal.Utils build-depends: base >=4.7 && <4.10 @@ -41,15 +43,16 @@ library , containers , hashable , http-media + , lens , mtl , network + , scientific , text , template-haskell , time , transformers , unordered-containers - , lens - , scientific + , vector default-language: Haskell2010 test-suite spec @@ -58,14 +61,17 @@ test-suite spec main-is: Spec.hs build-depends: base , base-compat - , swagger2 + , aeson + , aeson-qq + , containers + , hashable , hspec , HUnit + , mtl , QuickCheck + , swagger2 , text - , aeson - , aeson-qq - , containers + , time , unordered-containers , vector , lens @@ -73,6 +79,7 @@ test-suite spec SpecCommon Data.SwaggerSpec Data.Swagger.SchemaSpec + Data.Swagger.Schema.ValidationSpec default-language: Haskell2010 test-suite doctest diff --git a/test/Data/Swagger/Schema/ValidationSpec.hs b/test/Data/Swagger/Schema/ValidationSpec.hs new file mode 100644 index 0000000..16d1437 --- /dev/null +++ b/test/Data/Swagger/Schema/ValidationSpec.hs @@ -0,0 +1,213 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE PackageImports #-} +module Data.Swagger.Schema.ValidationSpec where + +import Control.Applicative +import Data.Aeson +import Data.Aeson.Types +import Data.Int +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap +import Data.IntSet (IntSet) +import Data.Hashable (Hashable) +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.Map (Map) +import qualified Data.Map as Map +import Data.Proxy +import Data.Time +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Word +import GHC.Generics + +import Data.Swagger +import Data.Swagger.Declare +import Data.Swagger.Schema.Validation + +import SpecCommon +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck + +shouldValidate :: (ToJSON a, ToSchema a) => Proxy a -> a -> Bool +shouldValidate _ x = validateToJSON x == [] + +spec :: Spec +spec = do + describe "Validation" $ do + prop "Bool" $ shouldValidate (Proxy :: Proxy Bool) + prop "Char" $ shouldValidate (Proxy :: Proxy Char) + prop "Double" $ shouldValidate (Proxy :: Proxy Double) + prop "Float" $ shouldValidate (Proxy :: Proxy Float) + prop "Int" $ shouldValidate (Proxy :: Proxy Int) + prop "Int8" $ shouldValidate (Proxy :: Proxy Int8) + prop "Int16" $ shouldValidate (Proxy :: Proxy Int16) + prop "Int32" $ shouldValidate (Proxy :: Proxy Int32) + prop "Int64" $ shouldValidate (Proxy :: Proxy Int64) + prop "Integer" $ shouldValidate (Proxy :: Proxy Integer) + prop "Word" $ shouldValidate (Proxy :: Proxy Word) + prop "Word8" $ shouldValidate (Proxy :: Proxy Word8) + prop "Word16" $ shouldValidate (Proxy :: Proxy Word16) + prop "Word32" $ shouldValidate (Proxy :: Proxy Word32) + prop "Word64" $ shouldValidate (Proxy :: Proxy Word64) + prop "String" $ shouldValidate (Proxy :: Proxy String) + prop "()" $ shouldValidate (Proxy :: Proxy ()) + prop "ZonedTime" $ shouldValidate (Proxy :: Proxy ZonedTime) + prop "UTCTime" $ shouldValidate (Proxy :: Proxy UTCTime) + prop "T.Text" $ shouldValidate (Proxy :: Proxy T.Text) + prop "TL.Text" $ shouldValidate (Proxy :: Proxy TL.Text) + prop "[String]" $ shouldValidate (Proxy :: Proxy [String]) + -- prop "(Maybe [Int])" $ shouldValidate (Proxy :: Proxy (Maybe [Int])) + prop "(IntMap String)" $ shouldValidate (Proxy :: Proxy (IntMap String)) + prop "(Set Bool)" $ shouldValidate (Proxy :: Proxy (Set Bool)) + prop "(HashSet Bool)" $ shouldValidate (Proxy :: Proxy (HashSet Bool)) + prop "(Either Int String)" $ shouldValidate (Proxy :: Proxy (Either Int String)) + prop "(Int, String)" $ shouldValidate (Proxy :: Proxy (Int, String)) + prop "(Map String Int)" $ shouldValidate (Proxy :: Proxy (Map String Int)) + prop "(Map T.Text Int)" $ shouldValidate (Proxy :: Proxy (Map T.Text Int)) + prop "(Map TL.Text Bool)" $ shouldValidate (Proxy :: Proxy (Map TL.Text Bool)) + 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 "(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)) + prop "Person" $ shouldValidate (Proxy :: Proxy Person) + prop "Color" $ shouldValidate (Proxy :: Proxy Color) + prop "Paint" $ shouldValidate (Proxy :: Proxy Paint) + prop "MyRoseTree" $ shouldValidate (Proxy :: Proxy MyRoseTree) + prop "Light" $ shouldValidate (Proxy :: Proxy Light) + +main :: IO () +main = hspec spec + +-- ======================================================================== +-- Person (simple record with optional fields) +-- ======================================================================== +data Person = Person + { name :: String + , phone :: Integer + , email :: Maybe String + } deriving (Show, Generic) + +instance ToJSON Person +instance ToSchema Person + +instance Arbitrary Person where + arbitrary = Person <$> arbitrary <*> arbitrary <*> arbitrary + +-- ======================================================================== +-- Color (enum) +-- ======================================================================== +data Color = Red | Green | Blue deriving (Show, Generic, Bounded, Enum) + +instance ToJSON Color +instance ToSchema Color + +instance Arbitrary Color where + arbitrary = arbitraryBoundedEnum + +-- ======================================================================== +-- Paint (record with bounded enum property) +-- ======================================================================== + +newtype Paint = Paint { color :: Color } + deriving (Show, Generic) + +instance ToJSON Paint +instance ToSchema Paint + +instance Arbitrary Paint where + arbitrary = Paint <$> arbitrary + +-- ======================================================================== +-- MyRoseTree (custom datatypeNameModifier) +-- ======================================================================== + +data MyRoseTree = MyRoseTree + { root :: String + , trees :: [MyRoseTree] + } deriving (Show, Generic) + +instance ToJSON MyRoseTree + +instance ToSchema MyRoseTree where + declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions + { datatypeNameModifier = drop (length "My") } + +instance Arbitrary MyRoseTree where + arbitrary = fmap (cut limit) $ MyRoseTree <$> arbitrary <*> (take limit <$> arbitrary) + where + limit = 4 + cut 0 (MyRoseTree x _ ) = MyRoseTree x [] + cut n (MyRoseTree x xs) = MyRoseTree x (map (cut (n - 1)) xs) + +-- ======================================================================== +-- Light (sum type) +-- ======================================================================== + +data Light = NoLight | LightFreq Double | LightColor Color deriving (Show, Generic) + +instance ToSchema Light + +instance ToJSON Light where + toJSON = genericToJSON defaultOptions { sumEncoding = ObjectWithSingleField } + +instance Arbitrary Light where + arbitrary = oneof + [ return NoLight + , LightFreq <$> arbitrary + , LightColor <$> arbitrary + ] + +-- Arbitrary instances for common types + +#if MIN_VERSION_QuickCheck(2,8,2) +#else +instance (Ord k, Arbitrary k, Arbitrary v) => Arbitrary (Map k v) where + arbitrary = Map.fromList <$> arbitrary + +instance Arbitrary a => Arbitrary (IntMap a) where + arbitrary = IntMap.fromList <$> arbitrary + +instance (Ord a, Arbitrary a) => Arbitrary (Set a) where + arbitrary = Set.fromList <$> arbitrary +#endif + +instance (Eq k, Hashable k, Arbitrary k, Arbitrary v) => Arbitrary (HashMap k v) where + arbitrary = HashMap.fromList <$> arbitrary + +instance (Eq a, Hashable a, Arbitrary a) => Arbitrary (HashSet a) where + arbitrary = HashSet.fromList <$> arbitrary + +instance Arbitrary T.Text where + arbitrary = T.pack <$> arbitrary + +instance Arbitrary TL.Text where + arbitrary = TL.pack <$> arbitrary + +instance Arbitrary Day where + arbitrary = liftA3 fromGregorian (fmap ((+ 1) . abs) arbitrary) arbitrary arbitrary + +instance Arbitrary LocalTime where + arbitrary = LocalTime + <$> arbitrary + <*> liftA3 TimeOfDay (choose (0, 23)) (choose (0, 59)) (fromInteger <$> choose (0, 60)) + +instance Eq ZonedTime where + ZonedTime t (TimeZone x _ _) == ZonedTime t' (TimeZone y _ _) = t == t' && x == y + +instance Arbitrary ZonedTime where + arbitrary = ZonedTime + <$> arbitrary + <*> liftA3 TimeZone arbitrary arbitrary (vectorOf 3 (elements ['A'..'Z'])) + +instance Arbitrary UTCTime where + arbitrary = UTCTime <$> arbitrary <*> fmap fromInteger (choose (0, 86400)) +