{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE TupleSections #-}

-- |
-- Module: Data.Medea
-- Description: A JSON schema language validator.
-- Copyright: (C) Juspay Technologies Pvt Ltd, 2020
-- License: MIT
-- Maintainer: koz.ross@retro-freedom.nz
-- Stability: Experimental
-- Portability: GHC only
--
-- This module contains the reference Haskell implementation of a Medea
-- validator, providing both schema graph file loading and validation, with some
-- convenience functions.
--
-- A minimal example of use follows. This example first attempts to load a Medea
-- schema graph file from @\/path\/to\/schema.medea@, and, if successful, attempts
-- to validate the JSON file at @\/path\/to\/my.json@ against the schemata so
-- loaded.
--
-- > import Data.Medea (loadSchemaFromFile, validateFromFile)
-- > import Control.Monad.Except (runExceptT)
-- >
-- > main :: IO ()
-- > main = do
-- >   -- try to load the schema graph file
-- >   loaded <- runExceptT . loadSchemaFromFile $ "/path/to/schema.medea"
-- >   case loaded of
-- >      Left err -> print err -- or some other handling
-- >      Right scm -> do
-- >        -- try to validate
-- >        validated <- runExceptT . validateFromFile scm $ "/path/to/my.json"
-- >        case validated of
-- >          Left err -> print err -- or some other handling
-- >          Right validJson -> print validJson -- or some other useful thing
--
-- For more details about how to create Medea schema graph files, see
-- @TUTORIAL.md@ and @SPEC.md@.
module Data.Medea
  ( -- * Schema loading
    Schema,
    LoaderError (..),
    buildSchema,
    loadSchemaFromFile,
    loadSchemaFromHandle,

    -- * Schema validation
    JSONType (..),
    SchemaInformation (..),
    ValidationError (..),
    ValidatedJSON,
    toValue,
    validAgainst,
    validate,
    validateFromFile,
    validateFromHandle,
  )
where

import Control.Applicative ((<|>), Alternative)
import Control.Comonad.Cofree (Cofree (..))
import Control.DeepSeq (NFData (..))
import Control.Monad (MonadPlus, unless, when)
import Control.Monad.Except (MonadError (..))
import Control.Monad.IO.Class (MonadIO (..))
import Control.Monad.Reader (MonadReader, asks, runReaderT)
import Control.Monad.State.Strict (MonadState (..), evalStateT, gets)
import Data.Aeson (Array, Object, Value (..), decode)
import qualified Data.ByteString.Lazy as BS
import Data.ByteString.Lazy (ByteString)
import Data.Coerce (coerce)
import Data.Data (Data)
import Data.Foldable (asum, traverse_)
import Data.Functor (($>))
import qualified Data.HashMap.Strict as HM
import Data.Hashable (Hashable (..))
import qualified Data.Map.Strict as M
import Data.Maybe (isNothing)
import Data.Medea.Analysis (ArrayType (..), CompiledSchema (..), TypeNode (..))
import Data.Medea.JSONType (JSONType (..), typeOf)
import Data.Medea.Loader
  ( LoaderError (..),
    buildSchema,
    loadSchemaFromFile,
    loadSchemaFromHandle,
  )
import Data.Medea.Parser.Primitive (Identifier (..), ReservedIdentifier (..), identFromReserved)
import Data.Medea.Schema (Schema (..))
import Data.Medea.ValidJSON (ValidJSONF (..))
import qualified Data.Set as S
import Data.Set.NonEmpty
  ( NESet,
    dropWhileAntitone,
    findMin,
    member,
    singleton,
  )
import Data.Text (Text)
import qualified Data.Vector as V
import GHC.Generics (Generic)
import System.IO (Handle, hSetBinaryMode)

-- | An annotation, describing which schema a given chunk of JSON was deemed to
-- be valid against.
data SchemaInformation
  = -- | No requirements were placed on this chunk.
    AnySchema
  | -- | Validated as JSON @null@.
    NullSchema
  | -- | Validated as JSON boolean.
    BooleanSchema
  | -- | Validated as JSON number.
    NumberSchema
  | -- | Validated as JSON string.
    StringSchema
  | -- | Validated as JSON array.
    ArraySchema
  | -- | Validated as JSON object.
    ObjectSchema
  | -- | Validated against the start schema.
    StartSchema
  | -- | Validated against the schema with the given name.
    UserDefined {-# UNPACK #-} !Text
  deriving stock (SchemaInformation -> SchemaInformation -> Bool
(SchemaInformation -> SchemaInformation -> Bool)
-> (SchemaInformation -> SchemaInformation -> Bool)
-> Eq SchemaInformation
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SchemaInformation -> SchemaInformation -> Bool
$c/= :: SchemaInformation -> SchemaInformation -> Bool
== :: SchemaInformation -> SchemaInformation -> Bool
$c== :: SchemaInformation -> SchemaInformation -> Bool
Eq, Typeable SchemaInformation
DataType
Constr
Typeable SchemaInformation
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g)
    -> SchemaInformation
    -> c SchemaInformation)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c SchemaInformation)
-> (SchemaInformation -> Constr)
-> (SchemaInformation -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c SchemaInformation))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e))
    -> Maybe (c SchemaInformation))
-> ((forall b. Data b => b -> b)
    -> SchemaInformation -> SchemaInformation)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> SchemaInformation -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> SchemaInformation -> r)
-> (forall u.
    (forall d. Data d => d -> u) -> SchemaInformation -> [u])
-> (forall u.
    Int -> (forall d. Data d => d -> u) -> SchemaInformation -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d)
    -> SchemaInformation -> m SchemaInformation)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d)
    -> SchemaInformation -> m SchemaInformation)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d)
    -> SchemaInformation -> m SchemaInformation)
-> Data SchemaInformation
SchemaInformation -> DataType
SchemaInformation -> Constr
(forall b. Data b => b -> b)
-> SchemaInformation -> SchemaInformation
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> SchemaInformation -> c SchemaInformation
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c SchemaInformation
forall a.
Typeable a
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u.
Int -> (forall d. Data d => d -> u) -> SchemaInformation -> u
forall u. (forall d. Data d => d -> u) -> SchemaInformation -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> SchemaInformation -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> SchemaInformation -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> SchemaInformation -> m SchemaInformation
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> SchemaInformation -> m SchemaInformation
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c SchemaInformation
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> SchemaInformation -> c SchemaInformation
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c SchemaInformation)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c SchemaInformation)
$cUserDefined :: Constr
$cStartSchema :: Constr
$cObjectSchema :: Constr
$cArraySchema :: Constr
$cStringSchema :: Constr
$cNumberSchema :: Constr
$cBooleanSchema :: Constr
$cNullSchema :: Constr
$cAnySchema :: Constr
$tSchemaInformation :: DataType
gmapMo :: (forall d. Data d => d -> m d)
-> SchemaInformation -> m SchemaInformation
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> SchemaInformation -> m SchemaInformation
gmapMp :: (forall d. Data d => d -> m d)
-> SchemaInformation -> m SchemaInformation
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> SchemaInformation -> m SchemaInformation
gmapM :: (forall d. Data d => d -> m d)
-> SchemaInformation -> m SchemaInformation
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> SchemaInformation -> m SchemaInformation
gmapQi :: Int -> (forall d. Data d => d -> u) -> SchemaInformation -> u
$cgmapQi :: forall u.
Int -> (forall d. Data d => d -> u) -> SchemaInformation -> u
gmapQ :: (forall d. Data d => d -> u) -> SchemaInformation -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> SchemaInformation -> [u]
gmapQr :: (r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> SchemaInformation -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> SchemaInformation -> r
gmapQl :: (r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> SchemaInformation -> r
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> SchemaInformation -> r
gmapT :: (forall b. Data b => b -> b)
-> SchemaInformation -> SchemaInformation
$cgmapT :: (forall b. Data b => b -> b)
-> SchemaInformation -> SchemaInformation
dataCast2 :: (forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c SchemaInformation)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c SchemaInformation)
dataCast1 :: (forall d. Data d => c (t d)) -> Maybe (c SchemaInformation)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c SchemaInformation)
dataTypeOf :: SchemaInformation -> DataType
$cdataTypeOf :: SchemaInformation -> DataType
toConstr :: SchemaInformation -> Constr
$ctoConstr :: SchemaInformation -> Constr
gunfold :: (forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c SchemaInformation
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c SchemaInformation
gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> SchemaInformation -> c SchemaInformation
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> SchemaInformation -> c SchemaInformation
$cp1Data :: Typeable SchemaInformation
Data, Int -> SchemaInformation -> ShowS
[SchemaInformation] -> ShowS
SchemaInformation -> String
(Int -> SchemaInformation -> ShowS)
-> (SchemaInformation -> String)
-> ([SchemaInformation] -> ShowS)
-> Show SchemaInformation
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SchemaInformation] -> ShowS
$cshowList :: [SchemaInformation] -> ShowS
show :: SchemaInformation -> String
$cshow :: SchemaInformation -> String
showsPrec :: Int -> SchemaInformation -> ShowS
$cshowsPrec :: Int -> SchemaInformation -> ShowS
Show, (forall x. SchemaInformation -> Rep SchemaInformation x)
-> (forall x. Rep SchemaInformation x -> SchemaInformation)
-> Generic SchemaInformation
forall x. Rep SchemaInformation x -> SchemaInformation
forall x. SchemaInformation -> Rep SchemaInformation x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep SchemaInformation x -> SchemaInformation
$cfrom :: forall x. SchemaInformation -> Rep SchemaInformation x
Generic)
  deriving anyclass (Int -> SchemaInformation -> Int
SchemaInformation -> Int
(Int -> SchemaInformation -> Int)
-> (SchemaInformation -> Int) -> Hashable SchemaInformation
forall a. (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: SchemaInformation -> Int
$chash :: SchemaInformation -> Int
hashWithSalt :: Int -> SchemaInformation -> Int
$chashWithSalt :: Int -> SchemaInformation -> Int
Hashable, SchemaInformation -> ()
(SchemaInformation -> ()) -> NFData SchemaInformation
forall a. (a -> ()) -> NFData a
rnf :: SchemaInformation -> ()
$crnf :: SchemaInformation -> ()
NFData)

-- | JSON, annotated with what schemata it was deemed valid against.
newtype ValidatedJSON = ValidatedJSON (Cofree ValidJSONF SchemaInformation)
  deriving stock (Typeable ValidatedJSON
DataType
Constr
Typeable ValidatedJSON
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> ValidatedJSON -> c ValidatedJSON)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c ValidatedJSON)
-> (ValidatedJSON -> Constr)
-> (ValidatedJSON -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c ValidatedJSON))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e))
    -> Maybe (c ValidatedJSON))
-> ((forall b. Data b => b -> b) -> ValidatedJSON -> ValidatedJSON)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> ValidatedJSON -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> ValidatedJSON -> r)
-> (forall u. (forall d. Data d => d -> u) -> ValidatedJSON -> [u])
-> (forall u.
    Int -> (forall d. Data d => d -> u) -> ValidatedJSON -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> ValidatedJSON -> m ValidatedJSON)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> ValidatedJSON -> m ValidatedJSON)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> ValidatedJSON -> m ValidatedJSON)
-> Data ValidatedJSON
ValidatedJSON -> DataType
ValidatedJSON -> Constr
(forall b. Data b => b -> b) -> ValidatedJSON -> ValidatedJSON
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> ValidatedJSON -> c ValidatedJSON
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c ValidatedJSON
forall a.
Typeable a
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> ValidatedJSON -> u
forall u. (forall d. Data d => d -> u) -> ValidatedJSON -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> ValidatedJSON -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> ValidatedJSON -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> ValidatedJSON -> m ValidatedJSON
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> ValidatedJSON -> m ValidatedJSON
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c ValidatedJSON
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> ValidatedJSON -> c ValidatedJSON
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c ValidatedJSON)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c ValidatedJSON)
$cValidatedJSON :: Constr
$tValidatedJSON :: DataType
gmapMo :: (forall d. Data d => d -> m d) -> ValidatedJSON -> m ValidatedJSON
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> ValidatedJSON -> m ValidatedJSON
gmapMp :: (forall d. Data d => d -> m d) -> ValidatedJSON -> m ValidatedJSON
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> ValidatedJSON -> m ValidatedJSON
gmapM :: (forall d. Data d => d -> m d) -> ValidatedJSON -> m ValidatedJSON
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> ValidatedJSON -> m ValidatedJSON
gmapQi :: Int -> (forall d. Data d => d -> u) -> ValidatedJSON -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> ValidatedJSON -> u
gmapQ :: (forall d. Data d => d -> u) -> ValidatedJSON -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> ValidatedJSON -> [u]
gmapQr :: (r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> ValidatedJSON -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> ValidatedJSON -> r
gmapQl :: (r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> ValidatedJSON -> r
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> ValidatedJSON -> r
gmapT :: (forall b. Data b => b -> b) -> ValidatedJSON -> ValidatedJSON
$cgmapT :: (forall b. Data b => b -> b) -> ValidatedJSON -> ValidatedJSON
dataCast2 :: (forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c ValidatedJSON)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c ValidatedJSON)
dataCast1 :: (forall d. Data d => c (t d)) -> Maybe (c ValidatedJSON)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c ValidatedJSON)
dataTypeOf :: ValidatedJSON -> DataType
$cdataTypeOf :: ValidatedJSON -> DataType
toConstr :: ValidatedJSON -> Constr
$ctoConstr :: ValidatedJSON -> Constr
gunfold :: (forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c ValidatedJSON
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c ValidatedJSON
gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> ValidatedJSON -> c ValidatedJSON
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> ValidatedJSON -> c ValidatedJSON
$cp1Data :: Typeable ValidatedJSON
Data)
  deriving newtype (ValidatedJSON -> ValidatedJSON -> Bool
(ValidatedJSON -> ValidatedJSON -> Bool)
-> (ValidatedJSON -> ValidatedJSON -> Bool) -> Eq ValidatedJSON
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ValidatedJSON -> ValidatedJSON -> Bool
$c/= :: ValidatedJSON -> ValidatedJSON -> Bool
== :: ValidatedJSON -> ValidatedJSON -> Bool
$c== :: ValidatedJSON -> ValidatedJSON -> Bool
Eq, Int -> ValidatedJSON -> ShowS
[ValidatedJSON] -> ShowS
ValidatedJSON -> String
(Int -> ValidatedJSON -> ShowS)
-> (ValidatedJSON -> String)
-> ([ValidatedJSON] -> ShowS)
-> Show ValidatedJSON
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ValidatedJSON] -> ShowS
$cshowList :: [ValidatedJSON] -> ShowS
show :: ValidatedJSON -> String
$cshow :: ValidatedJSON -> String
showsPrec :: Int -> ValidatedJSON -> ShowS
$cshowsPrec :: Int -> ValidatedJSON -> ShowS
Show)

-- Can't coerce-erase the constructor fmap, sigh
instance NFData ValidatedJSON where
  {-# INLINE rnf #-}
  rnf :: ValidatedJSON -> ()
rnf (ValidatedJSON (SchemaInformation
x :< ValidJSONF (Cofree ValidJSONF SchemaInformation)
f)) =
    SchemaInformation -> ()
forall a. NFData a => a -> ()
rnf SchemaInformation
x () -> () -> ()
`seq` (ValidJSONF ValidatedJSON -> ()
forall a. NFData a => a -> ()
rnf (ValidJSONF ValidatedJSON -> ())
-> (ValidJSONF (Cofree ValidJSONF SchemaInformation)
    -> ValidJSONF ValidatedJSON)
-> ValidJSONF (Cofree ValidJSONF SchemaInformation)
-> ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Cofree ValidJSONF SchemaInformation -> ValidatedJSON)
-> ValidJSONF (Cofree ValidJSONF SchemaInformation)
-> ValidJSONF ValidatedJSON
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Cofree ValidJSONF SchemaInformation -> ValidatedJSON
ValidatedJSON (ValidJSONF (Cofree ValidJSONF SchemaInformation) -> ())
-> ValidJSONF (Cofree ValidJSONF SchemaInformation) -> ()
forall a b. (a -> b) -> a -> b
$ ValidJSONF (Cofree ValidJSONF SchemaInformation)
f)

-- Nor here
instance Hashable ValidatedJSON where
  {-# INLINE hashWithSalt #-}
  hashWithSalt :: Int -> ValidatedJSON -> Int
hashWithSalt Int
salt (ValidatedJSON (SchemaInformation
x :< ValidJSONF (Cofree ValidJSONF SchemaInformation)
f)) =
    Int
salt Int -> SchemaInformation -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` SchemaInformation
x Int -> ValidJSONF ValidatedJSON -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` (Cofree ValidJSONF SchemaInformation -> ValidatedJSON)
-> ValidJSONF (Cofree ValidJSONF SchemaInformation)
-> ValidJSONF ValidatedJSON
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Cofree ValidJSONF SchemaInformation -> ValidatedJSON
ValidatedJSON ValidJSONF (Cofree ValidJSONF SchemaInformation)
f

-- | Convert to an Aeson 'Value', throwing away all schema information.
toValue :: ValidatedJSON -> Value
toValue :: ValidatedJSON -> Value
toValue (ValidatedJSON (SchemaInformation
_ :< ValidJSONF (Cofree ValidJSONF SchemaInformation)
f)) = case ValidJSONF (Cofree ValidJSONF SchemaInformation)
f of
  AnythingF Value
v -> Value
v
  ValidJSONF (Cofree ValidJSONF SchemaInformation)
NullF -> Value
Null
  BooleanF Bool
b -> Bool -> Value
Bool Bool
b
  NumberF Scientific
n -> Scientific -> Value
Number Scientific
n
  StringF Text
s -> Text -> Value
String Text
s
  ArrayF Vector (Cofree ValidJSONF SchemaInformation)
v -> Array -> Value
Array (Array -> Value)
-> (Vector (Cofree ValidJSONF SchemaInformation) -> Array)
-> Vector (Cofree ValidJSONF SchemaInformation)
-> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Cofree ValidJSONF SchemaInformation -> Value)
-> Vector (Cofree ValidJSONF SchemaInformation) -> Array
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ValidatedJSON -> Value
toValue (ValidatedJSON -> Value)
-> (Cofree ValidJSONF SchemaInformation -> ValidatedJSON)
-> Cofree ValidJSONF SchemaInformation
-> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cofree ValidJSONF SchemaInformation -> ValidatedJSON
coerce) (Vector (Cofree ValidJSONF SchemaInformation) -> Value)
-> Vector (Cofree ValidJSONF SchemaInformation) -> Value
forall a b. (a -> b) -> a -> b
$ Vector (Cofree ValidJSONF SchemaInformation)
v
  ObjectF HashMap Text (Cofree ValidJSONF SchemaInformation)
hm -> Object -> Value
Object (Object -> Value)
-> (HashMap Text (Cofree ValidJSONF SchemaInformation) -> Object)
-> HashMap Text (Cofree ValidJSONF SchemaInformation)
-> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Cofree ValidJSONF SchemaInformation -> Value)
-> HashMap Text (Cofree ValidJSONF SchemaInformation) -> Object
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ValidatedJSON -> Value
toValue (ValidatedJSON -> Value)
-> (Cofree ValidJSONF SchemaInformation -> ValidatedJSON)
-> Cofree ValidJSONF SchemaInformation
-> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cofree ValidJSONF SchemaInformation -> ValidatedJSON
coerce) (HashMap Text (Cofree ValidJSONF SchemaInformation) -> Value)
-> HashMap Text (Cofree ValidJSONF SchemaInformation) -> Value
forall a b. (a -> b) -> a -> b
$ HashMap Text (Cofree ValidJSONF SchemaInformation)
hm

-- | What schema did this validate against?
validAgainst :: ValidatedJSON -> SchemaInformation
validAgainst :: ValidatedJSON -> SchemaInformation
validAgainst (ValidatedJSON (SchemaInformation
label :< ValidJSONF (Cofree ValidJSONF SchemaInformation)
_)) = SchemaInformation
label -- TODO: This is a bit useless right now.

-- | All possible validation errors.
data ValidationError
  = EmptyError
  | -- | We could not parse JSON out of what we were provided.
    NotJSON
  | -- | We got a type different to what we expected.
    WrongType 
      !Value -- ^ The chunk of JSON. 
      !JSONType -- ^ What we expected the type to be.
  | -- | We expected one of several possibilities, but got something that fits
    -- none.
    NotOneOfOptions !Value
  | -- | We found a JSON object with a property that wasn't specified in its
    -- schema, and additional properties are forbidden.
    AdditionalPropFoundButBanned 
      {-# UNPACK #-} !Text -- ^ The property in question. 
      {-# UNPACK #-} !Text -- ^ The name of the specifying schema.
  | -- | We found a JSON object which is missing a property its schema requires.
    RequiredPropertyIsMissing 
      {-# UNPACK #-} !Text -- ^ The property in question.
      {-# UNPACK #-} !Text -- ^ The name of the specifying schema.
  | -- | We found a JSON array which falls outside of the minimum or maximum 
    -- length constraints its corresponding schema demands.
    OutOfBoundsArrayLength 
      {-# UNPACK #-} !Text -- ^ The name of the specifying schema. 
      !Value -- ^ The JSON chunk corresponding to the invalid array.
  | -- | This is a bug - please report it to us!
    ImplementationError 
      {-# UNPACK #-} !Text -- some descriptive text
  deriving stock (ValidationError -> ValidationError -> Bool
(ValidationError -> ValidationError -> Bool)
-> (ValidationError -> ValidationError -> Bool)
-> Eq ValidationError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ValidationError -> ValidationError -> Bool
$c/= :: ValidationError -> ValidationError -> Bool
== :: ValidationError -> ValidationError -> Bool
$c== :: ValidationError -> ValidationError -> Bool
Eq, Int -> ValidationError -> ShowS
[ValidationError] -> ShowS
ValidationError -> String
(Int -> ValidationError -> ShowS)
-> (ValidationError -> String)
-> ([ValidationError] -> ShowS)
-> Show ValidationError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ValidationError] -> ShowS
$cshowList :: [ValidationError] -> ShowS
show :: ValidationError -> String
$cshow :: ValidationError -> String
showsPrec :: Int -> ValidationError -> ShowS
$cshowsPrec :: Int -> ValidationError -> ShowS
Show, (forall x. ValidationError -> Rep ValidationError x)
-> (forall x. Rep ValidationError x -> ValidationError)
-> Generic ValidationError
forall x. Rep ValidationError x -> ValidationError
forall x. ValidationError -> Rep ValidationError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ValidationError x -> ValidationError
$cfrom :: forall x. ValidationError -> Rep ValidationError x
Generic)
  deriving anyclass (Int -> ValidationError -> Int
ValidationError -> Int
(Int -> ValidationError -> Int)
-> (ValidationError -> Int) -> Hashable ValidationError
forall a. (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: ValidationError -> Int
$chash :: ValidationError -> Int
hashWithSalt :: Int -> ValidationError -> Int
$chashWithSalt :: Int -> ValidationError -> Int
Hashable)

instance Semigroup ValidationError where
  ValidationError
EmptyError <> :: ValidationError -> ValidationError -> ValidationError
<> ValidationError
x = ValidationError
x
  ValidationError
x <> ValidationError
_ = ValidationError
x

instance Monoid ValidationError where
  mempty :: ValidationError
mempty = ValidationError
EmptyError

-- | Attempt to construct validated JSON from a bytestring.
-- This will attempt to decode using Aeson before validating.
validate ::
  (MonadPlus m, MonadError ValidationError m) =>
  Schema ->
  ByteString ->
  m ValidatedJSON
validate :: Schema -> ByteString -> m ValidatedJSON
validate Schema
scm ByteString
bs = case ByteString -> Maybe Value
forall a. FromJSON a => ByteString -> Maybe a
decode ByteString
bs of
  Maybe Value
Nothing -> ValidationError -> m ValidatedJSON
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ValidationError
NotJSON
  Just Value
v -> Cofree ValidJSONF SchemaInformation -> ValidatedJSON
ValidatedJSON (Cofree ValidJSONF SchemaInformation -> ValidatedJSON)
-> m (Cofree ValidJSONF SchemaInformation) -> m ValidatedJSON
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> m (Cofree ValidJSONF SchemaInformation)
forall (m :: * -> *).
(MonadPlus m, MonadError ValidationError m) =>
Value -> m (Cofree ValidJSONF SchemaInformation)
go Value
v
  where
    go :: Value -> m (Cofree ValidJSONF SchemaInformation)
go Value
v = ReaderT Schema m (Cofree ValidJSONF SchemaInformation)
-> Schema -> m (Cofree ValidJSONF SchemaInformation)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (StateT
  (NESet TypeNode, Maybe Identifier)
  (ReaderT Schema m)
  (Cofree ValidJSONF SchemaInformation)
-> (NESet TypeNode, Maybe Identifier)
-> ReaderT Schema m (Cofree ValidJSONF SchemaInformation)
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (Value
-> StateT
     (NESet TypeNode, Maybe Identifier)
     (ReaderT Schema m)
     (Cofree ValidJSONF SchemaInformation)
forall (m :: * -> *).
(Alternative m, MonadReader Schema m,
 MonadState (NESet TypeNode, Maybe Identifier) m,
 MonadError ValidationError m) =>
Value -> m (Cofree ValidJSONF SchemaInformation)
checkTypes Value
v) (NESet TypeNode
initialSet, Maybe Identifier
forall a. Maybe a
Nothing)) Schema
scm
    initialSet :: NESet TypeNode
initialSet = TypeNode -> NESet TypeNode
forall a. a -> NESet a
singleton (TypeNode -> NESet TypeNode)
-> (ReservedIdentifier -> TypeNode)
-> ReservedIdentifier
-> NESet TypeNode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identifier -> TypeNode
CustomNode (Identifier -> TypeNode)
-> (ReservedIdentifier -> Identifier)
-> ReservedIdentifier
-> TypeNode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReservedIdentifier -> Identifier
identFromReserved (ReservedIdentifier -> NESet TypeNode)
-> ReservedIdentifier -> NESet TypeNode
forall a b. (a -> b) -> a -> b
$ ReservedIdentifier
RStart

-- | Helper for construction of validated JSON from a JSON file.
-- This will attempt to decode using Aeson before validating.
validateFromFile ::
  (MonadPlus m, MonadError ValidationError m, MonadIO m) =>
  Schema ->
  FilePath ->
  m ValidatedJSON
validateFromFile :: Schema -> String -> m ValidatedJSON
validateFromFile Schema
scm String
fp = do
  ByteString
bs <- IO ByteString -> m ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO ByteString
BS.readFile String
fp)
  Schema -> ByteString -> m ValidatedJSON
forall (m :: * -> *).
(MonadPlus m, MonadError ValidationError m) =>
Schema -> ByteString -> m ValidatedJSON
validate Schema
scm ByteString
bs

-- | Helper for construction of validated JSON from a 'Handle'.
-- This will set the argument 'Handle' to binary mode, as this function won't
-- work otherwise. This function will close the 'Handle' once it finds EOF.
-- This will attempt to decode using Aeson before validating.
validateFromHandle ::
  (MonadPlus m, MonadError ValidationError m, MonadIO m) =>
  Schema ->
  Handle ->
  m ValidatedJSON
validateFromHandle :: Schema -> Handle -> m ValidatedJSON
validateFromHandle Schema
scm Handle
h = do
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Handle -> Bool -> IO ()
hSetBinaryMode Handle
h Bool
True)
  ByteString
bs <- IO ByteString -> m ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Handle -> IO ByteString
BS.hGetContents Handle
h)
  Schema -> ByteString -> m ValidatedJSON
forall (m :: * -> *).
(MonadPlus m, MonadError ValidationError m) =>
Schema -> ByteString -> m ValidatedJSON
validate Schema
scm ByteString
bs

-- Helpers

-- We have 3 different cases:
-- 1. If we are checking against AnyNode, we ALWAYS succeed.
-- 2. If we are checking against PrimitiveNode, we can match with EXACTLY ONE
--    kind of PrimitiveNode.
-- 3. If we are checking against CustomNode, we can match against ANY CustomNode.
--    Thus, we must try all of them.
checkTypes ::
  (Alternative m, MonadReader Schema m, MonadState (NESet TypeNode, Maybe Identifier) m, MonadError ValidationError m) =>
  Value ->
  m (Cofree ValidJSONF SchemaInformation)
checkTypes :: Value -> m (Cofree ValidJSONF SchemaInformation)
checkTypes Value
v = Value -> m (Cofree ValidJSONF SchemaInformation)
forall (m :: * -> *).
(Alternative m, MonadState (NESet TypeNode, Maybe Identifier) m,
 MonadError ValidationError m) =>
Value -> m (Cofree ValidJSONF SchemaInformation)
checkAny Value
v m (Cofree ValidJSONF SchemaInformation)
-> m (Cofree ValidJSONF SchemaInformation)
-> m (Cofree ValidJSONF SchemaInformation)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Value -> m (Cofree ValidJSONF SchemaInformation)
forall (m :: * -> *).
(Alternative m, MonadReader Schema m,
 MonadState (NESet TypeNode, Maybe Identifier) m,
 MonadError ValidationError m) =>
Value -> m (Cofree ValidJSONF SchemaInformation)
checkPrim Value
v m (Cofree ValidJSONF SchemaInformation)
-> m (Cofree ValidJSONF SchemaInformation)
-> m (Cofree ValidJSONF SchemaInformation)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Value -> m (Cofree ValidJSONF SchemaInformation)
forall (m :: * -> *).
(Alternative m, MonadReader Schema m,
 MonadState (NESet TypeNode, Maybe Identifier) m,
 MonadError ValidationError m) =>
Value -> m (Cofree ValidJSONF SchemaInformation)
checkCustoms Value
v

-- checkAny throws EmptyError if AnyNode is not found. This lets checkTypes
-- use the error thrown by checkPrim/checkCustoms if checkAny fails.
checkAny ::
  (Alternative m, MonadState (NESet TypeNode, Maybe Identifier) m, MonadError ValidationError m) =>
  Value ->
  m (Cofree ValidJSONF SchemaInformation)
checkAny :: Value -> m (Cofree ValidJSONF SchemaInformation)
checkAny Value
v = do
  TypeNode
minNode <- ((NESet TypeNode, Maybe Identifier) -> TypeNode) -> m TypeNode
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (((NESet TypeNode, Maybe Identifier) -> TypeNode) -> m TypeNode)
-> ((NESet TypeNode, Maybe Identifier) -> TypeNode) -> m TypeNode
forall a b. (a -> b) -> a -> b
$ NESet TypeNode -> TypeNode
forall a. NESet a -> a
findMin (NESet TypeNode -> TypeNode)
-> ((NESet TypeNode, Maybe Identifier) -> NESet TypeNode)
-> (NESet TypeNode, Maybe Identifier)
-> TypeNode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NESet TypeNode, Maybe Identifier) -> NESet TypeNode
forall a b. (a, b) -> a
fst -- AnyNode is the smallest possible TypeNode.
  case TypeNode
minNode of
    TypeNode
AnyNode -> Cofree ValidJSONF SchemaInformation
-> m (Cofree ValidJSONF SchemaInformation)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Cofree ValidJSONF SchemaInformation
 -> m (Cofree ValidJSONF SchemaInformation))
-> Cofree ValidJSONF SchemaInformation
-> m (Cofree ValidJSONF SchemaInformation)
forall a b. (a -> b) -> a -> b
$ SchemaInformation
AnySchema SchemaInformation
-> ValidJSONF (Cofree ValidJSONF SchemaInformation)
-> Cofree ValidJSONF SchemaInformation
forall (f :: * -> *) a. a -> f (Cofree f a) -> Cofree f a
:< Value -> ValidJSONF (Cofree ValidJSONF SchemaInformation)
forall a. Value -> ValidJSONF a
AnythingF Value
v
    TypeNode
_ -> ValidationError -> m (Cofree ValidJSONF SchemaInformation)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ValidationError
EmptyError

-- checkPrim searches the NESet for the PrimitiveNode corresponding to the Value, otherwise throws an error.
checkPrim ::
  (Alternative m, MonadReader Schema m, MonadState (NESet TypeNode, Maybe Identifier) m, MonadError ValidationError m) =>
  Value ->
  m (Cofree ValidJSONF SchemaInformation)
checkPrim :: Value -> m (Cofree ValidJSONF SchemaInformation)
checkPrim Value
v = do
  (NESet TypeNode
nodes, Maybe Identifier
par) <- ((NESet TypeNode, Maybe Identifier)
 -> (NESet TypeNode, Maybe Identifier))
-> m (NESet TypeNode, Maybe Identifier)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (NESet TypeNode, Maybe Identifier)
-> (NESet TypeNode, Maybe Identifier)
forall a. a -> a
id
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (TypeNode -> NESet TypeNode -> Bool
forall a. Ord a => a -> NESet a -> Bool
member (JSONType -> TypeNode
PrimitiveNode (JSONType -> TypeNode) -> (Value -> JSONType) -> Value -> TypeNode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> JSONType
typeOf (Value -> TypeNode) -> Value -> TypeNode
forall a b. (a -> b) -> a -> b
$ Value
v) NESet TypeNode
nodes) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ ValidationError -> m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ValidationError -> m ())
-> (Value -> ValidationError) -> Value -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> ValidationError
NotOneOfOptions (Value -> m ()) -> Value -> m ()
forall a b. (a -> b) -> a -> b
$ Value
v
  case Value
v of
    Value
Null -> Cofree ValidJSONF SchemaInformation
-> m (Cofree ValidJSONF SchemaInformation)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Cofree ValidJSONF SchemaInformation
 -> m (Cofree ValidJSONF SchemaInformation))
-> Cofree ValidJSONF SchemaInformation
-> m (Cofree ValidJSONF SchemaInformation)
forall a b. (a -> b) -> a -> b
$ SchemaInformation
NullSchema SchemaInformation
-> ValidJSONF (Cofree ValidJSONF SchemaInformation)
-> Cofree ValidJSONF SchemaInformation
forall (f :: * -> *) a. a -> f (Cofree f a) -> Cofree f a
:< ValidJSONF (Cofree ValidJSONF SchemaInformation)
forall a. ValidJSONF a
NullF
    Bool Bool
b -> Cofree ValidJSONF SchemaInformation
-> m (Cofree ValidJSONF SchemaInformation)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Cofree ValidJSONF SchemaInformation
 -> m (Cofree ValidJSONF SchemaInformation))
-> Cofree ValidJSONF SchemaInformation
-> m (Cofree ValidJSONF SchemaInformation)
forall a b. (a -> b) -> a -> b
$ SchemaInformation
BooleanSchema SchemaInformation
-> ValidJSONF (Cofree ValidJSONF SchemaInformation)
-> Cofree ValidJSONF SchemaInformation
forall (f :: * -> *) a. a -> f (Cofree f a) -> Cofree f a
:< Bool -> ValidJSONF (Cofree ValidJSONF SchemaInformation)
forall a. Bool -> ValidJSONF a
BooleanF Bool
b
    Number Scientific
n -> Cofree ValidJSONF SchemaInformation
-> m (Cofree ValidJSONF SchemaInformation)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Cofree ValidJSONF SchemaInformation
 -> m (Cofree ValidJSONF SchemaInformation))
-> Cofree ValidJSONF SchemaInformation
-> m (Cofree ValidJSONF SchemaInformation)
forall a b. (a -> b) -> a -> b
$ SchemaInformation
NumberSchema SchemaInformation
-> ValidJSONF (Cofree ValidJSONF SchemaInformation)
-> Cofree ValidJSONF SchemaInformation
forall (f :: * -> *) a. a -> f (Cofree f a) -> Cofree f a
:< Scientific -> ValidJSONF (Cofree ValidJSONF SchemaInformation)
forall a. Scientific -> ValidJSONF a
NumberF Scientific
n
    String Text
s -> case Maybe Identifier
par of
      -- if we are checking against a dependant string, we match against the supplied values
      Maybe Identifier
Nothing -> Cofree ValidJSONF SchemaInformation
-> m (Cofree ValidJSONF SchemaInformation)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Cofree ValidJSONF SchemaInformation
 -> m (Cofree ValidJSONF SchemaInformation))
-> Cofree ValidJSONF SchemaInformation
-> m (Cofree ValidJSONF SchemaInformation)
forall a b. (a -> b) -> a -> b
$ SchemaInformation
StringSchema SchemaInformation
-> ValidJSONF (Cofree ValidJSONF SchemaInformation)
-> Cofree ValidJSONF SchemaInformation
forall (f :: * -> *) a. a -> f (Cofree f a) -> Cofree f a
:< Text -> ValidJSONF (Cofree ValidJSONF SchemaInformation)
forall a. Text -> ValidJSONF a
StringF Text
s
      Just Identifier
parIdent -> do
        CompiledSchema
scm <- Identifier -> m CompiledSchema
forall (m :: * -> *).
(MonadReader Schema m, MonadError ValidationError m) =>
Identifier -> m CompiledSchema
lookupSchema Identifier
parIdent
        let validVals :: Vector Text
validVals = CompiledSchema -> Vector Text
stringVals CompiledSchema
scm
        if Text
s Text -> Vector Text -> Bool
forall a. Eq a => a -> Vector a -> Bool
`V.elem` Vector Text
validVals Bool -> Bool -> Bool
|| Vector Text -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Vector Text
validVals
          then Cofree ValidJSONF SchemaInformation
-> m (Cofree ValidJSONF SchemaInformation)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Cofree ValidJSONF SchemaInformation
 -> m (Cofree ValidJSONF SchemaInformation))
-> Cofree ValidJSONF SchemaInformation
-> m (Cofree ValidJSONF SchemaInformation)
forall a b. (a -> b) -> a -> b
$ SchemaInformation
StringSchema SchemaInformation
-> ValidJSONF (Cofree ValidJSONF SchemaInformation)
-> Cofree ValidJSONF SchemaInformation
forall (f :: * -> *) a. a -> f (Cofree f a) -> Cofree f a
:< Text -> ValidJSONF (Cofree ValidJSONF SchemaInformation)
forall a. Text -> ValidJSONF a
StringF Text
s
          else ValidationError -> m (Cofree ValidJSONF SchemaInformation)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ValidationError -> m (Cofree ValidJSONF SchemaInformation))
-> ValidationError -> m (Cofree ValidJSONF SchemaInformation)
forall a b. (a -> b) -> a -> b
$ Value -> ValidationError
NotOneOfOptions Value
v
    Array Array
arr -> case Maybe Identifier
par of
      Maybe Identifier
Nothing -> (NESet TypeNode, Maybe Identifier) -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (NESet TypeNode
anySet, Maybe Identifier
forall a. Maybe a
Nothing) m ()
-> m (Cofree ValidJSONF SchemaInformation)
-> m (Cofree ValidJSONF SchemaInformation)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (SchemaInformation
ArraySchema SchemaInformation
-> ValidJSONF (Cofree ValidJSONF SchemaInformation)
-> Cofree ValidJSONF SchemaInformation
forall (f :: * -> *) a. a -> f (Cofree f a) -> Cofree f a
:<) (ValidJSONF (Cofree ValidJSONF SchemaInformation)
 -> Cofree ValidJSONF SchemaInformation)
-> (Vector (Cofree ValidJSONF SchemaInformation)
    -> ValidJSONF (Cofree ValidJSONF SchemaInformation))
-> Vector (Cofree ValidJSONF SchemaInformation)
-> Cofree ValidJSONF SchemaInformation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector (Cofree ValidJSONF SchemaInformation)
-> ValidJSONF (Cofree ValidJSONF SchemaInformation)
forall a. Vector a -> ValidJSONF a
ArrayF (Vector (Cofree ValidJSONF SchemaInformation)
 -> Cofree ValidJSONF SchemaInformation)
-> m (Vector (Cofree ValidJSONF SchemaInformation))
-> m (Cofree ValidJSONF SchemaInformation)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Value -> m (Cofree ValidJSONF SchemaInformation))
-> Array -> m (Vector (Cofree ValidJSONF SchemaInformation))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Value -> m (Cofree ValidJSONF SchemaInformation)
forall (m :: * -> *).
(Alternative m, MonadReader Schema m,
 MonadState (NESet TypeNode, Maybe Identifier) m,
 MonadError ValidationError m) =>
Value -> m (Cofree ValidJSONF SchemaInformation)
checkTypes Array
arr
      Just Identifier
parIdent -> Array -> Identifier -> m (Cofree ValidJSONF SchemaInformation)
forall (m :: * -> *).
(Alternative m, MonadReader Schema m,
 MonadState (NESet TypeNode, Maybe Identifier) m,
 MonadError ValidationError m) =>
Array -> Identifier -> m (Cofree ValidJSONF SchemaInformation)
checkArray Array
arr Identifier
parIdent
    Object Object
obj -> case Maybe Identifier
par of
      -- Fast Path (no object spec)
      Maybe Identifier
Nothing -> (NESet TypeNode, Maybe Identifier) -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (NESet TypeNode
anySet, Maybe Identifier
forall a. Maybe a
Nothing) m ()
-> m (Cofree ValidJSONF SchemaInformation)
-> m (Cofree ValidJSONF SchemaInformation)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (SchemaInformation
ObjectSchema SchemaInformation
-> ValidJSONF (Cofree ValidJSONF SchemaInformation)
-> Cofree ValidJSONF SchemaInformation
forall (f :: * -> *) a. a -> f (Cofree f a) -> Cofree f a
:<) (ValidJSONF (Cofree ValidJSONF SchemaInformation)
 -> Cofree ValidJSONF SchemaInformation)
-> (HashMap Text (Cofree ValidJSONF SchemaInformation)
    -> ValidJSONF (Cofree ValidJSONF SchemaInformation))
-> HashMap Text (Cofree ValidJSONF SchemaInformation)
-> Cofree ValidJSONF SchemaInformation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashMap Text (Cofree ValidJSONF SchemaInformation)
-> ValidJSONF (Cofree ValidJSONF SchemaInformation)
forall a. HashMap Text a -> ValidJSONF a
ObjectF (HashMap Text (Cofree ValidJSONF SchemaInformation)
 -> Cofree ValidJSONF SchemaInformation)
-> m (HashMap Text (Cofree ValidJSONF SchemaInformation))
-> m (Cofree ValidJSONF SchemaInformation)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Value -> m (Cofree ValidJSONF SchemaInformation))
-> Object -> m (HashMap Text (Cofree ValidJSONF SchemaInformation))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Value -> m (Cofree ValidJSONF SchemaInformation)
forall (m :: * -> *).
(Alternative m, MonadReader Schema m,
 MonadState (NESet TypeNode, Maybe Identifier) m,
 MonadError ValidationError m) =>
Value -> m (Cofree ValidJSONF SchemaInformation)
checkTypes Object
obj
      Just Identifier
parIdent -> Object -> Identifier -> m (Cofree ValidJSONF SchemaInformation)
forall (m :: * -> *).
(Alternative m, MonadReader Schema m,
 MonadState (NESet TypeNode, Maybe Identifier) m,
 MonadError ValidationError m) =>
Object -> Identifier -> m (Cofree ValidJSONF SchemaInformation)
checkObject Object
obj Identifier
parIdent

-- check if the array length is within the specification range.
checkArray ::
  (Alternative m, MonadReader Schema m, MonadState (NESet TypeNode, Maybe Identifier) m, MonadError ValidationError m) =>
  Array ->
  Identifier ->
  m (Cofree ValidJSONF SchemaInformation)
checkArray :: Array -> Identifier -> m (Cofree ValidJSONF SchemaInformation)
checkArray Array
arr Identifier
parIdent = do
  CompiledSchema
scm <- Identifier -> m CompiledSchema
forall (m :: * -> *).
(MonadReader Schema m, MonadError ValidationError m) =>
Identifier -> m CompiledSchema
lookupSchema Identifier
parIdent
  let arrLen :: Natural
arrLen = Int -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Natural) -> Int -> Natural
forall a b. (a -> b) -> a -> b
$ Array -> Int
forall a. Vector a -> Int
V.length Array
arr
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when
    ( Bool -> (Natural -> Bool) -> Maybe Natural -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Natural
arrLen Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
<) (CompiledSchema -> Maybe Natural
minArrayLen CompiledSchema
scm)
        Bool -> Bool -> Bool
|| Bool -> (Natural -> Bool) -> Maybe Natural -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Natural
arrLen Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
>) (CompiledSchema -> Maybe Natural
maxArrayLen CompiledSchema
scm)
    )
    (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ ValidationError -> m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ValidationError -> m ())
-> (Array -> ValidationError) -> Array -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Value -> ValidationError
OutOfBoundsArrayLength (Identifier -> Text
textify Identifier
parIdent) (Value -> ValidationError)
-> (Array -> Value) -> Array -> ValidationError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Array -> Value
Array
    (Array -> m ()) -> Array -> m ()
forall a b. (a -> b) -> a -> b
$ Array
arr
  let valsAndTypes :: Vector (Value, TypeNode)
valsAndTypes = Maybe ArrayType -> Vector (Value, TypeNode)
pairValsWithTypes (Maybe ArrayType -> Vector (Value, TypeNode))
-> Maybe ArrayType -> Vector (Value, TypeNode)
forall a b. (a -> b) -> a -> b
$ CompiledSchema -> Maybe ArrayType
arrayTypes CompiledSchema
scm
  Vector (Cofree ValidJSONF SchemaInformation)
checkedArray <- ((Value, TypeNode) -> m (Cofree ValidJSONF SchemaInformation))
-> Vector (Value, TypeNode)
-> m (Vector (Cofree ValidJSONF SchemaInformation))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\(Value
val, TypeNode
typeNode) -> (NESet TypeNode, Maybe Identifier) -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (TypeNode -> NESet TypeNode
forall a. a -> NESet a
singleton TypeNode
typeNode, Maybe Identifier
forall a. Maybe a
Nothing) m ()
-> m (Cofree ValidJSONF SchemaInformation)
-> m (Cofree ValidJSONF SchemaInformation)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Value -> m (Cofree ValidJSONF SchemaInformation)
forall (m :: * -> *).
(Alternative m, MonadReader Schema m,
 MonadState (NESet TypeNode, Maybe Identifier) m,
 MonadError ValidationError m) =>
Value -> m (Cofree ValidJSONF SchemaInformation)
checkTypes Value
val) Vector (Value, TypeNode)
valsAndTypes
  Cofree ValidJSONF SchemaInformation
-> m (Cofree ValidJSONF SchemaInformation)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Cofree ValidJSONF SchemaInformation
 -> m (Cofree ValidJSONF SchemaInformation))
-> Cofree ValidJSONF SchemaInformation
-> m (Cofree ValidJSONF SchemaInformation)
forall a b. (a -> b) -> a -> b
$ SchemaInformation
ArraySchema SchemaInformation
-> ValidJSONF (Cofree ValidJSONF SchemaInformation)
-> Cofree ValidJSONF SchemaInformation
forall (f :: * -> *) a. a -> f (Cofree f a) -> Cofree f a
:< Vector (Cofree ValidJSONF SchemaInformation)
-> ValidJSONF (Cofree ValidJSONF SchemaInformation)
forall a. Vector a -> ValidJSONF a
ArrayF Vector (Cofree ValidJSONF SchemaInformation)
checkedArray
  where
    pairValsWithTypes :: Maybe ArrayType -> Vector (Value, TypeNode)
pairValsWithTypes Maybe ArrayType
Nothing = (Value -> (Value, TypeNode)) -> Array -> Vector (Value, TypeNode)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (,TypeNode
AnyNode) Array
arr
    pairValsWithTypes (Just (ListType TypeNode
node)) = (Value -> (Value, TypeNode)) -> Array -> Vector (Value, TypeNode)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (,TypeNode
node) Array
arr
    pairValsWithTypes (Just (TupleType Vector TypeNode
nodes)) = Array -> Vector TypeNode -> Vector (Value, TypeNode)
forall a b. Vector a -> Vector b -> Vector (a, b)
V.zip Array
arr Vector TypeNode
nodes

-- check if object properties satisfy the corresponding specification.
checkObject ::
  (Alternative m, MonadReader Schema m, MonadState (NESet TypeNode, Maybe Identifier) m, MonadError ValidationError m) =>
  Object ->
  Identifier ->
  m (Cofree ValidJSONF SchemaInformation)
checkObject :: Object -> Identifier -> m (Cofree ValidJSONF SchemaInformation)
checkObject Object
obj Identifier
parIdent = do
  HashMap Text (Value, TypeNode)
valsAndTypes <- Object -> Identifier -> m (HashMap Text (Value, TypeNode))
forall (m :: * -> *).
(Alternative m, MonadReader Schema m,
 MonadError ValidationError m) =>
Object -> Identifier -> m (HashMap Text (Value, TypeNode))
pairPropertySchemaAndVal Object
obj Identifier
parIdent
  HashMap Text (Cofree ValidJSONF SchemaInformation)
checkedObj <- ((Value, TypeNode) -> m (Cofree ValidJSONF SchemaInformation))
-> HashMap Text (Value, TypeNode)
-> m (HashMap Text (Cofree ValidJSONF SchemaInformation))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\(Value
val, TypeNode
typeNode) -> (NESet TypeNode, Maybe Identifier) -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (TypeNode -> NESet TypeNode
forall a. a -> NESet a
singleton TypeNode
typeNode, Maybe Identifier
forall a. Maybe a
Nothing) m ()
-> m (Cofree ValidJSONF SchemaInformation)
-> m (Cofree ValidJSONF SchemaInformation)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Value -> m (Cofree ValidJSONF SchemaInformation)
forall (m :: * -> *).
(Alternative m, MonadReader Schema m,
 MonadState (NESet TypeNode, Maybe Identifier) m,
 MonadError ValidationError m) =>
Value -> m (Cofree ValidJSONF SchemaInformation)
checkTypes Value
val) HashMap Text (Value, TypeNode)
valsAndTypes
  Cofree ValidJSONF SchemaInformation
-> m (Cofree ValidJSONF SchemaInformation)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Cofree ValidJSONF SchemaInformation
 -> m (Cofree ValidJSONF SchemaInformation))
-> Cofree ValidJSONF SchemaInformation
-> m (Cofree ValidJSONF SchemaInformation)
forall a b. (a -> b) -> a -> b
$ SchemaInformation
ObjectSchema SchemaInformation
-> ValidJSONF (Cofree ValidJSONF SchemaInformation)
-> Cofree ValidJSONF SchemaInformation
forall (f :: * -> *) a. a -> f (Cofree f a) -> Cofree f a
:< HashMap Text (Cofree ValidJSONF SchemaInformation)
-> ValidJSONF (Cofree ValidJSONF SchemaInformation)
forall a. HashMap Text a -> ValidJSONF a
ObjectF HashMap Text (Cofree ValidJSONF SchemaInformation)
checkedObj

pairPropertySchemaAndVal ::
  (Alternative m, MonadReader Schema m, MonadError ValidationError m) =>
  HM.HashMap Text Value ->
  Identifier ->
  m (HM.HashMap Text (Value, TypeNode))
pairPropertySchemaAndVal :: Object -> Identifier -> m (HashMap Text (Value, TypeNode))
pairPropertySchemaAndVal Object
obj Identifier
parIdent = do
  CompiledSchema
scm <- Identifier -> m CompiledSchema
forall (m :: * -> *).
(MonadReader Schema m, MonadError ValidationError m) =>
Identifier -> m CompiledSchema
lookupSchema Identifier
parIdent
  HashMap Text (Value, TypeNode)
mappedObj <- ((Text, Value) -> m (Value, TypeNode))
-> HashMap Text (Text, Value) -> m (HashMap Text (Value, TypeNode))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (CompiledSchema -> (Text, Value) -> m (Value, TypeNode)
forall (f :: * -> *) a.
MonadError ValidationError f =>
CompiledSchema -> (Text, a) -> f (a, TypeNode)
pairProperty CompiledSchema
scm) (HashMap Text (Text, Value) -> m (HashMap Text (Value, TypeNode)))
-> HashMap Text (Text, Value) -> m (HashMap Text (Value, TypeNode))
forall a b. (a -> b) -> a -> b
$ (Text -> Value -> (Text, Value))
-> Object -> HashMap Text (Text, Value)
forall k v1 v2. (k -> v1 -> v2) -> HashMap k v1 -> HashMap k v2
HM.mapWithKey (,) Object
obj
  ((Text, (TypeNode, Bool)) -> m ())
-> HashMap Text (Text, (TypeNode, Bool)) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Text, (TypeNode, Bool)) -> m ()
forall (f :: * -> *) a.
MonadError ValidationError f =>
(Text, (a, Bool)) -> f ()
isMatched (HashMap Text (Text, (TypeNode, Bool)) -> m ())
-> (HashMap Text (TypeNode, Bool)
    -> HashMap Text (Text, (TypeNode, Bool)))
-> HashMap Text (TypeNode, Bool)
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> (TypeNode, Bool) -> (Text, (TypeNode, Bool)))
-> HashMap Text (TypeNode, Bool)
-> HashMap Text (Text, (TypeNode, Bool))
forall k v1 v2. (k -> v1 -> v2) -> HashMap k v1 -> HashMap k v2
HM.mapWithKey (,) (HashMap Text (TypeNode, Bool) -> m ())
-> HashMap Text (TypeNode, Bool) -> m ()
forall a b. (a -> b) -> a -> b
$ CompiledSchema -> HashMap Text (TypeNode, Bool)
props CompiledSchema
scm
  HashMap Text (Value, TypeNode)
-> m (HashMap Text (Value, TypeNode))
forall (f :: * -> *) a. Applicative f => a -> f a
pure HashMap Text (Value, TypeNode)
mappedObj
  where
    -- maps each property-value with the schema(typeNode) it should validate against
    pairProperty :: CompiledSchema -> (Text, a) -> f (a, TypeNode)
pairProperty CompiledSchema
scm (Text
propName, a
v) = case Text -> HashMap Text (TypeNode, Bool) -> Maybe (TypeNode, Bool)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup Text
propName (HashMap Text (TypeNode, Bool) -> Maybe (TypeNode, Bool))
-> HashMap Text (TypeNode, Bool) -> Maybe (TypeNode, Bool)
forall a b. (a -> b) -> a -> b
$ CompiledSchema -> HashMap Text (TypeNode, Bool)
props CompiledSchema
scm of
      Just (TypeNode
typeNode, Bool
_) -> (a, TypeNode) -> f (a, TypeNode)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
v, TypeNode
typeNode)
      Maybe (TypeNode, Bool)
Nothing
        | CompiledSchema -> Bool
additionalProps CompiledSchema
scm -> (a, TypeNode) -> f (a, TypeNode)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
v, CompiledSchema -> TypeNode
additionalPropSchema CompiledSchema
scm)
        | Bool
otherwise -> ValidationError -> f (a, TypeNode)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ValidationError -> f (a, TypeNode))
-> (Text -> ValidationError) -> Text -> f (a, TypeNode)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> ValidationError
AdditionalPropFoundButBanned (Identifier -> Text
textify Identifier
parIdent) (Text -> f (a, TypeNode)) -> Text -> f (a, TypeNode)
forall a b. (a -> b) -> a -> b
$ Text
propName
    -- throws ann error if a non-optional property was not found in the object
    isMatched :: (Text, (a, Bool)) -> f ()
isMatched (Text
propName, (a
_, Bool
optional)) =
      Bool -> f () -> f ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe Value -> Bool
forall a. Maybe a -> Bool
isNothing (Text -> Object -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup Text
propName Object
obj) Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
optional)
        (f () -> f ()) -> f () -> f ()
forall a b. (a -> b) -> a -> b
$ ValidationError -> f ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ValidationError -> f ())
-> (Text -> ValidationError) -> Text -> f ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> ValidationError
RequiredPropertyIsMissing (Identifier -> Text
textify Identifier
parIdent)
        (Text -> f ()) -> Text -> f ()
forall a b. (a -> b) -> a -> b
$ Text
propName

-- checkCustoms removes all non custom nodes from the typeNode set and
-- checks the Value against each until one succeeds.
checkCustoms ::
  (Alternative m, MonadReader Schema m, MonadState (NESet TypeNode, Maybe Identifier) m, MonadError ValidationError m) =>
  Value ->
  m (Cofree ValidJSONF SchemaInformation)
checkCustoms :: Value -> m (Cofree ValidJSONF SchemaInformation)
checkCustoms Value
v = do
  -- Here we drop all non custom nodes.
  Set TypeNode
customNodes <- ((NESet TypeNode, Maybe Identifier) -> Set TypeNode)
-> m (Set TypeNode)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (((NESet TypeNode, Maybe Identifier) -> Set TypeNode)
 -> m (Set TypeNode))
-> ((NESet TypeNode, Maybe Identifier) -> Set TypeNode)
-> m (Set TypeNode)
forall a b. (a -> b) -> a -> b
$ (TypeNode -> Bool) -> NESet TypeNode -> Set TypeNode
forall a. (a -> Bool) -> NESet a -> Set a
dropWhileAntitone (Bool -> Bool
not (Bool -> Bool) -> (TypeNode -> Bool) -> TypeNode -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeNode -> Bool
isCustom) (NESet TypeNode -> Set TypeNode)
-> ((NESet TypeNode, Maybe Identifier) -> NESet TypeNode)
-> (NESet TypeNode, Maybe Identifier)
-> Set TypeNode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NESet TypeNode, Maybe Identifier) -> NESet TypeNode
forall a b. (a, b) -> a
fst
  [m (Cofree ValidJSONF SchemaInformation)]
-> m (Cofree ValidJSONF SchemaInformation)
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum ([m (Cofree ValidJSONF SchemaInformation)]
 -> m (Cofree ValidJSONF SchemaInformation))
-> (Set TypeNode -> [m (Cofree ValidJSONF SchemaInformation)])
-> Set TypeNode
-> m (Cofree ValidJSONF SchemaInformation)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TypeNode -> m (Cofree ValidJSONF SchemaInformation))
-> [TypeNode] -> [m (Cofree ValidJSONF SchemaInformation)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TypeNode -> m (Cofree ValidJSONF SchemaInformation)
forall (m :: * -> *).
(MonadReader Schema m, MonadError ValidationError m,
 MonadState (NESet TypeNode, Maybe Identifier) m, Alternative m) =>
TypeNode -> m (Cofree ValidJSONF SchemaInformation)
checkCustom ([TypeNode] -> [m (Cofree ValidJSONF SchemaInformation)])
-> (Set TypeNode -> [TypeNode])
-> Set TypeNode
-> [m (Cofree ValidJSONF SchemaInformation)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set TypeNode -> [TypeNode]
forall a. Set a -> [a]
S.toList (Set TypeNode -> m (Cofree ValidJSONF SchemaInformation))
-> Set TypeNode -> m (Cofree ValidJSONF SchemaInformation)
forall a b. (a -> b) -> a -> b
$ Set TypeNode
customNodes
  where
    -- Check value against successfors of a custom node.
    checkCustom :: TypeNode -> m (Cofree ValidJSONF SchemaInformation)
checkCustom (CustomNode Identifier
ident) = do
      NESet TypeNode
neighbourhood <- CompiledSchema -> NESet TypeNode
typesAs (CompiledSchema -> NESet TypeNode)
-> m CompiledSchema -> m (NESet TypeNode)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Identifier -> m CompiledSchema
forall (m :: * -> *).
(MonadReader Schema m, MonadError ValidationError m) =>
Identifier -> m CompiledSchema
lookupSchema Identifier
ident
      (NESet TypeNode, Maybe Identifier) -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (NESet TypeNode
neighbourhood, Identifier -> Maybe Identifier
forall a. a -> Maybe a
Just Identifier
ident)
      (Cofree ValidJSONF SchemaInformation
-> SchemaInformation -> Cofree ValidJSONF SchemaInformation
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> (Text -> SchemaInformation
UserDefined (Text -> SchemaInformation)
-> (Identifier -> Text) -> Identifier -> SchemaInformation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identifier -> Text
textify (Identifier -> SchemaInformation)
-> Identifier -> SchemaInformation
forall a b. (a -> b) -> a -> b
$ Identifier
ident)) (Cofree ValidJSONF SchemaInformation
 -> Cofree ValidJSONF SchemaInformation)
-> m (Cofree ValidJSONF SchemaInformation)
-> m (Cofree ValidJSONF SchemaInformation)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> m (Cofree ValidJSONF SchemaInformation)
forall (m :: * -> *).
(Alternative m, MonadReader Schema m,
 MonadState (NESet TypeNode, Maybe Identifier) m,
 MonadError ValidationError m) =>
Value -> m (Cofree ValidJSONF SchemaInformation)
checkTypes Value
v
    checkCustom TypeNode
_ = ValidationError -> m (Cofree ValidJSONF SchemaInformation)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ValidationError -> m (Cofree ValidJSONF SchemaInformation))
-> ValidationError -> m (Cofree ValidJSONF SchemaInformation)
forall a b. (a -> b) -> a -> b
$ Text -> ValidationError
ImplementationError Text
"Unreachable code: All these nodes MUST be custom."

lookupSchema ::
  (MonadReader Schema m, MonadError ValidationError m) => Identifier -> m CompiledSchema
lookupSchema :: Identifier -> m CompiledSchema
lookupSchema Identifier
ident = do
  Maybe CompiledSchema
x <- (Schema -> Maybe CompiledSchema) -> m (Maybe CompiledSchema)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((Schema -> Maybe CompiledSchema) -> m (Maybe CompiledSchema))
-> (Schema -> Maybe CompiledSchema) -> m (Maybe CompiledSchema)
forall a b. (a -> b) -> a -> b
$ Identifier -> Map Identifier CompiledSchema -> Maybe CompiledSchema
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Identifier
ident (Map Identifier CompiledSchema -> Maybe CompiledSchema)
-> (Schema -> Map Identifier CompiledSchema)
-> Schema
-> Maybe CompiledSchema
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Schema -> Map Identifier CompiledSchema
compiledSchemata
  case Maybe CompiledSchema
x of
    Just CompiledSchema
scm -> CompiledSchema -> m CompiledSchema
forall (f :: * -> *) a. Applicative f => a -> f a
pure CompiledSchema
scm
    Maybe CompiledSchema
Nothing -> ValidationError -> m CompiledSchema
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ValidationError -> m CompiledSchema)
-> (Text -> ValidationError) -> Text -> m CompiledSchema
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ValidationError
ImplementationError (Text -> m CompiledSchema) -> Text -> m CompiledSchema
forall a b. (a -> b) -> a -> b
$ Text
"Unreachable state: We should be able to find this schema"

anySet :: NESet TypeNode
anySet :: NESet TypeNode
anySet = TypeNode -> NESet TypeNode
forall a. a -> NESet a
singleton TypeNode
AnyNode

textify :: Identifier -> Text
textify :: Identifier -> Text
textify (Identifier Text
t) = Text
t

isCustom :: TypeNode -> Bool
isCustom :: TypeNode -> Bool
isCustom (CustomNode Identifier
_) = Bool
True
isCustom TypeNode
_ = Bool
False