@@ -27,6 +27,7 @@ import Control.Lens
2727import Control.Monad (when)
2828
2929import Data.Aeson hiding (Result)
30+import Data.Aeson.Encode.Pretty (encodePretty)
3031import Data.Foldable (for_, sequenceA_,
3132 traverse_)
3233import Data.HashMap.Strict (HashMap)
@@ -39,6 +40,8 @@ import Data.Proxy
3940import Data.Scientific (Scientific, isInteger)
4041import Data.Text (Text)
4142import qualified Data.Text as Text
43+import qualified Data.Text.Lazy as TL
44+import qualified Data.Text.Lazy.Encoding as TL
4245import Data.Vector (Vector)
4346import qualified Data.Vector as Vector
4447
@@ -54,18 +57,101 @@ import Data.Swagger.Lens
5457--
5558-- /NOTE:/ @'validateToJSON'@ does not perform string pattern validation.
5659-- See @'validateToJSONWithPatternChecker'@.
60+--
61+-- See 'renderValidationErrors' on how the output is structured.
62+validatePrettyToJSON :: forall a. (ToJSON a, ToSchema a) => a -> Maybe String
63+validatePrettyToJSON = renderValidationErrors validateToJSON
64+
65+-- | Variant of 'validatePrettyToJSON' with typed output.
5766validateToJSON :: forall a. (ToJSON a, ToSchema a) => a -> [ValidationError]
5867validateToJSON = validateToJSONWithPatternChecker (\_pattern _str -> True)
5968
6069-- | Validate @'ToJSON'@ instance matches @'ToSchema'@ for a given value and pattern checker.
6170-- This can be used with QuickCheck to ensure those instances are coherent.
6271--
63−-- For validation without patterns see @'validateToJSON'@.
72+-- For validation without patterns see @'validateToJSON'@. See also:
73+-- 'renderValidationErrors'.
6474validateToJSONWithPatternChecker :: forall a. (ToJSON a, ToSchema a) => (Pattern -> Text -> Bool) -> a -> [ValidationError]
6575validateToJSONWithPatternChecker checker = validateJSONWithPatternChecker checker defs sch . toJSON
6676 where
6777 (defs, sch) = runDeclare (declareSchema (Proxy :: Proxy a)) mempty
6878
79+-- | Pretty print validation errors
80+-- together with actual JSON and Swagger Schema
81+-- (using 'encodePretty').
82+--
83+-- >>> import Data.Aeson as Aeson
84+-- >>> import Data.Foldable (traverse_)
85+-- >>> import GHC.Generics
86+-- >>> data Phone = Phone { value :: String } deriving (Generic)
87+-- >>> data Person = Person { name :: String, phone :: Phone } deriving (Generic)
88+-- >>> instance ToJSON Person where toJSON p = object [ "name" Aeson..= name p ]
89+-- >>> instance ToSchema Phone
90+-- >>> instance ToSchema Person
91+-- >>> let person = Person { name = "John", phone = Phone "123456" }
92+-- >>> traverse_ putStrLn $ renderValidationErrors validateToJSON person
93+-- Validation against the schema fails:
94+-- * property "phone" is required, but not found in "{\"name\":\"John\"}"
95+-- <BLANKLINE>
96+-- JSON value:
97+-- {
98+-- "name": "John"
99+-- }
100+-- <BLANKLINE>
101+-- Swagger Schema:
102+-- {
103+-- "required": [
104+-- "name",
105+-- "phone"
106+-- ],
107+-- "type": "object",
108+-- "properties": {
109+-- "phone": {
110+-- "$ref": "#/definitions/Phone"
111+-- },
112+-- "name": {
113+-- "type": "string"
114+-- }
115+-- }
116+-- }
117+-- <BLANKLINE>
118+-- Swagger Description Context:
119+-- {
120+-- "Phone": {
121+-- "required": [
122+-- "value"
123+-- ],
124+-- "type": "object",
125+-- "properties": {
126+-- "value": {
127+-- "type": "string"
128+-- }
129+-- }
130+-- }
131+-- }
132+-- <BLANKLINE>
133+renderValidationErrors
134+ :: forall a. (ToJSON a, ToSchema a)
135+ => (a -> [ValidationError]) -> a -> Maybe String
136+renderValidationErrors f x =
137+ case f x of
138+ [] -> Nothing
139+ errors -> Just $ unlines
140+ [ "Validation against the schema fails:"
141+ , unlines (map (" * " ++) errors)
142+ , "JSON value:"
143+ , ppJSONString (toJSON x)
144+ , ""
145+ , "Swagger Schema:"
146+ , ppJSONString (toJSON schema_)
147+ , ""
148+ , "Swagger Description Context:"
149+ , ppJSONString (toJSON refs_)
150+ ]
151+ where
152+ ppJSONString = TL.unpack . TL.decodeUtf8 . encodePretty
153+ (refs_, schema_) = runDeclare (declareSchema (Proxy :: Proxy a)) mempty
154+
69155-- | Validate JSON @'Value'@ against Swagger @'Schema'@.
70156--
71157-- prop> validateJSON mempty (toSchema (Proxy :: Proxy Int)) (toJSON (x :: Int)) == []