206 lines
7.4 KiB
Haskell
206 lines
7.4 KiB
Haskell
{-# LANGUAGE ConstraintKinds #-}
|
||
{-# LANGUAGE DataKinds #-}
|
||
{-# LANGUAGE FlexibleContexts #-}
|
||
{-# LANGUAGE RankNTypes #-}
|
||
{-# LANGUAGE ScopedTypeVariables #-}
|
||
{-# LANGUAGE TypeOperators #-}
|
||
{-# LANGUAGE OverloadedStrings #-}
|
||
module Servant.Swagger.Internal.Test where
|
||
|
||
import Data.Aeson (ToJSON (..))
|
||
import Data.Aeson.Encode.Pretty (encodePretty', defConfig,
|
||
confCompare)
|
||
import Data.Swagger (Pattern, ToSchema,
|
||
toSchema)
|
||
import Data.Swagger.Schema.Validation
|
||
import Data.Text (Text)
|
||
import qualified Data.Text.Lazy as TL
|
||
import qualified Data.Text.Lazy.Encoding as TL
|
||
import Data.Typeable
|
||
import Test.Hspec
|
||
import Test.Hspec.QuickCheck
|
||
import Test.QuickCheck (Arbitrary, Property,
|
||
counterexample, property)
|
||
|
||
import Servant.API
|
||
import Servant.Swagger.Internal.TypeLevel
|
||
|
||
-- $setup
|
||
-- >>> import Control.Applicative
|
||
-- >>> import GHC.Generics
|
||
-- >>> import Test.QuickCheck
|
||
-- >>> :set -XDeriveGeneric
|
||
-- >>> :set -XGeneralizedNewtypeDeriving
|
||
-- >>> :set -XDataKinds
|
||
-- >>> :set -XTypeOperators
|
||
|
||
-- | Verify that every type used with @'JSON'@ content type in a servant API
|
||
-- has compatible @'ToJSON'@ and @'ToSchema'@ instances using @'validateToJSON'@.
|
||
--
|
||
-- /NOTE:/ @'validateEveryToJSON'@ does not perform string pattern validation.
|
||
-- See @'validateEveryToJSONWithPatternChecker'@.
|
||
--
|
||
-- @'validateEveryToJSON'@ will produce one @'prop'@ specification for every type in the API.
|
||
-- Each type only gets one test, even if it occurs multiple times in the API.
|
||
--
|
||
-- >>> data User = User { name :: String, age :: Maybe Int } deriving (Show, Generic, Typeable)
|
||
-- >>> newtype UserId = UserId String deriving (Show, Generic, Typeable, ToJSON, Arbitrary)
|
||
-- >>> instance ToJSON User
|
||
-- >>> instance ToSchema User
|
||
-- >>> instance ToSchema UserId
|
||
-- >>> instance Arbitrary User where arbitrary = User <$> arbitrary <*> arbitrary
|
||
-- >>> type UserAPI = (Capture "user_id" UserId :> Get '[JSON] User) :<|> (ReqBody '[JSON] User :> Post '[JSON] UserId)
|
||
--
|
||
-- >>> hspec $ context "ToJSON matches ToSchema" $ validateEveryToJSON (Proxy :: Proxy UserAPI)
|
||
-- <BLANKLINE>
|
||
-- ToJSON matches ToSchema
|
||
-- User
|
||
-- ...
|
||
-- UserId
|
||
-- ...
|
||
-- Finished in ... seconds
|
||
-- 2 examples, 0 failures
|
||
--
|
||
-- For the test to compile all body types should have the following instances:
|
||
--
|
||
-- * @'ToJSON'@ and @'ToSchema'@ are used to perform the validation;
|
||
-- * @'Typeable'@ is used to name the test for each type;
|
||
-- * @'Show'@ is used to display value for which @'ToJSON'@ does not satisfy @'ToSchema'@.
|
||
-- * @'Arbitrary'@ is used to arbitrarily generate values.
|
||
--
|
||
-- If any of the instances is missing, you'll get a descriptive type error:
|
||
--
|
||
-- >>> data Contact = Contact { fullname :: String, phone :: Integer } deriving (Show, Generic)
|
||
-- >>> instance ToJSON Contact
|
||
-- >>> instance ToSchema Contact
|
||
-- >>> type ContactAPI = Get '[JSON] Contact
|
||
-- >>> hspec $ validateEveryToJSON (Proxy :: Proxy ContactAPI)
|
||
-- ...
|
||
-- ...No instance for (Arbitrary Contact)
|
||
-- ... arising from a use of ‘validateEveryToJSON’
|
||
-- ...
|
||
validateEveryToJSON
|
||
:: forall proxy api .
|
||
TMap (Every [Typeable, Show, Arbitrary, ToJSON, ToSchema])
|
||
(BodyTypes JSON api)
|
||
=> proxy api -- ^ Servant API.
|
||
-> Spec
|
||
validateEveryToJSON _ = props
|
||
(Proxy :: Proxy [ToJSON, ToSchema])
|
||
(maybeCounterExample . prettyValidateWith validateToJSON)
|
||
(Proxy :: Proxy (BodyTypes JSON api))
|
||
|
||
-- | Verify that every type used with @'JSON'@ content type in a servant API
|
||
-- has compatible @'ToJSON'@ and @'ToSchema'@ instances using @'validateToJSONWithPatternChecker'@.
|
||
--
|
||
-- For validation without patterns see @'validateEveryToJSON'@.
|
||
validateEveryToJSONWithPatternChecker :: forall proxy api. TMap (Every [Typeable, Show, Arbitrary, ToJSON, ToSchema]) (BodyTypes JSON api) =>
|
||
(Pattern -> Text -> Bool) -- ^ @'Pattern'@ checker.
|
||
-> proxy api -- ^ Servant API.
|
||
-> Spec
|
||
validateEveryToJSONWithPatternChecker checker _ = props
|
||
(Proxy :: Proxy [ToJSON, ToSchema])
|
||
(maybeCounterExample . prettyValidateWith (validateToJSONWithPatternChecker checker))
|
||
(Proxy :: Proxy (BodyTypes JSON api))
|
||
|
||
-- * QuickCheck-related stuff
|
||
|
||
-- | Construct property tests for each type in a list.
|
||
-- The name for each property is the name of the corresponding type.
|
||
--
|
||
-- >>> :{
|
||
-- hspec $
|
||
-- context "read . show == id" $
|
||
-- props
|
||
-- (Proxy :: Proxy [Eq, Show, Read])
|
||
-- (\x -> read (show x) === x)
|
||
-- (Proxy :: Proxy [Bool, Int, String])
|
||
-- :}
|
||
-- <BLANKLINE>
|
||
-- read . show == id
|
||
-- Bool
|
||
-- ...
|
||
-- Int
|
||
-- ...
|
||
-- [Char]
|
||
-- ...
|
||
-- Finished in ... seconds
|
||
-- 3 examples, 0 failures
|
||
props :: forall p p'' cs xs. TMap (Every (Typeable ': Show ': Arbitrary ': cs)) xs =>
|
||
p cs -- ^ A list of constraints.
|
||
-> (forall x. EveryTF cs x => x -> Property) -- ^ Property predicate.
|
||
-> p'' xs -- ^ A list of types.
|
||
-> Spec
|
||
props _ f px = sequence_ specs
|
||
where
|
||
specs :: [Spec]
|
||
specs = tmapEvery (Proxy :: Proxy (Typeable ': Show ': Arbitrary ': cs)) aprop px
|
||
|
||
aprop :: forall p' a. (EveryTF cs a, Typeable a, Show a, Arbitrary a) => p' a -> Spec
|
||
aprop _ = prop (show (typeOf (undefined :: a))) (f :: a -> Property)
|
||
|
||
-- | Pretty print validation errors
|
||
-- together with actual JSON and Swagger Schema
|
||
-- (using 'encodePretty').
|
||
--
|
||
-- >>> import Data.Aeson
|
||
-- >>> import Data.Foldable (traverse_)
|
||
-- >>> data Person = Person { name :: String, phone :: Integer } deriving (Generic)
|
||
-- >>> instance ToJSON Person where toJSON p = object [ "name" .= name p ]
|
||
-- >>> instance ToSchema Person
|
||
-- >>> let person = Person { name = "John", phone = 123456 }
|
||
-- >>> traverse_ putStrLn $ prettyValidateWith validateToJSON person
|
||
-- Validation against the schema fails:
|
||
-- * property "phone" is required, but not found in "{\"name\":\"John\"}"
|
||
-- <BLANKLINE>
|
||
-- JSON value:
|
||
-- {
|
||
-- "name": "John"
|
||
-- }
|
||
-- <BLANKLINE>
|
||
-- Swagger Schema:
|
||
-- {
|
||
-- "properties": {
|
||
-- "name": {
|
||
-- "type": "string"
|
||
-- },
|
||
-- "phone": {
|
||
-- "type": "integer"
|
||
-- }
|
||
-- },
|
||
-- "required": [
|
||
-- "name",
|
||
-- "phone"
|
||
-- ],
|
||
-- "type": "object"
|
||
-- }
|
||
-- <BLANKLINE>
|
||
--
|
||
-- FIXME: this belongs in "Data.Swagger.Schema.Validation" (in @swagger2@).
|
||
prettyValidateWith
|
||
:: forall a. (ToJSON a, ToSchema a)
|
||
=> (a -> [ValidationError]) -> a -> Maybe String
|
||
prettyValidateWith f x =
|
||
case f x of
|
||
[] -> Nothing
|
||
errors -> Just $ unlines
|
||
[ "Validation against the schema fails:"
|
||
, unlines (map (" * " ++) errors)
|
||
, "JSON value:"
|
||
, ppJSONString json
|
||
, ""
|
||
, "Swagger Schema:"
|
||
, ppJSONString (toJSON schema)
|
||
]
|
||
where
|
||
ppJSONString = TL.unpack . TL.decodeUtf8 . encodePretty' ppCfg
|
||
ppCfg = defConfig { confCompare = compare }
|
||
|
||
json = toJSON x
|
||
schema = toSchema (Proxy :: Proxy a)
|
||
|
||
-- | Provide a counterexample if there is any.
|
||
maybeCounterExample :: Maybe String -> Property
|
||
maybeCounterExample Nothing = property True
|
||
maybeCounterExample (Just s) = counterexample s (property False)
|