forked from haskell-servant/servant-swagger
-
Notifications
You must be signed in to change notification settings - Fork 0
/
Test.hs
199 lines (188 loc) · 7.18 KB
/
Test.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
module Servant.Swagger.Internal.Test where
import Data.Aeson (ToJSON (..))
import Data.Aeson.Encode.Pretty (encodePretty)
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:
-- {
-- "required": [
-- "name",
-- "phone"
-- ],
-- "type": "object",
-- "properties": {
-- "phone": {
-- "type": "integer"
-- },
-- "name": {
-- "type": "string"
-- }
-- }
-- }
-- <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
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)