JSON validation based on Swagger Schema

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

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 <nickolay@getshoptv.com>
+-- 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
+

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