{-# OPTIONS_GHC -Wall                  #-}
{-# LANGUAGE CPP                        #-}
{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE DeriveFunctor              #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE FunctionalDependencies     #-}
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE PackageImports             #-}
{-# LANGUAGE RankNTypes                 #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE TemplateHaskell            #-}
{-# LANGUAGE UndecidableInstances       #-}
{-# LANGUAGE ViewPatterns               #-}
-- |
-- Module:      Data.OpenApi.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.OpenApi.Internal.Schema.Validation where

import           Prelude                             ()
import           Prelude.Compat

import           Control.Applicative
import           Control.Lens                        hiding (allOf)
import           Control.Monad                       (forM, forM_, when)

import           Data.Aeson                          hiding (Result)
#if MIN_VERSION_aeson(2,0,0)
import qualified Data.Aeson.KeyMap as KeyMap
#endif
import           Data.Foldable                       (for_, sequenceA_,
                                                      traverse_)
#if !MIN_VERSION_aeson(2,0,0)
import           Data.HashMap.Strict                 (HashMap)
#endif
import qualified Data.HashMap.Strict.InsOrd          as InsOrdHashMap
import qualified "unordered-containers" Data.HashSet as HashSet
import           Data.Maybe                          (fromMaybe)
import           Data.Proxy
import           Data.Scientific                     (Scientific, isInteger)
import           Data.Text                           (Text)
import qualified Data.Text                           as Text
import qualified Data.Text.Lazy                      as TL
import qualified Data.Text.Lazy.Encoding             as TL
import           Data.Vector                         (Vector)
import qualified Data.Vector                         as Vector

import Data.OpenApi.Aeson.Compat    (hasKey, keyToText, lookupKey, objectToList)
import Data.OpenApi.Declare
import Data.OpenApi.Internal
import Data.OpenApi.Internal.Schema
import Data.OpenApi.Internal.Utils
import Data.OpenApi.Lens

-- $setup
-- >>> import Data.OpenApi.Internal.Schema.Validation

-- | 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'@.
--
-- See 'renderValidationErrors' on how the output is structured.
validatePrettyToJSON :: forall a. (ToJSON a, ToSchema a) => a -> Maybe String
validatePrettyToJSON :: forall a. (ToJSON a, ToSchema a) => a -> Maybe String
validatePrettyToJSON = forall a.
(ToJSON a, ToSchema a) =>
(a -> [String]) -> a -> Maybe String
renderValidationErrors forall a. (ToJSON a, ToSchema a) => a -> [String]
validateToJSON

-- | Variant of 'validatePrettyToJSON' with typed output.
validateToJSON :: forall a. (ToJSON a, ToSchema a) => a -> [ValidationError]
validateToJSON :: forall a. (ToJSON a, ToSchema a) => a -> [String]
validateToJSON = forall a.
(ToJSON a, ToSchema a) =>
(Pattern -> Pattern -> Bool) -> a -> [String]
validateToJSONWithPatternChecker (\Pattern
_pattern Pattern
_str -> Bool
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'@.  See also:
-- 'renderValidationErrors'.
validateToJSONWithPatternChecker :: forall a. (ToJSON a, ToSchema a) => (Pattern -> Text -> Bool) -> a -> [ValidationError]
validateToJSONWithPatternChecker :: forall a.
(ToJSON a, ToSchema a) =>
(Pattern -> Pattern -> Bool) -> a -> [String]
validateToJSONWithPatternChecker Pattern -> Pattern -> Bool
checker = (Pattern -> Pattern -> Bool)
-> Definitions Schema -> Schema -> Value -> [String]
validateJSONWithPatternChecker Pattern -> Pattern -> Bool
checker Definitions Schema
defs Schema
sch forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToJSON a => a -> Value
toJSON
  where
    (Definitions Schema
defs, Schema
sch) = forall d a. Declare d a -> d -> (d, a)
runDeclare (forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) Schema
declareSchema (forall {k} (t :: k). Proxy t
Proxy :: Proxy a)) forall a. Monoid a => a
mempty

-- | Pretty print validation errors
-- together with actual JSON and Swagger Schema
-- (using 'encodePretty').
--
-- >>> import Data.Aeson as Aeson
-- >>> import Data.Foldable (traverse_)
-- >>> import GHC.Generics
-- >>> data Phone = Phone { value :: String } deriving (Generic)
-- >>> data Person = Person { name :: String, phone :: Phone } deriving (Generic)
-- >>> instance ToJSON Person where toJSON p = object [ "name" Aeson..= name p ]
-- >>> instance ToSchema Phone
-- >>> instance ToSchema Person
-- >>> let person = Person { name = "John", phone = Phone "123456" }
-- >>> traverse_ putStrLn $ renderValidationErrors 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": {
--             "$ref": "#/components/schemas/Phone"
--         }
--     },
--     "required": [
--         "name",
--         "phone"
--     ],
--     "type": "object"
-- }
-- <BLANKLINE>
-- Swagger Description Context:
-- {
--     "Phone": {
--         "properties": {
--             "value": {
--                 "type": "string"
--             }
--         },
--         "required": [
--             "value"
--         ],
--         "type": "object"
--     }
-- }
-- <BLANKLINE>
renderValidationErrors
  :: forall a. (ToJSON a, ToSchema a)
  => (a -> [ValidationError]) -> a -> Maybe String
renderValidationErrors :: forall a.
(ToJSON a, ToSchema a) =>
(a -> [String]) -> a -> Maybe String
renderValidationErrors a -> [String]
f a
x =
  case a -> [String]
f a
x of
    []      -> forall a. Maybe a
Nothing
    [String]
errors  -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
      [ String
"Validation against the schema fails:"
      , [String] -> String
unlines (forall a b. (a -> b) -> [a] -> [b]
map (String
"  * " forall a. [a] -> [a] -> [a]
++) [String]
errors)
      , String
"JSON value:"
      , Value -> String
ppJSONString (forall a. ToJSON a => a -> Value
toJSON a
x)
      , String
""
      , String
"Swagger Schema:"
      , Value -> String
ppJSONString (forall a. ToJSON a => a -> Value
toJSON Schema
schema_)
      , String
""
      , String
"Swagger Description Context:"
      , Value -> String
ppJSONString (forall a. ToJSON a => a -> Value
toJSON Definitions Schema
refs_)
      ]
  where
    ppJSONString :: Value -> String
ppJSONString = Text -> String
TL.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
TL.decodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToJSON a => a -> ByteString
encodePretty
    (Definitions Schema
refs_, Schema
schema_) = forall d a. Declare d a -> d -> (d, a)
runDeclare (forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) Schema
declareSchema (forall {k} (t :: k). Proxy t
Proxy :: Proxy a)) forall a. Monoid a => a
mempty

-- | Validate JSON @'Value'@ against Swagger @'Schema'@.
--
-- prop> validateJSON mempty (toSchema (Proxy :: Proxy Int)) (toJSON (x :: Int)) == []
--
-- /NOTE:/ @'validateJSON'@ does not perform string pattern validation.
-- See @'validateJSONWithPatternChecker'@.
validateJSON :: Definitions Schema -> Schema -> Value -> [ValidationError]
validateJSON :: Definitions Schema -> Schema -> Value -> [String]
validateJSON = (Pattern -> Pattern -> Bool)
-> Definitions Schema -> Schema -> Value -> [String]
validateJSONWithPatternChecker (\Pattern
_pattern Pattern
_str -> Bool
True)

-- | Validate JSON @'Value'@ agains Swagger @'ToSchema'@ for a given value and pattern checker.
--
-- For validation without patterns see @'validateJSON'@.
validateJSONWithPatternChecker :: (Pattern -> Text -> Bool) -> Definitions Schema -> Schema -> Value -> [ValidationError]
validateJSONWithPatternChecker :: (Pattern -> Pattern -> Bool)
-> Definitions Schema -> Schema -> Value -> [String]
validateJSONWithPatternChecker Pattern -> Pattern -> Bool
checker Definitions Schema
defs Schema
sch Value
js =
  case forall s a. Validation s a -> Config -> s -> Result a
runValidation (Value -> Validation Schema ()
validateWithSchema Value
js) Config
cfg Schema
sch of
    Failed [String]
xs -> [String]
xs
    Passed ()
_  -> forall a. Monoid a => a
mempty
  where
    cfg :: Config
cfg = Config
defaultConfig
            { configPatternChecker :: Pattern -> Pattern -> Bool
configPatternChecker = Pattern -> Pattern -> Bool
checker
            , configDefinitions :: Definitions Schema
configDefinitions = Definitions Schema
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 (Result a -> Result a -> Bool
forall a. Eq a => Result a -> Result a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Result a -> Result a -> Bool
$c/= :: forall a. Eq a => Result a -> Result a -> Bool
== :: Result a -> Result a -> Bool
$c== :: forall a. Eq a => Result a -> Result a -> Bool
Eq, Int -> Result a -> String -> String
forall a. Show a => Int -> Result a -> String -> String
forall a. Show a => [Result a] -> String -> String
forall a. Show a => Result a -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Result a] -> String -> String
$cshowList :: forall a. Show a => [Result a] -> String -> String
show :: Result a -> String
$cshow :: forall a. Show a => Result a -> String
showsPrec :: Int -> Result a -> String -> String
$cshowsPrec :: forall a. Show a => Int -> Result a -> String -> String
Show, forall a b. a -> Result b -> Result a
forall a b. (a -> b) -> Result a -> Result b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Result b -> Result a
$c<$ :: forall a b. a -> Result b -> Result a
fmap :: forall a b. (a -> b) -> Result a -> Result b
$cfmap :: forall a b. (a -> b) -> Result a -> Result b
Functor)

instance Applicative Result where
  pure :: forall a. a -> Result a
pure = forall a. a -> Result a
Passed
  Passed a -> b
f <*> :: forall a b. Result (a -> b) -> Result a -> Result b
<*> Passed a
x = forall a. a -> Result a
Passed (a -> b
f a
x)
  Failed [String]
xs <*> Failed [String]
ys = forall a. [String] -> Result a
Failed ([String]
xs forall a. Semigroup a => a -> a -> a
<> [String]
ys)
  Failed [String]
xs <*> Result a
_ = forall a. [String] -> Result a
Failed [String]
xs
  Result (a -> b)
_ <*> Failed [String]
ys = forall a. [String] -> Result a
Failed [String]
ys

instance Alternative Result where
  empty :: forall a. Result a
empty = forall a. [String] -> Result a
Failed forall a. Monoid a => a
mempty
  Passed a
x <|> :: forall a. Result a -> Result a -> Result a
<|> Result a
_ = forall a. a -> Result a
Passed a
x
  Result a
_        <|> Result a
y = Result a
y

instance Monad Result where
  return :: forall a. a -> Result a
return = forall (f :: * -> *) a. Applicative f => a -> f a
pure
  Passed a
x >>= :: forall a b. Result a -> (a -> Result b) -> Result b
>>=  a -> Result b
f = a -> Result b
f a
x
  Failed [String]
xs >>= a -> Result b
_ = forall a. [String] -> Result a
Failed [String]
xs

-- | Validation configuration.
data Config = Config
  { -- | Pattern checker for @'_schemaPattern'@ validation.
    Config -> Pattern -> Pattern -> Bool
configPatternChecker :: Pattern -> Text -> Bool
    -- | Schema definitions in scope to resolve references.
  , Config -> Definitions Schema
configDefinitions    :: Definitions Schema
  }

-- | Default @'Config'@:
--
-- @
-- defaultConfig = 'Config'
--   { 'configPatternChecker' = \\_pattern _str -> True
--   , 'configDefinitions'    = mempty
--   }
-- @
defaultConfig :: Config
defaultConfig :: Config
defaultConfig = Config
  { configPatternChecker :: Pattern -> Pattern -> Bool
configPatternChecker = \Pattern
_pattern Pattern
_str -> Bool
True
  , configDefinitions :: Definitions Schema
configDefinitions    = forall a. Monoid a => a
mempty
  }

-- | Value validation.
newtype Validation s a = Validation { forall s a. Validation s a -> Config -> s -> Result a
runValidation :: Config -> s -> Result a }
  deriving (forall a b. a -> Validation s b -> Validation s a
forall a b. (a -> b) -> Validation s a -> Validation s b
forall s a b. a -> Validation s b -> Validation s a
forall s a b. (a -> b) -> Validation s a -> Validation s b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Validation s b -> Validation s a
$c<$ :: forall s a b. a -> Validation s b -> Validation s a
fmap :: forall a b. (a -> b) -> Validation s a -> Validation s b
$cfmap :: forall s a b. (a -> b) -> Validation s a -> Validation s b
Functor)

instance Applicative (Validation schema) where
  pure :: forall a. a -> Validation schema a
pure a
x = forall s a. (Config -> s -> Result a) -> Validation s a
Validation (\Config
_ schema
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x)
  Validation Config -> schema -> Result (a -> b)
f <*> :: forall a b.
Validation schema (a -> b)
-> Validation schema a -> Validation schema b
<*> Validation Config -> schema -> Result a
x = forall s a. (Config -> s -> Result a) -> Validation s a
Validation (\Config
c schema
s -> Config -> schema -> Result (a -> b)
f Config
c schema
s forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Config -> schema -> Result a
x Config
c schema
s)

instance Alternative (Validation schema) where
  empty :: forall a. Validation schema a
empty = forall s a. (Config -> s -> Result a) -> Validation s a
Validation (\Config
_ schema
_ -> forall (f :: * -> *) a. Alternative f => f a
empty)
  Validation Config -> schema -> Result a
x <|> :: forall a.
Validation schema a -> Validation schema a -> Validation schema a
<|> Validation Config -> schema -> Result a
y = forall s a. (Config -> s -> Result a) -> Validation s a
Validation (\Config
c schema
s -> Config -> schema -> Result a
x Config
c schema
s forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Config -> schema -> Result a
y Config
c schema
s)

instance Profunctor Validation where
  dimap :: forall a b c d.
(a -> b) -> (c -> d) -> Validation b c -> Validation a d
dimap a -> b
f c -> d
g (Validation Config -> b -> Result c
k) = forall s a. (Config -> s -> Result a) -> Validation s a
Validation (\Config
c a
s -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap c -> d
g (Config -> b -> Result c
k Config
c (a -> b
f a
s)))

instance Choice Validation where
  left' :: forall a b c.
Validation a b -> Validation (Either a c) (Either b c)
left'  (Validation Config -> a -> Result b
g) = forall s a. (Config -> s -> Result a) -> Validation s a
Validation (\Config
c -> forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config -> a -> Result b
g Config
c) (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. b -> Either a b
Right))
  right' :: forall a b c.
Validation a b -> Validation (Either c a) (Either c b)
right' (Validation Config -> a -> Result b
g) = forall s a. (Config -> s -> Result a) -> Validation s a
Validation (\Config
c -> forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config -> a -> Result b
g Config
c))

instance Monad (Validation s) where
  return :: forall a. a -> Validation s a
return = forall (f :: * -> *) a. Applicative f => a -> f a
pure
  Validation Config -> s -> Result a
x >>= :: forall a b.
Validation s a -> (a -> Validation s b) -> Validation s b
>>= a -> Validation s b
f = forall s a. (Config -> s -> Result a) -> Validation s a
Validation (\Config
c s
s -> Config -> s -> Result a
x Config
c s
s forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
y -> forall s a. Validation s a -> Config -> s -> Result a
runValidation (a -> Validation s b
f a
y) Config
c s
s)
  >> :: forall a b. Validation s a -> Validation s b -> Validation s b
(>>) = forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
(*>)

withConfig :: (Config -> Validation s a) -> Validation s a
withConfig :: forall s a. (Config -> Validation s a) -> Validation s a
withConfig Config -> Validation s a
f = forall s a. (Config -> s -> Result a) -> Validation s a
Validation (\Config
c -> forall s a. Validation s a -> Config -> s -> Result a
runValidation (Config -> Validation s a
f Config
c) Config
c)

withSchema :: (s -> Validation s a) -> Validation s a
withSchema :: forall s a. (s -> Validation s a) -> Validation s a
withSchema s -> Validation s a
f = forall s a. (Config -> s -> Result a) -> Validation s a
Validation (\Config
c s
s -> forall s a. Validation s a -> Config -> s -> Result a
runValidation (s -> Validation s a
f s
s) Config
c s
s)

-- | Issue an error message.
invalid :: String -> Validation schema a
invalid :: forall schema a. String -> Validation schema a
invalid String
msg = forall s a. (Config -> s -> Result a) -> Validation s a
Validation (\Config
_ schema
_ -> forall a. [String] -> Result a
Failed [String
msg])

-- | Validation passed.
valid :: Validation schema ()
valid :: forall schema. Validation schema ()
valid = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Validate schema's property given a lens into that property
-- and property checker.
checkMissing :: Validation s () -> Lens' s (Maybe a) -> (a -> Validation s ()) -> Validation s ()
checkMissing :: forall s a.
Validation s ()
-> Lens' s (Maybe a) -> (a -> Validation s ()) -> Validation s ()
checkMissing Validation s ()
missing Lens' s (Maybe a)
l a -> Validation s ()
g = forall s a. (s -> Validation s a) -> Validation s a
withSchema forall a b. (a -> b) -> a -> b
$ \s
sch ->
  case s
sch forall s a. s -> Getting a s a -> a
^. Lens' s (Maybe a)
l of
    Maybe a
Nothing -> Validation s ()
missing
    Just a
x  -> a -> Validation s ()
g a
x

-- | Validate schema's property given a lens into that property
-- and property checker.
-- If property is missing in schema, consider it valid.
check :: Lens' s (Maybe a) -> (a -> Validation s ()) -> Validation s ()
check :: forall s a.
Lens' s (Maybe a) -> (a -> Validation s ()) -> Validation s ()
check = forall s a.
Validation s ()
-> Lens' s (Maybe a) -> (a -> Validation s ()) -> Validation s ()
checkMissing forall schema. Validation schema ()
valid

-- | Validate same value with different schema.
sub :: t -> Validation t a -> Validation s a
sub :: forall t a s. t -> Validation t a -> Validation s a
sub = forall (p :: * -> * -> *) a b c.
Profunctor p =>
(a -> b) -> p b c -> p a c
lmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b -> a
const

-- | Validate same value with a part of the original schema.
sub_ :: Getting a s a -> Validation a r -> Validation s r
sub_ :: forall a s r. Getting a s a -> Validation a r -> Validation s r
sub_ = forall (p :: * -> * -> *) a b c.
Profunctor p =>
(a -> b) -> p b c -> p a c
lmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view

-- | Validate value against a schema given schema reference and validation function.
withRef :: Reference -> (Schema -> Validation s a) -> Validation s a
withRef :: forall s a.
Reference -> (Schema -> Validation s a) -> Validation s a
withRef (Reference Pattern
ref) Schema -> Validation s a
f = forall s a. (Config -> Validation s a) -> Validation s a
withConfig forall a b. (a -> b) -> a -> b
$ \Config
cfg ->
  case forall k v. (Eq k, Hashable k) => k -> InsOrdHashMap k v -> Maybe v
InsOrdHashMap.lookup Pattern
ref (Config -> Definitions Schema
configDefinitions Config
cfg) of
    Maybe Schema
Nothing -> forall schema a. String -> Validation schema a
invalid forall a b. (a -> b) -> a -> b
$ String
"unknown schema " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Pattern
ref
    Just Schema
s  -> Schema -> Validation s a
f Schema
s

validateWithSchemaRef :: Referenced Schema -> Value -> Validation s ()
validateWithSchemaRef :: forall s. Referenced Schema -> Value -> Validation s ()
validateWithSchemaRef (Ref Reference
ref)  Value
js = forall s a.
Reference -> (Schema -> Validation s a) -> Validation s a
withRef Reference
ref forall a b. (a -> b) -> a -> b
$ \Schema
sch -> forall t a s. t -> Validation t a -> Validation s a
sub Schema
sch (Value -> Validation Schema ()
validateWithSchema Value
js)
validateWithSchemaRef (Inline Schema
s) Value
js = forall t a s. t -> Validation t a -> Validation s a
sub Schema
s (Value -> Validation Schema ()
validateWithSchema Value
js)

-- | Validate JSON @'Value'@ with Swagger @'Schema'@.
validateWithSchema :: Value -> Validation Schema ()
validateWithSchema :: Value -> Validation Schema ()
validateWithSchema Value
val = do
  Value -> Validation Schema ()
validateSchemaType Value
val
  Value -> Validation Schema ()
validateEnum Value
val

validateInteger :: Scientific -> Validation Schema ()
validateInteger :: Scientific -> Validation Schema ()
validateInteger Scientific
n = do
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Scientific -> Bool
isInteger Scientific
n)) forall a b. (a -> b) -> a -> b
$
    forall schema a. String -> Validation schema a
invalid (String
"not an integer")
  Scientific -> Validation Schema ()
validateNumber Scientific
n

validateNumber :: Scientific -> Validation Schema ()
validateNumber :: Scientific -> Validation Schema ()
validateNumber Scientific
n = forall s a. (Config -> Validation s a) -> Validation s a
withConfig forall a b. (a -> b) -> a -> b
$ \Config
_cfg -> forall s a. (s -> Validation s a) -> Validation s a
withSchema forall a b. (a -> b) -> a -> b
$ \Schema
sch -> do
  let exMax :: Bool
exMax = forall a. a -> Maybe a
Just Bool
True forall a. Eq a => a -> a -> Bool
== Schema
sch forall s a. s -> Getting a s a -> a
^. forall s a. HasExclusiveMaximum s a => Lens' s a
exclusiveMaximum
      exMin :: Bool
exMin = forall a. a -> Maybe a
Just Bool
True forall a. Eq a => a -> a -> Bool
== Schema
sch forall s a. s -> Getting a s a -> a
^. forall s a. HasExclusiveMinimum s a => Lens' s a
exclusiveMinimum

  forall s a.
Lens' s (Maybe a) -> (a -> Validation s ()) -> Validation s ()
check forall s a. HasMaximum s a => Lens' s a
maximum_ forall a b. (a -> b) -> a -> b
$ \Scientific
m ->
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (if Bool
exMax then (Scientific
n forall a. Ord a => a -> a -> Bool
>= Scientific
m) else (Scientific
n forall a. Ord a => a -> a -> Bool
> Scientific
m)) forall a b. (a -> b) -> a -> b
$
      forall schema a. String -> Validation schema a
invalid (String
"value " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Scientific
n forall a. [a] -> [a] -> [a]
++ String
" exceeds maximum (should be " forall a. [a] -> [a] -> [a]
++ (if Bool
exMax then String
"<" else String
"<=") forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Scientific
m forall a. [a] -> [a] -> [a]
++ String
")")

  forall s a.
Lens' s (Maybe a) -> (a -> Validation s ()) -> Validation s ()
check forall s a. HasMinimum s a => Lens' s a
minimum_ forall a b. (a -> b) -> a -> b
$ \Scientific
m ->
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (if Bool
exMin then (Scientific
n forall a. Ord a => a -> a -> Bool
<= Scientific
m) else (Scientific
n forall a. Ord a => a -> a -> Bool
< Scientific
m)) forall a b. (a -> b) -> a -> b
$
      forall schema a. String -> Validation schema a
invalid (String
"value " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Scientific
n forall a. [a] -> [a] -> [a]
++ String
" falls below minimum (should be " forall a. [a] -> [a] -> [a]
++ (if Bool
exMin then String
">" else String
">=") forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Scientific
m forall a. [a] -> [a] -> [a]
++ String
")")

  forall s a.
Lens' s (Maybe a) -> (a -> Validation s ()) -> Validation s ()
check forall s a. HasMultipleOf s a => Lens' s a
multipleOf forall a b. (a -> b) -> a -> b
$ \Scientific
k ->
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Scientific -> Bool
isInteger (Scientific
n forall a. Fractional a => a -> a -> a
/ Scientific
k))) forall a b. (a -> b) -> a -> b
$
      forall schema a. String -> Validation schema a
invalid (String
"expected a multiple of " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Scientific
k forall a. [a] -> [a] -> [a]
++ String
" but got " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Scientific
n)

validateString :: Text -> Validation Schema ()
validateString :: Pattern -> Validation Schema ()
validateString Pattern
s = do
  forall s a.
Lens' s (Maybe a) -> (a -> Validation s ()) -> Validation s ()
check forall s a. HasMaxLength s a => Lens' s a
maxLength forall a b. (a -> b) -> a -> b
$ \Integer
n ->
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
len forall a. Ord a => a -> a -> Bool
> forall a. Num a => Integer -> a
fromInteger Integer
n) forall a b. (a -> b) -> a -> b
$
      forall schema a. String -> Validation schema a
invalid (String
"string is too long (length should be <=" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Integer
n forall a. [a] -> [a] -> [a]
++ String
")")

  forall s a.
Lens' s (Maybe a) -> (a -> Validation s ()) -> Validation s ()
check forall s a. HasMinLength s a => Lens' s a
minLength forall a b. (a -> b) -> a -> b
$ \Integer
n ->
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
len forall a. Ord a => a -> a -> Bool
< forall a. Num a => Integer -> a
fromInteger Integer
n) forall a b. (a -> b) -> a -> b
$
      forall schema a. String -> Validation schema a
invalid (String
"string is too short (length should be >=" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Integer
n forall a. [a] -> [a] -> [a]
++ String
")")

  forall s a.
Lens' s (Maybe a) -> (a -> Validation s ()) -> Validation s ()
check forall s a. HasPattern s a => Lens' s a
pattern forall a b. (a -> b) -> a -> b
$ \Pattern
regex -> do
    forall s a. (Config -> Validation s a) -> Validation s a
withConfig forall a b. (a -> b) -> a -> b
$ \Config
cfg -> do
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Config -> Pattern -> Pattern -> Bool
configPatternChecker Config
cfg Pattern
regex Pattern
s)) forall a b. (a -> b) -> a -> b
$
        forall schema a. String -> Validation schema a
invalid (String
"string does not match pattern " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Pattern
regex)
  where
    len :: Int
len = Pattern -> Int
Text.length Pattern
s

validateArray :: Vector Value -> Validation Schema ()
validateArray :: Vector Value -> Validation Schema ()
validateArray Vector Value
xs = do
  forall s a.
Lens' s (Maybe a) -> (a -> Validation s ()) -> Validation s ()
check forall s a. HasMaxItems s a => Lens' s a
maxItems forall a b. (a -> b) -> a -> b
$ \Integer
n ->
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
len forall a. Ord a => a -> a -> Bool
> forall a. Num a => Integer -> a
fromInteger Integer
n) forall a b. (a -> b) -> a -> b
$
      forall schema a. String -> Validation schema a
invalid (String
"array exceeds maximum size (should be <=" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Integer
n forall a. [a] -> [a] -> [a]
++ String
")")

  forall s a.
Lens' s (Maybe a) -> (a -> Validation s ()) -> Validation s ()
check forall s a. HasMinItems s a => Lens' s a
minItems forall a b. (a -> b) -> a -> b
$ \Integer
n ->
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
len forall a. Ord a => a -> a -> Bool
< forall a. Num a => Integer -> a
fromInteger Integer
n) forall a b. (a -> b) -> a -> b
$
      forall schema a. String -> Validation schema a
invalid (String
"array is too short (size should be >=" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Integer
n forall a. [a] -> [a] -> [a]
++ String
")")

  forall s a.
Lens' s (Maybe a) -> (a -> Validation s ()) -> Validation s ()
check forall s a. HasItems s a => Lens' s a
items forall a b. (a -> b) -> a -> b
$ \case
    OpenApiItemsObject Referenced Schema
itemSchema      -> forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (forall s. Referenced Schema -> Value -> Validation s ()
validateWithSchemaRef Referenced Schema
itemSchema) Vector Value
xs
    OpenApiItemsArray [Referenced Schema]
itemSchemas -> do
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
len forall a. Eq a => a -> a -> Bool
/= forall (t :: * -> *) a. Foldable t => t a -> Int
length [Referenced Schema]
itemSchemas) forall a b. (a -> b) -> a -> b
$
        forall schema a. String -> Validation schema a
invalid (String
"array size is invalid (should be exactly " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Referenced Schema]
itemSchemas) forall a. [a] -> [a] -> [a]
++ String
")")
      forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Applicative f) =>
t (f a) -> f ()
sequenceA_ (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall s. Referenced Schema -> Value -> Validation s ()
validateWithSchemaRef [Referenced Schema]
itemSchemas (forall a. Vector a -> [a]
Vector.toList Vector Value
xs))

  forall s a.
Lens' s (Maybe a) -> (a -> Validation s ()) -> Validation s ()
check forall s a. HasUniqueItems s a => Lens' s a
uniqueItems forall a b. (a -> b) -> a -> b
$ \Bool
unique ->
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
unique Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
allUnique) forall a b. (a -> b) -> a -> b
$
      forall schema a. String -> Validation schema a
invalid (String
"array is expected to contain unique items, but it does not")
  where
    len :: Int
len = forall a. Vector a -> Int
Vector.length Vector Value
xs
    allUnique :: Bool
allUnique = Int
len forall a. Eq a => a -> a -> Bool
== forall a. HashSet a -> Int
HashSet.size (forall a. (Eq a, Hashable a) => [a] -> HashSet a
HashSet.fromList (forall a. Vector a -> [a]
Vector.toList Vector Value
xs))

validateObject ::
#if MIN_VERSION_aeson(2,0,0)
  KeyMap.KeyMap Value
#else
  HashMap Text Value
#endif
  -> Validation Schema ()
validateObject :: KeyMap Value -> Validation Schema ()
validateObject KeyMap Value
o = forall s a. (s -> Validation s a) -> Validation s a
withSchema forall a b. (a -> b) -> a -> b
$ \Schema
sch ->
  case Schema
sch forall s a. s -> Getting a s a -> a
^. forall s a. HasDiscriminator s a => Lens' s a
discriminator of
    Just (Discriminator Pattern
pname InsOrdHashMap Pattern Pattern
types) -> case forall a. FromJSON a => Value -> Result a
fromJSON forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall v. Pattern -> KeyMap v -> Maybe v
lookupKey Pattern
pname KeyMap Value
o of
      Just (Success Pattern
pvalue) ->
        let ref :: Pattern
ref = forall a. a -> Maybe a -> a
fromMaybe Pattern
pvalue forall a b. (a -> b) -> a -> b
$ forall k v. (Eq k, Hashable k) => k -> InsOrdHashMap k v -> Maybe v
InsOrdHashMap.lookup Pattern
pvalue InsOrdHashMap Pattern Pattern
types
        -- TODO ref may be name or reference
        in forall s. Referenced Schema -> Value -> Validation s ()
validateWithSchemaRef (forall a. Reference -> Referenced a
Ref (Pattern -> Reference
Reference Pattern
ref)) (KeyMap Value -> Value
Object KeyMap Value
o)
      Just (Error String
msg)   -> forall schema a. String -> Validation schema a
invalid (String
"failed to parse discriminator property " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Pattern
pname forall a. [a] -> [a] -> [a]
++ String
": " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
msg)
      Maybe (Result Pattern)
Nothing            -> forall schema a. String -> Validation schema a
invalid (String
"discriminator property " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Pattern
pname forall a. [a] -> [a] -> [a]
++ String
"is missing")
    Maybe Discriminator
Nothing -> do
      forall s a.
Lens' s (Maybe a) -> (a -> Validation s ()) -> Validation s ()
check forall s a. HasMaxProperties s a => Lens' s a
maxProperties forall a b. (a -> b) -> a -> b
$ \Integer
n ->
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Integer
size forall a. Ord a => a -> a -> Bool
> Integer
n) forall a b. (a -> b) -> a -> b
$
          forall schema a. String -> Validation schema a
invalid (String
"object size exceeds maximum (total number of properties should be <=" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Integer
n forall a. [a] -> [a] -> [a]
++ String
")")

      forall s a.
Lens' s (Maybe a) -> (a -> Validation s ()) -> Validation s ()
check forall s a. HasMinProperties s a => Lens' s a
minProperties forall a b. (a -> b) -> a -> b
$ \Integer
n ->
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Integer
size forall a. Ord a => a -> a -> Bool
< Integer
n) forall a b. (a -> b) -> a -> b
$
          forall schema a. String -> Validation schema a
invalid (String
"object size is too small (total number of properties should be >=" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Integer
n forall a. [a] -> [a] -> [a]
++ String
")")

      Validation Schema ()
validateRequired
      Validation Schema ()
validateProps
  where
    size :: Integer
size = forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall (t :: * -> *) a. Foldable t => t a -> Int
length KeyMap Value
o)

    validateRequired :: Validation Schema ()
validateRequired = forall s a. (s -> Validation s a) -> Validation s a
withSchema forall a b. (a -> b) -> a -> b
$ \Schema
sch -> forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Pattern -> Validation Schema ()
validateReq (Schema
sch forall s a. s -> Getting a s a -> a
^. forall s a. HasRequired s a => Lens' s a
required)
    validateReq :: Pattern -> Validation Schema ()
validateReq Pattern
n =
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (forall a. Pattern -> KeyMap a -> Bool
hasKey Pattern
n KeyMap Value
o)) forall a b. (a -> b) -> a -> b
$
        forall schema a. String -> Validation schema a
invalid (String
"property " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Pattern
n forall a. [a] -> [a] -> [a]
++ String
" is required, but not found in " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall a. ToJSON a => a -> ByteString
encode KeyMap Value
o))

    validateProps :: Validation Schema ()
validateProps = forall s a. (s -> Validation s a) -> Validation s a
withSchema forall a b. (a -> b) -> a -> b
$ \Schema
sch -> do
      forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (forall v. KeyMap v -> [(Key, v)]
objectToList KeyMap Value
o) forall a b. (a -> b) -> a -> b
$ \(Key -> Pattern
keyToText -> Pattern
k, Value
v) ->
        case Value
v of
          Value
Null | Bool -> Bool
not (Pattern
k forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (Schema
sch forall s a. s -> Getting a s a -> a
^. forall s a. HasRequired s a => Lens' s a
required)) -> forall schema. Validation schema ()
valid  -- null is fine for non-required property
          Value
_ ->
            case forall k v. (Eq k, Hashable k) => k -> InsOrdHashMap k v -> Maybe v
InsOrdHashMap.lookup Pattern
k (Schema
sch forall s a. s -> Getting a s a -> a
^. forall s a. HasProperties s a => Lens' s a
properties) of
              Maybe (Referenced Schema)
Nothing -> forall s a.
Validation s ()
-> Lens' s (Maybe a) -> (a -> Validation s ()) -> Validation s ()
checkMissing (forall s a. Pattern -> Validation s a
unknownProperty Pattern
k) forall s a. HasAdditionalProperties s a => Lens' s a
additionalProperties forall a b. (a -> b) -> a -> b
$ forall {a} {schema}.
Show a =>
a -> Value -> AdditionalProperties -> Validation schema ()
validateAdditional Pattern
k Value
v
              Just Referenced Schema
s  -> forall s. Referenced Schema -> Value -> Validation s ()
validateWithSchemaRef Referenced Schema
s Value
v

    validateAdditional :: a -> Value -> AdditionalProperties -> Validation schema ()
validateAdditional a
_ Value
_ (AdditionalPropertiesAllowed Bool
True) = forall schema. Validation schema ()
valid
    validateAdditional a
k Value
_ (AdditionalPropertiesAllowed Bool
False) = forall schema a. String -> Validation schema a
invalid forall a b. (a -> b) -> a -> b
$ String
"additionalProperties=false but extra property " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show a
k forall a. Semigroup a => a -> a -> a
<> String
" found"
    validateAdditional a
_ Value
v (AdditionalPropertiesSchema Referenced Schema
s) = forall s. Referenced Schema -> Value -> Validation s ()
validateWithSchemaRef Referenced Schema
s Value
v

    unknownProperty :: Text -> Validation s a
    unknownProperty :: forall s a. Pattern -> Validation s a
unknownProperty Pattern
pname = forall schema a. String -> Validation schema a
invalid forall a b. (a -> b) -> a -> b
$
      String
"property " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Pattern
pname forall a. Semigroup a => a -> a -> a
<> String
" is found in JSON value, but it is not mentioned in Swagger schema"

validateEnum :: Value -> Validation Schema ()
validateEnum :: Value -> Validation Schema ()
validateEnum Value
val = do
  forall s a.
Lens' s (Maybe a) -> (a -> Validation s ()) -> Validation s ()
check forall s a. HasEnum s a => Lens' s a
enum_ forall a b. (a -> b) -> a -> b
$ \[Value]
xs ->
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Value
val forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Value]
xs) forall a b. (a -> b) -> a -> b
$
      forall schema a. String -> Validation schema a
invalid (String
"expected one of " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall a. ToJSON a => a -> ByteString
encode [Value]
xs) forall a. [a] -> [a] -> [a]
++ String
" but got " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Value
val)

-- | Infer schema type based on used properties.
--
-- This is like 'inferParamSchemaTypes', but also works for objects:
--
-- >>> inferSchemaTypes <$> decode "{\"minProperties\": 1}"
-- Just [OpenApiObject]
inferSchemaTypes :: Schema -> [OpenApiType]
inferSchemaTypes :: Schema -> [OpenApiType]
inferSchemaTypes Schema
sch = Schema -> [OpenApiType]
inferParamSchemaTypes Schema
sch forall a. [a] -> [a] -> [a]
++
  [ OpenApiType
OpenApiObject | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a b. (a -> b) -> a -> b
$ Schema
sch)
       [ forall s a. Getting Any s a -> s -> Bool
has (forall s a. HasAdditionalProperties s a => Lens' s a
additionalPropertiesforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a b. Prism (Maybe a) (Maybe b) a b
_Just)
       , forall s a. Getting Any s a -> s -> Bool
has (forall s a. HasMaxProperties s a => Lens' s a
maxPropertiesforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a b. Prism (Maybe a) (Maybe b) a b
_Just)
       , forall s a. Getting Any s a -> s -> Bool
has (forall s a. HasMinProperties s a => Lens' s a
minPropertiesforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a b. Prism (Maybe a) (Maybe b) a b
_Just)
       , forall s a. Getting Any s a -> s -> Bool
has (forall s a. HasProperties s a => Lens' s a
propertiesforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall (f :: * -> *) a. Foldable f => IndexedFold Int (f a) a
folded)
       , forall s a. Getting Any s a -> s -> Bool
has (forall s a. HasRequired s a => Lens' s a
requiredforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall (f :: * -> *) a. Foldable f => IndexedFold Int (f a) a
folded) ] ]

-- | Infer schema type based on used properties.
--
-- >>> inferSchemaTypes <$> decode "{\"minLength\": 2}"
-- Just [OpenApiString]
--
-- >>> inferSchemaTypes <$> decode "{\"maxItems\": 0}"
-- Just [OpenApiArray]
--
-- From numeric properties 'OpenApiInteger' type is inferred.
-- If you want 'OpenApiNumber' instead, you must specify it explicitly.
--
-- >>> inferSchemaTypes <$> decode "{\"minimum\": 1}"
-- Just [OpenApiInteger]
inferParamSchemaTypes :: Schema -> [OpenApiType]
inferParamSchemaTypes :: Schema -> [OpenApiType]
inferParamSchemaTypes Schema
sch = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
  [ [ OpenApiType
OpenApiArray | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a b. (a -> b) -> a -> b
$ Schema
sch)
        [ forall s a. Getting Any s a -> s -> Bool
has (forall s a. HasItems s a => Lens' s a
itemsforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a b. Prism (Maybe a) (Maybe b) a b
_Just)
        , forall s a. Getting Any s a -> s -> Bool
has (forall s a. HasMaxItems s a => Lens' s a
maxItemsforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a b. Prism (Maybe a) (Maybe b) a b
_Just)
        , forall s a. Getting Any s a -> s -> Bool
has (forall s a. HasMinItems s a => Lens' s a
minItemsforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a b. Prism (Maybe a) (Maybe b) a b
_Just)
        , forall s a. Getting Any s a -> s -> Bool
has (forall s a. HasUniqueItems s a => Lens' s a
uniqueItemsforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a b. Prism (Maybe a) (Maybe b) a b
_Just) ] ]
  , [ OpenApiType
OpenApiInteger | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a b. (a -> b) -> a -> b
$ Schema
sch)
        [ forall s a. Getting Any s a -> s -> Bool
has (forall s a. HasExclusiveMaximum s a => Lens' s a
exclusiveMaximumforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a b. Prism (Maybe a) (Maybe b) a b
_Just)
        , forall s a. Getting Any s a -> s -> Bool
has (forall s a. HasExclusiveMinimum s a => Lens' s a
exclusiveMinimumforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a b. Prism (Maybe a) (Maybe b) a b
_Just)
        , forall s a. Getting Any s a -> s -> Bool
has (forall s a. HasMaximum s a => Lens' s a
maximum_forall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a b. Prism (Maybe a) (Maybe b) a b
_Just)
        , forall s a. Getting Any s a -> s -> Bool
has (forall s a. HasMinimum s a => Lens' s a
minimum_forall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a b. Prism (Maybe a) (Maybe b) a b
_Just)
        , forall s a. Getting Any s a -> s -> Bool
has (forall s a. HasMultipleOf s a => Lens' s a
multipleOfforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a b. Prism (Maybe a) (Maybe b) a b
_Just) ] ]
  , [ OpenApiType
OpenApiString | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a b. (a -> b) -> a -> b
$ Schema
sch)
        [ forall s a. Getting Any s a -> s -> Bool
has (forall s a. HasMaxLength s a => Lens' s a
maxLengthforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a b. Prism (Maybe a) (Maybe b) a b
_Just)
        , forall s a. Getting Any s a -> s -> Bool
has (forall s a. HasMinLength s a => Lens' s a
minLengthforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a b. Prism (Maybe a) (Maybe b) a b
_Just)
        , forall s a. Getting Any s a -> s -> Bool
has (forall s a. HasPattern s a => Lens' s a
patternforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a b. Prism (Maybe a) (Maybe b) a b
_Just) ] ]
  ]

validateSchemaType :: Value -> Validation Schema ()
validateSchemaType :: Value -> Validation Schema ()
validateSchemaType Value
val = forall s a. (s -> Validation s a) -> Validation s a
withSchema forall a b. (a -> b) -> a -> b
$ \Schema
sch ->
  case Schema
sch of
    (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall s a. HasOneOf s a => Lens' s a
oneOf -> Just [Referenced Schema]
variants) -> do
      [Bool]
res <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Referenced Schema]
variants forall a b. (a -> b) -> a -> b
$ \Referenced Schema
var ->
        (Bool
True forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall s. Referenced Schema -> Value -> Validation s ()
validateWithSchemaRef Referenced Schema
var Value
val) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False)
      case forall (t :: * -> *) a. Foldable t => t a -> Int
length forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter forall a. a -> a
id [Bool]
res of
        Int
0 -> forall schema a. String -> Validation schema a
invalid forall a b. (a -> b) -> a -> b
$ String
"Value not valid under any of 'oneOf' schemas: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Value
val
        Int
1 -> forall schema. Validation schema ()
valid
        Int
_ -> forall schema a. String -> Validation schema a
invalid forall a b. (a -> b) -> a -> b
$ String
"Value matches more than one of 'oneOf' schemas: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Value
val
    (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall s a. HasAllOf s a => Lens' s a
allOf -> Just [Referenced Schema]
variants) -> do
      -- Default semantics for Validation Monad will abort when at least one
      -- variant does not match.
      forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Referenced Schema]
variants forall a b. (a -> b) -> a -> b
$ \Referenced Schema
var ->
        forall s. Referenced Schema -> Value -> Validation s ()
validateWithSchemaRef Referenced Schema
var Value
val

    Schema
_ ->
      case (Schema
sch forall s a. s -> Getting a s a -> a
^. forall s a. HasType s a => Lens' s a
type_, Value
val) of
        (Just OpenApiType
OpenApiNull,    Value
Null)       -> forall schema. Validation schema ()
valid
        (Just OpenApiType
OpenApiBoolean, Bool Bool
_)     -> forall schema. Validation schema ()
valid
        (Just OpenApiType
OpenApiInteger, Number Scientific
n)   -> Scientific -> Validation Schema ()
validateInteger Scientific
n
        (Just OpenApiType
OpenApiNumber,  Number Scientific
n)   -> Scientific -> Validation Schema ()
validateNumber Scientific
n
        (Just OpenApiType
OpenApiString,  String Pattern
s)   -> Pattern -> Validation Schema ()
validateString Pattern
s
        (Just OpenApiType
OpenApiArray,   Array Vector Value
xs)   -> Vector Value -> Validation Schema ()
validateArray Vector Value
xs
        (Just OpenApiType
OpenApiObject,  Object KeyMap Value
o)   -> KeyMap Value -> Validation Schema ()
validateObject KeyMap Value
o
        (Maybe OpenApiType
Nothing, Value
Null)                   -> forall schema. Validation schema ()
valid
        (Maybe OpenApiType
Nothing, Bool Bool
_)                 -> forall schema. Validation schema ()
valid
        -- Number by default
        (Maybe OpenApiType
Nothing, Number Scientific
n)               -> Scientific -> Validation Schema ()
validateNumber Scientific
n
        (Maybe OpenApiType
Nothing, String Pattern
s)               -> Pattern -> Validation Schema ()
validateString Pattern
s
        (Maybe OpenApiType
Nothing, Array Vector Value
xs)               -> Vector Value -> Validation Schema ()
validateArray Vector Value
xs
        (Maybe OpenApiType
Nothing, Object KeyMap Value
o)               -> KeyMap Value -> Validation Schema ()
validateObject KeyMap Value
o
        (Maybe OpenApiType, Value)
bad -> forall schema a. String -> Validation schema a
invalid forall a b. (a -> b) -> a -> b
$ String
"expected JSON value of type " forall a. [a] -> [a] -> [a]
++ (Maybe OpenApiType, Value) -> String
showType (Maybe OpenApiType, Value)
bad

validateParamSchemaType :: Value -> Validation Schema ()
validateParamSchemaType :: Value -> Validation Schema ()
validateParamSchemaType Value
val = forall s a. (s -> Validation s a) -> Validation s a
withSchema forall a b. (a -> b) -> a -> b
$ \Schema
sch ->
  case (Schema
sch forall s a. s -> Getting a s a -> a
^. forall s a. HasType s a => Lens' s a
type_, Value
val) of
    (Just OpenApiType
OpenApiBoolean, Bool Bool
_)     -> forall schema. Validation schema ()
valid
    (Just OpenApiType
OpenApiInteger, Number Scientific
n)   -> Scientific -> Validation Schema ()
validateInteger Scientific
n
    (Just OpenApiType
OpenApiNumber,  Number Scientific
n)   -> Scientific -> Validation Schema ()
validateNumber Scientific
n
    (Just OpenApiType
OpenApiString,  String Pattern
s)   -> Pattern -> Validation Schema ()
validateString Pattern
s
    (Just OpenApiType
OpenApiArray,   Array Vector Value
xs)   -> Vector Value -> Validation Schema ()
validateArray Vector Value
xs
    (Maybe OpenApiType
Nothing, Bool Bool
_)                 -> forall schema. Validation schema ()
valid
    -- Number by default
    (Maybe OpenApiType
Nothing, Number Scientific
n)               -> Scientific -> Validation Schema ()
validateNumber Scientific
n
    (Maybe OpenApiType
Nothing, String Pattern
s)               -> Pattern -> Validation Schema ()
validateString Pattern
s
    (Maybe OpenApiType
Nothing, Array Vector Value
xs)               -> Vector Value -> Validation Schema ()
validateArray Vector Value
xs
    (Maybe OpenApiType, Value)
bad -> forall schema a. String -> Validation schema a
invalid forall a b. (a -> b) -> a -> b
$ String
"expected JSON value of type " forall a. [a] -> [a] -> [a]
++ (Maybe OpenApiType, Value) -> String
showType (Maybe OpenApiType, Value)
bad

showType :: (Maybe OpenApiType, Value) -> String
showType :: (Maybe OpenApiType, Value) -> String
showType (Just OpenApiType
ty, Value
_)        = forall a. Show a => a -> String
show OpenApiType
ty
showType (Maybe OpenApiType
Nothing, Value
Null)     = String
"OpenApiNull"
showType (Maybe OpenApiType
Nothing, Bool Bool
_)   = String
"OpenApiBoolean"
showType (Maybe OpenApiType
Nothing, Number Scientific
_) = String
"OpenApiNumber"
showType (Maybe OpenApiType
Nothing, String Pattern
_) = String
"OpenApiString"
showType (Maybe OpenApiType
Nothing, Array Vector Value
_)  = String
"OpenApiArray"
showType (Maybe OpenApiType
Nothing, Object KeyMap Value
_) = String
"OpenApiObject"