Skip to content

Commit 6586d27

Browse files
fizrukfizruk
authored
Merge pull request #84 from haskell-servant/neongreen-print-errors
Pretty print validation errors in validateEveryToJSON
2 parents f00aacc + d15f767 commit 6586d27

File tree

11 files changed

+178
-103
lines changed

11 files changed

+178
-103
lines changed

‎CHANGELOG.md

Lines changed: 6 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1,3 +1,9 @@
1+
next
2+
-----
3+
4+
* Fixes:
5+
* `validateEveryToJSON` now prints validation errors
6+
17
1.1.5
28
-----
39

‎servant-swagger.cabal

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -73,6 +73,7 @@ library
7373
Servant.Swagger.Internal.TypeLevel.TMap
7474
hs-source-dirs: src
7575
build-depends: aeson >=0.11.2.0 && <1.5
76+
, aeson-pretty >=0.4 && <0.9
7677
, base >=4.7.0.0 && <4.12
7778
, bytestring >=0.10.4.0 && <0.11
7879
, http-media >=0.6.3 && <0.8

‎src/Servant/Swagger/Internal.hs

Lines changed: 37 additions & 36 deletions
Original file line numberDiff line numberDiff line change
@@ -1,13 +1,13 @@
1-
{-# LANGUAGE CPP #-}
2-
{-# LANGUAGE DataKinds #-}
3-
{-# LANGUAGE FlexibleContexts #-}
4-
{-# LANGUAGE FlexibleInstances #-}
5-
{-# LANGUAGE OverloadedStrings #-}
6-
{-# LANGUAGE PolyKinds #-}
7-
{-# LANGUAGE RankNTypes #-}
8-
{-# LANGUAGE ScopedTypeVariables #-}
9-
{-# LANGUAGE TypeOperators #-}
10-
{-# LANGUAGE ConstraintKinds #-}
1+
{-# LANGUAGE CPP #-}
2+
{-# LANGUAGE ConstraintKinds #-}
3+
{-# LANGUAGE DataKinds #-}
4+
{-# LANGUAGE FlexibleContexts #-}
5+
{-# LANGUAGE FlexibleInstances #-}
6+
{-# LANGUAGE OverloadedStrings #-}
7+
{-# LANGUAGE PolyKinds #-}
8+
{-# LANGUAGE RankNTypes #-}
9+
{-# LANGUAGE ScopedTypeVariables #-}
10+
{-# LANGUAGE TypeOperators #-}
1111
#if __GLASGOW_HASKELL__ >= 710
1212
#define OVERLAPPABLE_ {-# OVERLAPPABLE #-}
1313
#else
@@ -16,25 +16,26 @@
1616
#endif
1717
module Servant.Swagger.Internal where
1818

19-
import Control.Lens
20-
import Data.Aeson
21-
import Data.Monoid
22-
import Data.Proxy
23-
import qualified Data.Swagger as Swagger
24-
import Data.Swagger hiding (Header)
25-
import Data.Swagger.Declare
26-
import Data.HashMap.Strict.InsOrd (InsOrdHashMap)
27-
import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
28-
import Data.Text (Text)
29-
import qualified Data.Text as Text
30-
import GHC.TypeLits
31-
import Network.HTTP.Media (MediaType)
32-
import Servant.API
33-
import Servant.API.Description (FoldDescription, reflectDescription)
34-
import Servant.API.Modifiers (FoldRequired)
35-
import Data.Singletons.Bool
36-
37-
import Servant.Swagger.Internal.TypeLevel.API
19+
import Control.Lens
20+
import Data.Aeson
21+
import Data.HashMap.Strict.InsOrd (InsOrdHashMap)
22+
import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
23+
import Data.Monoid
24+
import Data.Proxy
25+
import Data.Singletons.Bool
26+
import Data.Swagger hiding (Header)
27+
import qualified Data.Swagger as Swagger
28+
import Data.Swagger.Declare
29+
import Data.Text (Text)
30+
import qualified Data.Text as Text
31+
import GHC.TypeLits
32+
import Network.HTTP.Media (MediaType)
33+
import Servant.API
34+
import Servant.API.Description (FoldDescription,
35+
reflectDescription)
36+
import Servant.API.Modifiers (FoldRequired)
37+
38+
import Servant.Swagger.Internal.TypeLevel.API
3839

3940
-- | Generate a Swagger specification for a servant API.
4041
--
@@ -119,15 +120,15 @@ mkEndpointWithSchemaRef :: forall cs hs proxy method status a.
119120
mkEndpointWithSchemaRef mref path _ = mempty
120121
& paths.at path ?~
121122
(mempty & method ?~ (mempty
122-
& produces ?~ MimeList contentTypes
123+
& produces ?~ MimeList responseContentTypes
123124
& at code ?~ Inline (mempty
124125
& schema .~ mref
125126
& headers .~ responseHeaders)))
126127
where
127-
method = swaggerMethod (Proxy :: Proxy method)
128-
code = fromIntegral (natVal (Proxy :: Proxy status))
129-
contentTypes = allContentType (Proxy :: Proxy cs)
130-
responseHeaders = toAllResponseHeaders (Proxy :: Proxy hs)
128+
method = swaggerMethod (Proxy :: Proxy method)
129+
code = fromIntegral (natVal (Proxy :: Proxy status))
130+
responseContentTypes = allContentType (Proxy :: Proxy cs)
131+
responseHeaders = toAllResponseHeaders (Proxy :: Proxy hs)
131132

132133
-- | Add parameter to every operation in the spec.
133134
addParam :: Param -> Swagger -> Swagger
@@ -355,9 +356,9 @@ instance AllToResponseHeader '[] where
355356
toAllResponseHeaders _ = mempty
356357

357358
instance (ToResponseHeader h, AllToResponseHeader hs) => AllToResponseHeader (h ': hs) where
358-
toAllResponseHeaders _ = InsOrdHashMap.insert hname header hdrs
359+
toAllResponseHeaders _ = InsOrdHashMap.insert headerName headerBS hdrs
359360
where
360-
(hname, header) = toResponseHeader (Proxy :: Proxy h)
361+
(headerName, headerBS) = toResponseHeader (Proxy :: Proxy h)
361362
hdrs = toAllResponseHeaders (Proxy :: Proxy hs)
362363

363364
instance AllToResponseHeader hs => AllToResponseHeader (HList hs) where

‎src/Servant/Swagger/Internal/Test.hs

Lines changed: 90 additions & 21 deletions
Original file line numberDiff line numberDiff line change
@@ -1,21 +1,27 @@
1-
{-# LANGUAGE DataKinds #-}
2-
{-# LANGUAGE FlexibleContexts #-}
3-
{-# LANGUAGE RankNTypes #-}
1+
{-# LANGUAGE ConstraintKinds #-}
2+
{-# LANGUAGE DataKinds #-}
3+
{-# LANGUAGE FlexibleContexts #-}
4+
{-# LANGUAGE RankNTypes #-}
45
{-# LANGUAGE ScopedTypeVariables #-}
5-
{-# LANGUAGE TypeOperators #-}
6-
{-# LANGUAGE ConstraintKinds #-}
6+
{-# LANGUAGE TypeOperators #-}
77
module Servant.Swagger.Internal.Test where
88

9-
import Data.Aeson (ToJSON)
10-
import Data.Swagger
11-
import Data.Text (Text)
12-
import Data.Typeable
13-
import Test.Hspec
14-
import Test.Hspec.QuickCheck
15-
import Test.QuickCheck (Arbitrary)
9+
import Data.Aeson (ToJSON (..))
10+
import Data.Aeson.Encode.Pretty (encodePretty)
11+
import Data.Swagger (Pattern, ToSchema,
12+
toSchema)
13+
import Data.Swagger.Schema.Validation
14+
import Data.Text (Text)
15+
import qualified Data.Text.Lazy as TL
16+
import qualified Data.Text.Lazy.Encoding as TL
17+
import Data.Typeable
18+
import Test.Hspec
19+
import Test.Hspec.QuickCheck
20+
import Test.QuickCheck (Arbitrary, Property,
21+
counterexample, property)
1622

17-
import Servant.API
18-
import Servant.Swagger.Internal.TypeLevel
23+
import Servant.API
24+
import Servant.Swagger.Internal.TypeLevel
1925

2026
-- $setup
2127
-- >>> import Control.Applicative
@@ -76,7 +82,7 @@ validateEveryToJSON :: forall proxy api. TMap (Every [Typeable, Show, Arbitrary,
7682
-> Spec
7783
validateEveryToJSON _ = props
7884
(Proxy :: Proxy [ToJSON, ToSchema])
79-
(null . validateToJSON)
85+
(maybeCounterExample . prettyValidateWith validateToJSON)
8086
(Proxy :: Proxy (BodyTypes JSON api))
8187

8288
-- | Verify that every type used with @'JSON'@ content type in a servant API
@@ -89,7 +95,7 @@ validateEveryToJSONWithPatternChecker :: forall proxy api. TMap (Every [Typeable
8995
-> Spec
9096
validateEveryToJSONWithPatternChecker checker _ = props
9197
(Proxy :: Proxy [ToJSON, ToSchema])
92-
(null . validateToJSONWithPatternChecker checker)
98+
(maybeCounterExample . prettyValidateWith (validateToJSONWithPatternChecker checker))
9399
(Proxy :: Proxy (BodyTypes JSON api))
94100

95101
-- * QuickCheck-related stuff
@@ -102,7 +108,7 @@ validateEveryToJSONWithPatternChecker checker _ = props
102108
-- context "read . show == id" $
103109
-- props
104110
-- (Proxy :: Proxy [Eq, Show, Read])
105-
-- (\x -> read (show x) == x)
111+
-- (\x -> read (show x) === x)
106112
-- (Proxy :: Proxy [Bool, Int, String])
107113
-- :}
108114
-- <BLANKLINE>
@@ -116,15 +122,78 @@ validateEveryToJSONWithPatternChecker checker _ = props
116122
-- Finished in ... seconds
117123
-- 3 examples, 0 failures
118124
props :: forall p p'' cs xs. TMap (Every (Typeable ': Show ': Arbitrary ': cs)) xs =>
119-
p cs -- ^ A list of constraints.
120-
-> (forall x. EveryTF cs x => x -> Bool) -- ^ Property predicate.
121-
-> p'' xs -- ^ A list of types.
125+
p cs -- ^ A list of constraints.
126+
-> (forall x. EveryTF cs x => x -> Property) -- ^ Property predicate.
127+
-> p'' xs -- ^ A list of types.
122128
-> Spec
123129
props _ f px = sequence_ specs
124130
where
125131
specs :: [Spec]
126132
specs = tmapEvery (Proxy :: Proxy (Typeable ': Show ': Arbitrary ': cs)) aprop px
127133

128134
aprop :: forall p' a. (EveryTF cs a, Typeable a, Show a, Arbitrary a) => p' a -> Spec
129-
aprop _ = prop (show (typeOf (undefined :: a))) (f :: a -> Bool)
135+
aprop _ = prop (show (typeOf (undefined :: a))) (f :: a -> Property)
130136

137+
-- | Pretty print validation errors
138+
-- together with actual JSON and Swagger Schema
139+
-- (using 'encodePretty').
140+
--
141+
-- >>> import Data.Aeson
142+
-- >>> import Data.Foldable (traverse_)
143+
-- >>> data Person = Person { name :: String, phone :: Integer } deriving (Generic)
144+
-- >>> instance ToJSON Person where toJSON p = object [ "name" .= name p ]
145+
-- >>> instance ToSchema Person
146+
-- >>> let person = Person { name = "John", phone = 123456 }
147+
-- >>> traverse_ putStrLn $ prettyValidateWith validateToJSON person
148+
-- Validation against the schema fails:
149+
-- * property "phone" is required, but not found in "{\"name\":\"John\"}"
150+
-- <BLANKLINE>
151+
-- JSON value:
152+
-- {
153+
-- "name": "John"
154+
-- }
155+
-- <BLANKLINE>
156+
-- Swagger Schema:
157+
-- {
158+
-- "required": [
159+
-- "name",
160+
-- "phone"
161+
-- ],
162+
-- "type": "object",
163+
-- "properties": {
164+
-- "phone": {
165+
-- "type": "integer"
166+
-- },
167+
-- "name": {
168+
-- "type": "string"
169+
-- }
170+
-- }
171+
-- }
172+
-- <BLANKLINE>
173+
--
174+
-- FIXME: this belongs in "Data.Swagger.Schema.Validation" (in @swagger2@).
175+
prettyValidateWith
176+
:: forall a. (ToJSON a, ToSchema a)
177+
=> (a -> [ValidationError]) -> a -> Maybe String
178+
prettyValidateWith f x =
179+
case f x of
180+
[] -> Nothing
181+
errors -> Just $ unlines
182+
[ "Validation against the schema fails:"
183+
, unlines (map (" * " ++) errors)
184+
, "JSON value:"
185+
, ppJSONString json
186+
, ""
187+
, "Swagger Schema:"
188+
, ppJSONString (toJSON schema)
189+
]
190+
where
191+
ppJSONString = TL.unpack . TL.decodeUtf8 . encodePretty
192+
193+
json = toJSON x
194+
schema = toSchema (Proxy :: Proxy a)
195+
196+
-- | Provide a counterexample if there is any.
197+
maybeCounterExample :: Maybe String -> Property
198+
maybeCounterExample Nothing = property True
199+
maybeCounterExample (Just s) = counterexample s (property False)

‎src/Servant/Swagger/Internal/TypeLevel.hs

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -4,6 +4,6 @@ module Servant.Swagger.Internal.TypeLevel (
44
module Servant.Swagger.Internal.TypeLevel.TMap,
55
) where
66

7-
import Servant.Swagger.Internal.TypeLevel.API
8-
import Servant.Swagger.Internal.TypeLevel.Every
9-
import Servant.Swagger.Internal.TypeLevel.TMap
7+
import Servant.Swagger.Internal.TypeLevel.API
8+
import Servant.Swagger.Internal.TypeLevel.Every
9+
import Servant.Swagger.Internal.TypeLevel.TMap

‎src/Servant/Swagger/Internal/TypeLevel/API.hs

Lines changed: 9 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -1,15 +1,15 @@
1-
{-# LANGUAGE ConstraintKinds #-}
2-
{-# LANGUAGE DataKinds #-}
3-
{-# LANGUAGE KindSignatures #-}
4-
{-# LANGUAGE PolyKinds #-}
5-
{-# LANGUAGE TypeFamilies #-}
6-
{-# LANGUAGE TypeOperators #-}
1+
{-# LANGUAGE ConstraintKinds #-}
2+
{-# LANGUAGE DataKinds #-}
3+
{-# LANGUAGE KindSignatures #-}
4+
{-# LANGUAGE PolyKinds #-}
5+
{-# LANGUAGE TypeFamilies #-}
6+
{-# LANGUAGE TypeOperators #-}
77
{-# LANGUAGE UndecidableInstances #-}
88
module Servant.Swagger.Internal.TypeLevel.API where
99

10-
import Data.Type.Bool (If)
11-
import Servant.API
12-
import GHC.Exts (Constraint)
10+
import Data.Type.Bool (If)
11+
import GHC.Exts (Constraint)
12+
import Servant.API
1313

1414
-- | Build a list of endpoints from an API.
1515
type family EndpointsList api where

‎src/Servant/Swagger/Internal/TypeLevel/Every.hs

Lines changed: 18 additions & 18 deletions
Original file line numberDiff line numberDiff line change
@@ -1,27 +1,27 @@
1-
{-# LANGUAGE CPP #-}
2-
{-# LANGUAGE ConstraintKinds #-}
3-
{-# LANGUAGE DataKinds #-}
4-
{-# LANGUAGE GADTs #-}
5-
{-# LANGUAGE FlexibleContexts #-}
6-
{-# LANGUAGE FlexibleInstances #-}
7-
{-# LANGUAGE InstanceSigs #-}
8-
{-# LANGUAGE KindSignatures #-}
9-
{-# LANGUAGE MultiParamTypeClasses #-}
10-
{-# LANGUAGE PolyKinds #-}
11-
{-# LANGUAGE RankNTypes #-}
12-
{-# LANGUAGE ScopedTypeVariables #-}
13-
{-# LANGUAGE TypeFamilies #-}
14-
{-# LANGUAGE TypeOperators #-}
15-
{-# LANGUAGE UndecidableInstances #-}
1+
{-# LANGUAGE CPP #-}
2+
{-# LANGUAGE ConstraintKinds #-}
3+
{-# LANGUAGE DataKinds #-}
4+
{-# LANGUAGE FlexibleContexts #-}
5+
{-# LANGUAGE FlexibleInstances #-}
6+
{-# LANGUAGE GADTs #-}
7+
{-# LANGUAGE InstanceSigs #-}
8+
{-# LANGUAGE KindSignatures #-}
9+
{-# LANGUAGE MultiParamTypeClasses #-}
10+
{-# LANGUAGE PolyKinds #-}
11+
{-# LANGUAGE RankNTypes #-}
12+
{-# LANGUAGE ScopedTypeVariables #-}
13+
{-# LANGUAGE TypeFamilies #-}
14+
{-# LANGUAGE TypeOperators #-}
15+
{-# LANGUAGE UndecidableInstances #-}
1616
#if __GLASGOW_HASKELL__ >= 800
1717
{-# LANGUAGE UndecidableSuperClasses #-}
1818
#endif
1919
module Servant.Swagger.Internal.TypeLevel.Every where
2020

21-
import Data.Proxy
22-
import GHC.Exts (Constraint)
21+
import Data.Proxy
22+
import GHC.Exts (Constraint)
2323

24-
import Servant.Swagger.Internal.TypeLevel.TMap
24+
import Servant.Swagger.Internal.TypeLevel.TMap
2525

2626
-- $setup
2727
-- >>> :set -XDataKinds

‎src/Servant/Swagger/Internal/TypeLevel/TMap.hs

Lines changed: 11 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -1,17 +1,17 @@
1-
{-# LANGUAGE ConstraintKinds #-}
2-
{-# LANGUAGE DataKinds #-}
3-
{-# LANGUAGE FlexibleInstances #-}
4-
{-# LANGUAGE KindSignatures #-}
1+
{-# LANGUAGE ConstraintKinds #-}
2+
{-# LANGUAGE DataKinds #-}
3+
{-# LANGUAGE FlexibleInstances #-}
4+
{-# LANGUAGE KindSignatures #-}
55
{-# LANGUAGE MultiParamTypeClasses #-}
6-
{-# LANGUAGE PolyKinds #-}
7-
{-# LANGUAGE RankNTypes #-}
8-
{-# LANGUAGE ScopedTypeVariables #-}
9-
{-# LANGUAGE TypeOperators #-}
10-
{-# LANGUAGE UndecidableInstances #-}
6+
{-# LANGUAGE PolyKinds #-}
7+
{-# LANGUAGE RankNTypes #-}
8+
{-# LANGUAGE ScopedTypeVariables #-}
9+
{-# LANGUAGE TypeOperators #-}
10+
{-# LANGUAGE UndecidableInstances #-}
1111
module Servant.Swagger.Internal.TypeLevel.TMap where
1212

13-
import Data.Proxy
14-
import GHC.Exts (Constraint)
13+
import Data.Proxy
14+
import GHC.Exts (Constraint)
1515

1616
-- $setup
1717
-- >>> :set -XDataKinds

‎src/Servant/Swagger/Test.hs

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -10,4 +10,4 @@ module Servant.Swagger.Test (
1010
validateEveryToJSONWithPatternChecker,
1111
) where
1212

13-
import Servant.Swagger.Internal.Test
13+
import Servant.Swagger.Internal.Test

‎src/Servant/Swagger/TypeLevel.hs

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -11,5 +11,5 @@ module Servant.Swagger.TypeLevel (
1111
BodyTypes,
1212
) where
1313

14-
import Servant.Swagger.Internal.TypeLevel
14+
import Servant.Swagger.Internal.TypeLevel
1515

0 commit comments

Comments
 (0)