hjsonschema 1.3.0.1 → 1.4.0.0

raw patch · 42 files changed

+2640/−2635 lines, 42 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• changelog.md +5/−0
• examples/AlternateSchema.hs +19/−19
• examples/Simple.hs +5/−5
• examples/TwoStep.hs +4/−4
• hjsonschema.cabal +17/−17
• src/Data/JsonSchema/Draft4.hs +0/−195
• src/Data/JsonSchema/Draft4/Failure.hs +0/−59
• src/Data/JsonSchema/Draft4/Schema.hs +0/−342
• src/Data/JsonSchema/Draft4/Spec.hs +0/−128
• src/Data/JsonSchema/Fetch.hs +0/−194
• src/Data/JsonSchema/Types.hs +0/−36
• src/Data/Validator/Draft4.hs +0/−242
• src/Data/Validator/Draft4/Any.hs +0/−350
• src/Data/Validator/Draft4/Array.hs +0/−224
• src/Data/Validator/Draft4/Number.hs +0/−84
• src/Data/Validator/Draft4/Object.hs +0/−179
• src/Data/Validator/Draft4/Object/Properties.hs +0/−209
• src/Data/Validator/Draft4/String.hs +0/−79
• src/Data/Validator/Reference.hs +0/−79
• src/Data/Validator/Types.hs +0/−23
• src/Data/Validator/Utils.hs +0/−135
• src/JSONSchema/Draft4.hs +195/−0
• src/JSONSchema/Draft4/Failure.hs +59/−0
• src/JSONSchema/Draft4/Schema.hs +342/−0
• src/JSONSchema/Draft4/Spec.hs +128/−0
• src/JSONSchema/Fetch.hs +194/−0
• src/JSONSchema/Types.hs +36/−0
• src/JSONSchema/Validator/Draft4.hs +242/−0
• src/JSONSchema/Validator/Draft4/Any.hs +351/−0
• src/JSONSchema/Validator/Draft4/Array.hs +224/−0
• src/JSONSchema/Validator/Draft4/Number.hs +84/−0
• src/JSONSchema/Validator/Draft4/Object.hs +179/−0
• src/JSONSchema/Validator/Draft4/Object/Properties.hs +209/−0
• src/JSONSchema/Validator/Draft4/String.hs +79/−0
• src/JSONSchema/Validator/Reference.hs +79/−0
• src/JSONSchema/Validator/Types.hs +23/−0
• src/JSONSchema/Validator/Utils.hs +135/−0
• test/Local.hs +8/−8
• test/Local/Failure.hs +11/−11
• test/Local/Reference.hs +1/−1
• test/Local/Validation.hs +7/−8
• test/Remote.hs +4/−4

@@ -1,3 +1,8 @@+# 1.4.0.0+++ Rename `Data.JsonSchema.*` modules to `JSONSchema.*`.++ Rename `Data.Validator.*` modules to `JSONSchema.Validator.*`.+ # 1.3.0.1  + Bump `vector`.

@@ -1,8 +1,8 @@ -- | An implementation of JSON Schema Draft 4 based on 'HashMap Text Value'--- instead of a custom record type like 'Data.JsonSchema.Draft4'.+-- instead of a custom record type like 'JSONSchema.Draft4'. -- -- If you're writing code for a new schema specification you probably want--- to copy this module instead of the 'Data.JsonSchema.Draft4'. While it's+-- to copy this module instead of the 'JSONSchema.Draft4'. While it's -- less convenient to write schemas in Haskell without a record type, you -- can get the implementation finished with far fewer lines of code. @@ -10,23 +10,23 @@  import           Protolude -import           Data.Aeson               (FromJSON(..), Value(..),-                                           decode)-import qualified Data.Aeson               as AE-import qualified Data.ByteString.Lazy     as LBS-import qualified Data.HashMap.Strict      as HM-import           Data.Maybe               (fromMaybe)-import           Data.Profunctor          (Profunctor (..))+import           Data.Aeson                     (FromJSON(..), Value(..),+                                                 decode)+import qualified Data.Aeson                     as AE+import qualified Data.ByteString.Lazy           as LBS+import qualified Data.HashMap.Strict            as HM+import           Data.Maybe                     (fromMaybe)+import           Data.Profunctor                (Profunctor (..)) -import           Data.JsonSchema.Draft4   (ValidatorFailure(..),-                                           metaSchemaBytes)-import           Data.JsonSchema.Fetch    (ReferencedSchemas(..),-                                           SchemaWithURI(..))-import qualified Data.JsonSchema.Fetch    as FE-import           Data.JsonSchema.Types    (Schema(..), Spec(..))-import qualified Data.JsonSchema.Types    as JT-import qualified Data.Validator.Draft4    as D4-import           Data.Validator.Reference (updateResolutionScope)+import           JSONSchema.Draft4              (ValidatorFailure(..),+                                                 metaSchemaBytes)+import           JSONSchema.Fetch               (ReferencedSchemas(..),+                                                 SchemaWithURI(..))+import qualified JSONSchema.Fetch               as FE+import           JSONSchema.Types               (Schema(..), Spec(..))+import qualified JSONSchema.Types               as JT+import qualified JSONSchema.Validator.Draft4    as D4+import           JSONSchema.Validator.Reference (updateResolutionScope)  -------------------------------------------------- -- * Basic fetching tools@@ -107,7 +107,7 @@     -> Maybe Text     -> Spec Schema ValidatorFailure        -- ^ Here we reuses 'ValidatorFailure' from-       -- 'Data.JsonSchema.Draft4.Failure'. If your validators have different+       -- 'JSONSchema.Draft4.Failure'. If your validators have different        -- failure possibilities you'll need to create your own validator        -- failure type. d4Spec referenced visited scope =

@@ -3,12 +3,12 @@  import           Protolude -import           Data.Aeson             (Value(..), decode, toJSON)-import qualified Data.ByteString.Lazy   as LBS-import qualified Data.List.NonEmpty     as NE-import           Data.Maybe             (fromMaybe)+import           Data.Aeson           (Value(..), decode, toJSON)+import qualified Data.ByteString.Lazy as LBS+import qualified Data.List.NonEmpty   as NE+import           Data.Maybe           (fromMaybe) -import qualified Data.JsonSchema.Draft4 as D4+import qualified JSONSchema.Draft4    as D4  badData :: Value badData = toJSON [True, True]

@@ -15,11 +15,11 @@  import           Protolude -import           Data.Aeson             (Value (..), toJSON)-import qualified Data.List.NonEmpty     as NE+import           Data.Aeson                  (Value (..), toJSON)+import qualified Data.List.NonEmpty          as NE -import qualified Data.JsonSchema.Draft4 as D4-import qualified Data.Validator.Draft4  as VAL+import qualified JSONSchema.Draft4           as D4+import qualified JSONSchema.Validator.Draft4 as VAL  schema :: D4.Schema schema = D4.emptySchema { D4._schemaRef = Just "./unique.json" }

@@ -1,5 +1,5 @@ name:               hjsonschema-version:            1.3.0.1+version:            1.4.0.0 synopsis:           JSON Schema library homepage:           https://github.com/seagreen/hjsonschema license:            MIT@@ -38,23 +38,23 @@   ghc-options:     -Wall   exposed-modules:-      Data.JsonSchema.Draft4-    , Data.JsonSchema.Draft4.Failure-    , Data.JsonSchema.Draft4.Schema-    , Data.JsonSchema.Draft4.Spec-    , Data.JsonSchema.Fetch-    , Data.JsonSchema.Types-    , Data.Validator.Draft4-    , Data.Validator.Draft4.Any-    , Data.Validator.Draft4.Array-    , Data.Validator.Draft4.Number-    , Data.Validator.Draft4.Object-    , Data.Validator.Draft4.String-    , Data.Validator.Reference-    , Data.Validator.Types-    , Data.Validator.Utils+      JSONSchema.Draft4+    , JSONSchema.Draft4.Failure+    , JSONSchema.Draft4.Schema+    , JSONSchema.Draft4.Spec+    , JSONSchema.Fetch+    , JSONSchema.Types+    , JSONSchema.Validator.Draft4+    , JSONSchema.Validator.Draft4.Any+    , JSONSchema.Validator.Draft4.Array+    , JSONSchema.Validator.Draft4.Number+    , JSONSchema.Validator.Draft4.Object+    , JSONSchema.Validator.Draft4.String+    , JSONSchema.Validator.Reference+    , JSONSchema.Validator.Types+    , JSONSchema.Validator.Utils   other-modules:-      Data.Validator.Draft4.Object.Properties+      JSONSchema.Validator.Draft4.Object.Properties     , Import   build-depends:       base                 >= 4.7    && < 4.10

@@ -1,195 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}--module Data.JsonSchema.Draft4-    ( -- * Draft 4 Schema-      SchemaWithURI(..)-    , Schema(..)-    , SC.emptySchema--      -- * One-step validation (getting references over HTTP)-    , fetchHTTPAndValidate-    , HTTPValidationFailure(..)-    , FE.HTTPFailure(..)-    , SchemaInvalid(..)--      -- * One-step validation (getting references from the filesystem)-    , fetchFilesystemAndValidate-    , FilesystemValidationFailure(..)-    , FE.FilesystemFailure(..)--      -- * Validation failure-    , Invalid(..)-    , ValidatorFailure(..)--      -- * Fetching tools-    , ReferencedSchemas(..)-    , FE.URISchemaMap(..)-    , referencesViaHTTP-    , referencesViaFilesystem--      -- * Other Draft 4 things exported just in case-    , metaSchema-    , metaSchemaBytes-    , schemaValidity-    , referencesValidity-    , checkSchema-    , draft4FetchInfo-    ) where--import           Import--import           Control.Arrow                   (left)-import qualified Data.ByteString                 as BS-import           Data.FileEmbed                  (embedFile,-                                                  makeRelativeToProject)-import qualified Data.HashMap.Strict             as HM-import qualified Data.List.NonEmpty              as NE-import           Data.Maybe                      (fromMaybe)--import           Data.JsonSchema.Draft4.Failure  (Invalid(..),-                                                  SchemaInvalid(..),-                                                  ValidatorFailure(..))-import           Data.JsonSchema.Draft4.Schema   (Schema)-import qualified Data.JsonSchema.Draft4.Schema   as SC-import qualified Data.JsonSchema.Draft4.Spec     as Spec-import           Data.JsonSchema.Fetch           (ReferencedSchemas(..),-                                                  SchemaWithURI(..))-import qualified Data.JsonSchema.Fetch           as FE--data HTTPValidationFailure-    = HVRequest FE.HTTPFailure-    | HVSchema  SchemaInvalid-    | HVData    Invalid-    deriving Show---- | Fetch recursively referenced schemas over HTTP, check that both the--- original and referenced schemas are valid, then validate then data.-fetchHTTPAndValidate-    :: SchemaWithURI Schema-    -> Value-    -> IO (Either HTTPValidationFailure ())-fetchHTTPAndValidate sw v = do-    res <- referencesViaHTTP sw-    pure (g =<< f =<< left HVRequest res)-  where-    f :: FE.URISchemaMap Schema-      -> Either HTTPValidationFailure (Value -> [ValidatorFailure])-    f references = left HVSchema (checkSchema references sw)--    g :: (Value -> [ValidatorFailure]) -> Either HTTPValidationFailure ()-    g val = case NE.nonEmpty (val v) of-                Nothing       -> Right ()-                Just failures -> Left (HVData Invalid-                                     { _invalidSchema   = _swSchema sw-                                     , _invalidInstance = v-                                     , _invalidFailures = failures-                                     })--data FilesystemValidationFailure-    = FVRead   FE.FilesystemFailure-    | FVSchema SchemaInvalid-    | FVData   Invalid-    deriving (Show, Eq)---- | Fetch recursively referenced schemas from the filesystem, check--- that both the original and referenced schemas are valid, then validate--- the data.-fetchFilesystemAndValidate-    :: SchemaWithURI Schema-    -> Value-    -> IO (Either FilesystemValidationFailure ())-fetchFilesystemAndValidate sw v = do-    res <- referencesViaFilesystem sw-    pure (g =<< f =<< left FVRead res)-  where-    f :: FE.URISchemaMap Schema-      -> Either FilesystemValidationFailure (Value -> [ValidatorFailure])-    f references = left FVSchema (checkSchema references sw)--    g :: (Value -> [ValidatorFailure]) -> Either FilesystemValidationFailure ()-    g val = case NE.nonEmpty (val v) of-                Nothing      -> Right ()-                Just invalid -> Left (FVData Invalid-                                    { _invalidSchema   = _swSchema sw-                                    , _invalidInstance = v-                                    , _invalidFailures = invalid-                                    })---- | An instance of 'Data.JsonSchema.Fetch.FetchInfo' specialized for--- JSON Schema Draft 4.-draft4FetchInfo :: FE.FetchInfo Schema-draft4FetchInfo = FE.FetchInfo Spec.embedded SC._schemaId SC._schemaRef---- | Fetch the schemas recursively referenced by a starting schema over HTTP.-referencesViaHTTP-    :: SchemaWithURI Schema-    -> IO (Either FE.HTTPFailure (FE.URISchemaMap Schema))-referencesViaHTTP = FE.referencesViaHTTP' draft4FetchInfo---- | Fetch the schemas recursively referenced by a starting schema from--- the filesystem.-referencesViaFilesystem-    :: SchemaWithURI Schema-    -> IO (Either FE.FilesystemFailure (FE.URISchemaMap Schema))-referencesViaFilesystem = FE.referencesViaFilesystem' draft4FetchInfo---- | Checks if a schema and a set of referenced schemas are valid.------ Return a function to validate data.-checkSchema-    :: FE.URISchemaMap Schema-    -> SchemaWithURI Schema-    -> Either SchemaInvalid (Value -> [ValidatorFailure])-checkSchema sm sw =-    case NE.nonEmpty failures of-        Just fs -> Left (SchemaInvalid fs)-        Nothing -> Right (Spec.specValidate-                             (ReferencedSchemas (_swSchema sw)-                                                (FE._unURISchemaMap sm))-                             sw)-  where-    failures :: [(Maybe Text, NonEmpty ValidatorFailure)]-    failures =-        let refFailures = first Just <$> referencesValidity sm-        in case NE.nonEmpty (schemaValidity (_swSchema sw)) of-                     Nothing   -> refFailures-                     Just errs -> (Nothing,errs) : refFailures--metaSchema :: Schema-metaSchema =-      fromMaybe (panic "Schema decode failed (this should never happen)")-    . decodeStrict-    $ metaSchemaBytes--metaSchemaBytes :: BS.ByteString-metaSchemaBytes =-    $(makeRelativeToProject "src/draft4.json" >>= embedFile)---- | Check that a schema itself is valid--- (if so the returned list will be empty).-schemaValidity :: Schema -> [ValidatorFailure]-schemaValidity =-    Spec.specValidate referenced (SchemaWithURI metaSchema Nothing) . toJSON-  where-    referenced :: ReferencedSchemas Schema-    referenced = ReferencedSchemas-                     metaSchema-                     (HM.singleton "http://json-schema.org/draft-04/schema"-                                   metaSchema)---- | Check that a set of referenced schemas are valid--- (if so the returned list will be empty).-referencesValidity-  :: FE.URISchemaMap Schema-  -> [(Text, NonEmpty ValidatorFailure)]-  -- ^ The first item of the tuple is the URI of a schema, the second-  -- is that schema's validation errors.-referencesValidity = HM.foldlWithKey' f mempty . FE._unURISchemaMap-  where-    f :: [(Text, NonEmpty ValidatorFailure)]-      -> Text-      -> Schema-      -> [(Text, NonEmpty ValidatorFailure)]-    f acc k v = case NE.nonEmpty (schemaValidity v) of-                    Nothing   -> acc-                    Just errs -> (k,errs) : acc

@@ -1,59 +0,0 @@--module Data.JsonSchema.Draft4.Failure where--import           Import--import           Data.JsonSchema.Draft4.Schema (Schema)-import qualified Data.Validator.Draft4         as D4---- | Used to report an entire instance being invalidated, as opposed--- to the failure of a single validator.-data Invalid = Invalid-    { _invalidSchema   :: Schema-    , _invalidInstance :: Value-    , _invalidFailures :: NonEmpty ValidatorFailure-    } deriving (Eq, Show)--data ValidatorFailure-    = FailureMultipleOf D4.MultipleOfInvalid-    | FailureMaximum    D4.MaximumInvalid-    | FailureMinimum    D4.MinimumInvalid--    | FailureMaxLength D4.MaxLengthInvalid-    | FailureMinLength D4.MinLengthInvalid-    | FailurePattern   D4.PatternInvalid--    | FailureMaxItems        D4.MaxItemsInvalid-    | FailureMinItems        D4.MinItemsInvalid-    | FailureUniqueItems     D4.UniqueItemsInvalid-    | FailureItems           (D4.ItemsInvalid ValidatorFailure)-    | FailureAdditionalItems (D4.AdditionalItemsInvalid ValidatorFailure)--    | FailureMaxProperties     D4.MaxPropertiesInvalid-    | FailureMinProperties     D4.MinPropertiesInvalid-    | FailureRequired          ()-    | FailureDependencies      (D4.DependenciesInvalid ValidatorFailure)-    | FailurePropertiesRelated (D4.PropertiesRelatedInvalid ValidatorFailure)--    | FailureRef   (D4.RefInvalid ValidatorFailure)-    | FailureEnum  D4.EnumInvalid-    | FailureType  D4.TypeValidatorInvalid-    | FailureAllOf (D4.AllOfInvalid ValidatorFailure)-    | FailureAnyOf (D4.AnyOfInvalid ValidatorFailure)-    | FailureOneOf (D4.OneOfInvalid ValidatorFailure)-    | FailureNot   D4.NotValidatorInvalid-    deriving (Eq, Show)---- | A description of why a schema (or one of its reference) is itself--- invalid.------ 'Nothing' indicates the starting schema. 'Just' indicates a referenced--- schema. The contents of the 'Just' is the schema's URI.------ NOTE: 'HashMap (Maybe Text) Invalid' would be a nicer way of--- defining this, but then we lose the guarantee that there's at least--- one key.-newtype SchemaInvalid-    = SchemaInvalid {-        _unSchemaInvalid :: NonEmpty (Maybe Text, NonEmpty ValidatorFailure) }-    deriving (Eq, Show)

@@ -1,342 +0,0 @@--module Data.JsonSchema.Draft4.Schema where--import           Import                hiding (mapMaybe)--import qualified Data.HashMap.Strict   as HM-import           Data.List.NonEmpty    (NonEmpty)-import           Data.Maybe            (fromJust, isJust)-import           Data.Scientific-import qualified Data.Set              as Set-import qualified Data.Text             as T--import qualified Data.Validator.Draft4 as D4-import           Data.Validator.Utils--data Schema = Schema-    { _schemaVersion              :: Maybe Text-    , _schemaId                   :: Maybe Text-    , _schemaRef                  :: Maybe Text-    , _schemaDefinitions          :: Maybe (HashMap Text Schema)-    -- ^ A standardized location for embedding schemas-    -- to be referenced from elsewhere in the document.-    , _schemaOther                :: HashMap Text Value-    -- ^ Since the JSON document this schema was built from could-    -- contain schemas anywhere (not just in "definitions" or any-    -- of the other official keys) we save any leftover key/value-    -- pairs not covered by them here.-    ---    -- TODO: This field is the source of most of the complication in this-    -- module and needs to be removed. It should be doable, though it will-    -- involve some modification to the fetching code.--    , _schemaMultipleOf           :: Maybe Scientific-    , _schemaMaximum              :: Maybe Scientific-    , _schemaExclusiveMaximum     :: Maybe Bool-    , _schemaMinimum              :: Maybe Scientific-    , _schemaExclusiveMinimum     :: Maybe Bool--    , _schemaMaxLength            :: Maybe Int-    , _schemaMinLength            :: Maybe Int-    , _schemaPattern              :: Maybe Text--    , _schemaMaxItems             :: Maybe Int-    , _schemaMinItems             :: Maybe Int-    , _schemaUniqueItems          :: Maybe Bool-    , _schemaItems                :: Maybe (D4.Items Schema)-    -- Note that '_schemaAdditionalItems' is left out of 'runValidate'-    -- because its functionality is handled by '_schemaItems'. It always-    -- validates data unless 'Items' is present.-    , _schemaAdditionalItems      :: Maybe (D4.AdditionalItems Schema)--    , _schemaMaxProperties        :: Maybe Int-    , _schemaMinProperties        :: Maybe Int-    , _schemaRequired             :: Maybe (Set Text)-    , _schemaDependencies         :: Maybe (HashMap Text (D4.Dependency Schema))-    , _schemaProperties           :: Maybe (HashMap Text Schema)-    , _schemaPatternProperties    :: Maybe (HashMap Text Schema)-    , _schemaAdditionalProperties :: Maybe (D4.AdditionalProperties Schema)--    , _schemaEnum                 :: Maybe (NonEmpty Value)-    , _schemaType                 :: Maybe D4.TypeValidator-    , _schemaAllOf                :: Maybe (NonEmpty Schema)-    , _schemaAnyOf                :: Maybe (NonEmpty Schema)-    , _schemaOneOf                :: Maybe (NonEmpty Schema)-    , _schemaNot                  :: Maybe Schema-    } deriving (Eq, Show)--emptySchema :: Schema-emptySchema = Schema-    { _schemaVersion              = Nothing-    , _schemaId                   = Nothing-    , _schemaRef                  = Nothing-    , _schemaDefinitions          = Nothing-    , _schemaOther                = mempty--    , _schemaMultipleOf           = Nothing-    , _schemaMaximum              = Nothing-    , _schemaExclusiveMaximum     = Nothing-    , _schemaMinimum              = Nothing-    , _schemaExclusiveMinimum     = Nothing--    , _schemaMaxLength            = Nothing-    , _schemaMinLength            = Nothing-    , _schemaPattern              = Nothing--    , _schemaMaxItems             = Nothing-    , _schemaMinItems             = Nothing-    , _schemaUniqueItems          = Nothing-    , _schemaItems                = Nothing-    , _schemaAdditionalItems      = Nothing--    , _schemaMaxProperties        = Nothing-    , _schemaMinProperties        = Nothing-    , _schemaRequired             = Nothing-    , _schemaDependencies         = Nothing-    , _schemaProperties           = Nothing-    , _schemaPatternProperties    = Nothing-    , _schemaAdditionalProperties = Nothing--    , _schemaEnum                 = Nothing-    , _schemaType                 = Nothing-    , _schemaAllOf                = Nothing-    , _schemaAnyOf                = Nothing-    , _schemaOneOf                = Nothing-    , _schemaNot                  = Nothing-    }--instance FromJSON Schema where-    parseJSON = withObject "Schema" $ \o -> do-        a  <- o .:! "$schema"-        b  <- o .:! "id"-        c  <- o .:! "$ref"-        d  <- o .:! "definitions"-        e  <- parseJSON (Object (HM.difference o internalSchemaHashMap))--        f  <- o .:! "multipleOf"-        g  <- o .:! "maximum"-        h  <- o .:! "exclusiveMaximum"-        i  <- o .:! "minimum"-        j  <- o .:! "exclusiveMinimum"--        k  <- o .:! "maxLength"-        l  <- o .:! "minLength"-        m  <- o .:! "pattern"--        n  <- o .:! "maxItems"-        o' <- o .:! "minItems"-        p  <- o .:! "uniqueItems"-        q  <- o .:! "items"-        r  <- o .:! "additionalItems"--        s  <- o .:! "maxProperties"-        t  <- o .:! "minProperties"-        u  <- o .:! "required"-        v  <- o .:! "dependencies"-        w  <- o .:! "properties"-        x  <- o .:! "patternProperties"-        y  <- o .:! "additionalProperties"--        z  <- o .:! "enum"-        a2 <- o .:! "type"-        b2 <- fmap _unNonEmpty' <$> o .:! "allOf"-        c2 <- fmap _unNonEmpty' <$> o .:! "anyOf"-        d2 <- fmap _unNonEmpty' <$> o .:! "oneOf"-        e2 <- o .:! "not"-        pure Schema-            { _schemaVersion              = a-            , _schemaId                   = b-            , _schemaRef                  = c-            , _schemaDefinitions          = d-            , _schemaOther                = e--            , _schemaMultipleOf           = f-            , _schemaMaximum              = g-            , _schemaExclusiveMaximum     = h-            , _schemaMinimum              = i-            , _schemaExclusiveMinimum     = j--            , _schemaMaxLength            = k-            , _schemaMinLength            = l-            , _schemaPattern              = m--            , _schemaMaxItems             = n-            , _schemaMinItems             = o'-            , _schemaUniqueItems          = p-            , _schemaItems                = q-            , _schemaAdditionalItems      = r--            , _schemaMaxProperties        = s-            , _schemaMinProperties        = t-            , _schemaRequired             = u-            , _schemaDependencies         = v-            , _schemaProperties           = w-            , _schemaPatternProperties    = x-            , _schemaAdditionalProperties = y--            , _schemaEnum                 = z-            , _schemaType                 = a2-            , _schemaAllOf                = b2-            , _schemaAnyOf                = c2-            , _schemaOneOf                = d2-            , _schemaNot                  = e2-            }--instance ToJSON Schema where-    -- | The way we resolve JSON Pointers to embedded schemas is by-    -- serializing the containing schema to a value and then resolving the-    -- pointer against it. This means that FromJSON and ToJSON must be-    -- isomorphic.-    ---    -- This influences the design choices in the library. E.g. right now-    -- there are two false values for "exclusiveMaximum" -- Nothing and-    -- Just False. We could have condensed them down by using () instead-    -- of Bool for "exclusiveMaximum". This would have made writing schemas-    -- in haskell easier, but we could no longer round trip through/from-    -- JSON without losing information.-    toJSON s = Object $ HM.union (mapMaybe ($ s) internalSchemaHashMap)-                                 (toJSON <$> _schemaOther s)-      where-        -- 'mapMaybe' is provided by unordered-containers after-        -- unordered-container-2.6.0.0, but until that is a little older-        -- (and has time to get into Stackage etc.) we use our own-        -- implementation.-        mapMaybe :: (v1 -> Maybe v2) -> HashMap k v1 -> HashMap k v2-        mapMaybe f = fmap fromJust . HM.filter isJust . fmap f---- | Internal. Separate from ToJSON because it's also used--- by FromJSON to determine what keys aren't official schema--- keys and therefor should be included in _schemaOther.-internalSchemaHashMap :: HashMap Text (Schema -> Maybe Value)-internalSchemaHashMap = HM.fromList-    [ ("$schema"             , f _schemaVersion)-    , ("id"                  , f _schemaId)-    , ("$ref"                , f _schemaRef)-    , ("definitions"         , f _schemaDefinitions)--    , ("multipleOf"          , f _schemaMultipleOf)-    , ("maximum"             , f _schemaMaximum)-    , ("exclusiveMaximum"    , f _schemaExclusiveMaximum)-    , ("minimum"             , f _schemaMinimum)-    , ("exclusiveMinimum"    , f _schemaExclusiveMinimum)--    , ("maxLength"           , f _schemaMaxLength)-    , ("minLength"           , f _schemaMinLength)-    , ("pattern"             , f _schemaPattern)--    , ("maxItems"            , f _schemaMaxItems)-    , ("minItems"            , f _schemaMinItems)-    , ("uniqueItems"         , f _schemaUniqueItems)-    , ("items"               , f _schemaItems)-    , ("additionalItems"     , f _schemaAdditionalItems)--    , ("maxProperties"       , f _schemaMaxProperties)-    , ("minProperties"       , f _schemaMinProperties)-    , ("required"            , f _schemaRequired)-    , ("dependencies"        , f _schemaDependencies)-    , ("properties"          , f _schemaProperties)-    , ("patternProperties"   , f _schemaPatternProperties)-    , ("additionalProperties", f _schemaAdditionalProperties)--    , ("enum"                , f _schemaEnum)-    , ("type"                , f _schemaType)-    , ("allOf"               , f (fmap NonEmpty' . _schemaAllOf))-    , ("anyOf"               , f (fmap NonEmpty' . _schemaAnyOf))-    , ("oneOf"               , f (fmap NonEmpty' . _schemaOneOf))-    , ("not"                 , f _schemaNot)-    ]-  where-    f :: ToJSON a => (Schema -> Maybe a) -> Schema -> Maybe Value-    f = (fmap.fmap) toJSON--instance Arbitrary Schema where-    arbitrary = sized f-      where-        maybeGen :: Gen a -> Gen (Maybe a)-        maybeGen a = oneof [pure Nothing, Just <$> a]--        maybeRecurse :: Int -> Gen a -> Gen (Maybe a)-        maybeRecurse n a-            | n < 1     = pure Nothing-            | otherwise = maybeGen $ resize (n `div` 10) a--        f :: Int -> Gen Schema-        f n = do-            a  <- maybeGen arbitraryText-            b  <- maybeGen arbitraryText-            c  <- maybeGen arbitraryText-               -- NOTE: The next two fields are empty to generate cleaner-               -- schemas, but note that this means we don't test the-               -- invertability of these fields.-            d  <- pure Nothing -- _schemaDefinitions-            e  <- pure mempty -- _otherPairs--            f' <- maybeGen arbitraryPositiveScientific-            g  <- maybeGen arbitraryScientific-            h  <- arbitrary-            i  <- maybeGen arbitraryScientific-            j  <- arbitrary--            k  <- maybeGen (getPositive <$> arbitrary)-            l  <- maybeGen (getPositive <$> arbitrary)-            m  <- maybeGen arbitraryText--            n' <- maybeGen (getPositive <$> arbitrary)-            o  <- maybeGen (getPositive <$> arbitrary)-            p  <- arbitrary-            q  <- maybeRecurse n arbitrary-            r  <- maybeRecurse n arbitrary--            s  <- maybeGen (getPositive <$> arbitrary)-            t  <- maybeGen (getPositive <$> arbitrary)-            u  <- maybeGen (Set.map T.pack <$> arbitrary)-            v  <- maybeRecurse n arbitraryHashMap-            w  <- maybeRecurse n arbitraryHashMap-            x  <- maybeRecurse n arbitraryHashMap-            y  <- maybeRecurse n arbitrary--            z  <- maybeRecurse n ( fmap _unArbitraryValue . _unNonEmpty'-                               <$> arbitrary)-            a2 <- arbitrary-            b2 <- maybeRecurse n (_unNonEmpty' <$> arbitrary)-            c2 <- maybeRecurse n (_unNonEmpty' <$> arbitrary)-            d2 <- maybeRecurse n (_unNonEmpty' <$> arbitrary)-            e2 <- maybeRecurse n arbitrary-            pure Schema-                { _schemaVersion              = a-                , _schemaId                   = b-                , _schemaRef                  = c-                , _schemaDefinitions          = d-                , _schemaOther                = e--                , _schemaMultipleOf           = f'-                , _schemaMaximum              = g-                , _schemaExclusiveMaximum     = h-                , _schemaMinimum              = i-                , _schemaExclusiveMinimum     = j--                , _schemaMaxLength            = k-                , _schemaMinLength            = l-                , _schemaPattern              = m--                , _schemaMaxItems             = n'-                , _schemaMinItems             = o-                , _schemaUniqueItems          = p-                , _schemaItems                = q-                , _schemaAdditionalItems      = r--                , _schemaMaxProperties        = s-                , _schemaMinProperties        = t-                , _schemaRequired             = u-                , _schemaDependencies         = v-                , _schemaProperties           = w-                , _schemaPatternProperties    = x-                , _schemaAdditionalProperties = y--                , _schemaEnum                 = z-                , _schemaType                 = a2-                , _schemaAllOf                = b2-                , _schemaAnyOf                = c2-                , _schemaOneOf                = d2-                , _schemaNot                  = e2-                }

@@ -1,128 +0,0 @@--module Data.JsonSchema.Draft4.Spec where--import           Import--import           Data.Maybe                     (fromMaybe)-import           Data.Profunctor                (Profunctor(..))--import           Data.JsonSchema.Draft4.Failure-import           Data.JsonSchema.Draft4.Schema  (Schema(..))-import           Data.JsonSchema.Fetch          (ReferencedSchemas(..),-                                                 SchemaWithURI(..))-import qualified Data.JsonSchema.Fetch          as FE-import           Data.JsonSchema.Types          (Spec(..))-import qualified Data.JsonSchema.Types          as JT-import           Data.Validator.Draft4-import           Data.Validator.Reference       (updateResolutionScope)--embedded :: Schema -> ([Schema], [Schema])-embedded s = JT.embedded (d4Spec (ReferencedSchemas s mempty) mempty Nothing) s--specValidate-    :: ReferencedSchemas Schema-    -> SchemaWithURI Schema-    -> Value-    -> [ValidatorFailure]-specValidate rs =-    continueValidating rs (VisitedSchemas [(Nothing, Nothing)])--continueValidating-    :: ReferencedSchemas Schema-    -> VisitedSchemas-    -> SchemaWithURI Schema-    -> Value-    -> [ValidatorFailure]-continueValidating referenced visited sw =-    JT.validate (d4Spec referenced visited currentScope)-                (_swSchema sw)-  where-    currentScope :: Maybe Text-    currentScope = updateResolutionScope-                       (_swURI sw)-                       (_schemaId (_swSchema sw))--d4Spec-    :: ReferencedSchemas Schema-    -> VisitedSchemas-    -> Maybe Text-    -> Spec Schema ValidatorFailure-d4Spec referenced visited scope = Spec-    [ dimap (fmap MultipleOf . _schemaMultipleOf) FailureMultipleOf multipleOfValidator-    , dimap-        (\s -> Maximum (fromMaybe False (_schemaExclusiveMaximum s)) <$> _schemaMaximum s)-        FailureMaximum-        maximumValidator-    , dimap-        (\s -> Minimum (fromMaybe False (_schemaExclusiveMinimum s)) <$> _schemaMinimum s)-        FailureMinimum-        minimumValidator--    , dimap (fmap MaxLength . _schemaMaxLength) FailureMaxLength maxLengthValidator-    , dimap (fmap MinLength . _schemaMinLength) FailureMinLength minLengthValidator-    , dimap (fmap PatternValidator . _schemaPattern) FailurePattern patternValidator--    , dimap (fmap MaxItems . _schemaMaxItems) FailureMaxItems maxItemsValidator-    , dimap (fmap MinItems . _schemaMinItems) FailureMinItems minItemsValidator-    , dimap (fmap UniqueItems . _schemaUniqueItems) FailureUniqueItems uniqueItemsValidator-    , dimap-        (\s -> ItemsRelated-                   { _irItems      = _schemaItems s-                   , _irAdditional = _schemaAdditionalItems s-                   })-        (\err -> case err of-                     IRInvalidItems e      -> FailureItems e-                     IRInvalidAdditional e -> FailureAdditionalItems e)-        (itemsRelatedValidator descend)-    , lmap (fmap Definitions . _schemaDefinitions) definitionsEmbedded--    , dimap-        (fmap MaxProperties . _schemaMaxProperties)-        FailureMaxProperties-        maxPropertiesValidator-    , dimap-        (fmap MinProperties . _schemaMinProperties)-        FailureMinProperties-        minPropertiesValidator-    , dimap (fmap Required . _schemaRequired) FailureRequired requiredValidator-    , dimap-        (fmap DependenciesValidator . _schemaDependencies)-        FailureDependencies-        (dependenciesValidator descend)-    , dimap-        (\s -> PropertiesRelated-                   { _propProperties = _schemaProperties s-                   , _propPattern    = _schemaPatternProperties s-                   , _propAdditional = _schemaAdditionalProperties s-                   })-        FailurePropertiesRelated-        (propertiesRelatedValidator descend)--    , dimap-        (\s -> Ref <$> _schemaRef s)-        FailureRef-        (refValidator visited scope (FE.getReference referenced) getRef)-    , dimap (fmap EnumValidator . _schemaEnum) FailureEnum enumValidator-    , dimap (fmap TypeContext . _schemaType) FailureType typeValidator-    , dimap (fmap AllOf . _schemaAllOf) FailureAllOf (allOfValidator lateral)-    , dimap (fmap AnyOf . _schemaAnyOf) FailureAnyOf (anyOfValidator lateral)-    , dimap (fmap OneOf . _schemaOneOf) FailureOneOf (oneOfValidator lateral)-    , dimap (fmap NotValidator . _schemaNot) FailureNot (notValidator lateral)-    ]-  where-    getRef-        :: VisitedSchemas-        -> Maybe Text-        -> Schema-        -> Value-        -> [ValidatorFailure]-    getRef newVisited newScope schema =-        continueValidating referenced newVisited (SchemaWithURI schema newScope)--    descend :: Schema -> Value -> [ValidatorFailure]-    descend schema =-        continueValidating referenced mempty (SchemaWithURI schema scope)--    lateral :: Schema -> Value -> [ValidatorFailure]-    lateral schema =-        continueValidating referenced visited (SchemaWithURI schema scope)

@@ -1,194 +0,0 @@--module Data.JsonSchema.Fetch where--import           Import--import           Control.Arrow            (left)-import           Control.Exception        (IOException, catch)-import           Control.Monad            (foldM)-import qualified Data.ByteString          as BS-import qualified Data.ByteString.Lazy     as LBS-import qualified Data.HashMap.Strict      as HM-import qualified Data.Text                as T-import qualified Network.HTTP.Client      as NC--import           Data.Validator.Reference (resolveReference,-                                           updateResolutionScope)------------------------------------------------------- * Types------------------------------------------------------- | This is all the fetching functions need to know about a particular--- JSON Schema draft, e.g. JSON Schema Draft 4.-data FetchInfo schema = FetchInfo-    { _fiEmbedded :: schema -> ([schema], [schema])-    , _fiId       :: schema -> Maybe Text-    , _fiRef      :: schema -> Maybe Text-    }--data ReferencedSchemas schema = ReferencedSchemas-    { _rsStarting  :: !schema-      -- ^ Used to resolve relative references when we don't know what the scope-      -- of the current schema is. This only happens with starting schemas-      -- because if we're using a remote schema we had to know its URI in order-      -- to fetch it.-      ---      -- Tracking the starting schema (instead of just resolving the reference to-      -- the current schema being used for validation) is necessary for cases-      -- where schemas are embedded inside one another. For instance in this-      -- case not distinguishing the starting and "foo" schemas sends the code-      -- into an infinite loop:-      ---      -- {-      --   "additionalProperties": false,-      --   "properties": {-      --     "foo": {-      --       "$ref": "#"-      --     }-      --   }-      -- }-    , _rsSchemaMap :: !(HashMap Text schema)-      -- ^ Map of URIs to schemas.-    } deriving (Eq, Show)---- | Keys are URIs (without URI fragments).-newtype URISchemaMap schema-    = URISchemaMap { _unURISchemaMap :: HashMap Text schema }-    deriving (Eq, Show)--data SchemaWithURI schema = SchemaWithURI-    { _swSchema :: !schema-    , _swURI    :: !(Maybe Text)-      -- ^ This is the URI identifying the document containing the schema.-      -- It's different than the schema's "id" field, which controls scope-      -- when resolving references contained in the schema.--      -- TODO: Make the no URI fragment requirement unnecessary.-    } deriving (Eq, Show)--getReference :: ReferencedSchemas schema -> Maybe Text -> Maybe schema-getReference referenced Nothing  = Just (_rsStarting referenced)-getReference referenced (Just t) = HM.lookup t (_rsSchemaMap referenced)------------------------------------------------------- * Fetch via HTTP-----------------------------------------------------data HTTPFailure-    = HTTPParseFailure   Text-    | HTTPRequestFailure NC.HttpException-    deriving Show---- | Take a schema. Retrieve every document either it or its subschemas--- include via the "$ref" keyword.-referencesViaHTTP'-    :: forall schema. FromJSON schema-    => FetchInfo schema-    -> SchemaWithURI schema-    -> IO (Either HTTPFailure (URISchemaMap schema))-referencesViaHTTP' info sw = do-    manager <- NC.newManager NC.defaultManagerSettings-    let f = referencesMethodAgnostic (getURL manager) info sw-    catch (left HTTPParseFailure <$> f) handler-  where-    getURL :: NC.Manager -> Text -> IO BS.ByteString-    getURL man url = do-        request <- NC.parseUrlThrow (T.unpack url)-        LBS.toStrict . NC.responseBody <$> NC.httpLbs request man--    handler-        :: NC.HttpException-        -> IO (Either HTTPFailure (URISchemaMap schema))-    handler = pure . Left . HTTPRequestFailure------------------------------------------------------- * Fetch via Filesystem-----------------------------------------------------data FilesystemFailure-    = FSParseFailure Text-    | FSReadFailure  IOException-    deriving (Show, Eq)--referencesViaFilesystem'-    :: forall schema. FromJSON schema-    => FetchInfo schema-    -> SchemaWithURI schema-    -> IO (Either FilesystemFailure (URISchemaMap schema))-referencesViaFilesystem' info sw = catch (left FSParseFailure <$> f) handler-  where-    f :: IO (Either Text (URISchemaMap schema))-    f = referencesMethodAgnostic (BS.readFile . T.unpack) info sw--    handler-        :: IOException-        -> IO (Either FilesystemFailure (URISchemaMap schema))-    handler = pure . Left . FSReadFailure------------------------------------------------------- * Method Agnostic Fetching Tools------------------------------------------------------- | A version of 'fetchReferencedSchema's where the function to fetch--- schemas is provided by the user. This allows restrictions to be added,--- e.g. rejecting non-local URIs.-referencesMethodAgnostic-    :: forall schema. FromJSON schema-    => (Text -> IO BS.ByteString)-    -> FetchInfo schema-    -> SchemaWithURI schema-    -> IO (Either Text (URISchemaMap schema))-referencesMethodAgnostic fetchRef info =-    getRecursiveReferences fetchRef info (URISchemaMap mempty)--getRecursiveReferences-    :: forall schema. FromJSON schema-    => (Text -> IO BS.ByteString)-    -> FetchInfo schema-    -> URISchemaMap schema-    -> SchemaWithURI schema-    -> IO (Either Text (URISchemaMap schema))-getRecursiveReferences fetchRef info referenced sw =-    foldM f (Right referenced) (includeSubschemas info sw)-  where-    f :: Either Text (URISchemaMap schema)-      -> SchemaWithURI schema-      -> IO (Either Text (URISchemaMap schema))-    f (Left e) _                            = pure (Left e)-    f (Right (URISchemaMap usm)) (SchemaWithURI schema mUri) =-        case newRef of-            Nothing  -> pure (Right (URISchemaMap usm))-            Just uri -> do-                bts <- fetchRef uri-                case eitherDecodeStrict bts of-                    Left e     -> pure . Left . T.pack $ e-                    Right schm -> getRecursiveReferences-                                      fetchRef-                                      info-                                      (URISchemaMap (HM.insert uri schm usm))-                                      (SchemaWithURI schm (Just uri))-      where-        newRef :: Maybe Text-        newRef-          | Just (Just uri,_) <- resolveReference mUri <$> _fiRef info schema-              = case HM.lookup uri usm of-                    Nothing -> Just uri-                    Just _  -> Nothing-          | otherwise = Nothing---- | Return the schema passed in as an argument, as well as every--- subschema contained within it.-includeSubschemas-    :: forall schema.-       FetchInfo schema-    -> SchemaWithURI schema-    -> [SchemaWithURI schema]-includeSubschemas info (SchemaWithURI schema mUri) =-    SchemaWithURI schema mUri-    : (includeSubschemas info =<< subSchemas)-  where-    subSchemas :: [SchemaWithURI schema]-    subSchemas =-      (\a -> SchemaWithURI a (updateResolutionScope mUri (_fiId info schema)))-         <$> uncurry (<>) (_fiEmbedded info schema)

@@ -1,36 +0,0 @@--module Data.JsonSchema.Types where--import           Import--import           Data.Validator.Types (Validator(..))--newtype Spec schema err-    = Spec { _unSpec :: [Validator schema schema err] }---- | Return a schema's immediate subschemas.------ The first list is subschemas validating the same level of the document,--- the second list is subschemas validating lower levels (see--- 'Data.Validator.Types.Fail' for a full explanation).-embedded :: Spec schema a -> schema -> ([schema], [schema])-embedded spec schema =-    let embeds = (\val -> _embedded val schema) <$> _unSpec spec-    in foldl' (\(a,b) (x,y) -> (x <> a, y <> b)) (mempty, mempty) embeds--validate-    :: Spec schema err-    -> schema-    -> Value-    -> [err]-validate spec schema v =-    (\val -> _validate val schema v) =<< _unSpec spec---- | A basic schema type that doesn't impose much structure.------ 'Data.JsonSchema.Draft4' doesn't use this, but instead uses the one--- defined in 'Data.JsonSchema.Draft4.Schema' to make it easier to write--- draft 4 schemas in Haskell.-newtype Schema-    = Schema { _unSchema :: HashMap Text Value }-    deriving (Eq, Show, FromJSON, ToJSON)

@@ -1,242 +0,0 @@--- | Turn the validation functions into actual 'Validator's.--module Data.Validator.Draft4-    ( module Data.Validator.Draft4-    , module Export-    ) where--import           Import--import qualified Data.HashMap.Strict          as HM-import qualified Data.List.NonEmpty           as NE-import           Data.Maybe                   (catMaybes, maybe, maybeToList)-import           Data.Text                    (Text)--import           Data.Validator.Draft4.Any    as Export-import           Data.Validator.Draft4.Array  as Export-import           Data.Validator.Draft4.Number as Export-import           Data.Validator.Draft4.Object as Export-import           Data.Validator.Draft4.String as Export-import           Data.Validator.Types         (Validator(..))-import           Data.Validator.Utils         (fromJSONEither)---- | For internal use.------ Take a validation function, a possibly existing validator, and some data.--- If the validator is exists and can validate the type of data we have,--- attempt to do so and return any failures.-run :: FromJSON b => (a -> b -> Maybe c) -> Maybe a -> Value -> [c]-run _ Nothing _  = mempty-run f (Just a) b =-    case fromJSONEither b of-        Left _  -> mempty-        Right c -> maybeToList (f a c)---- | For internal use.-noEmbedded :: a -> ([b], [b])-noEmbedded = const (mempty, mempty)------------------------------------------------------- * Numbers-----------------------------------------------------multipleOfValidator :: Validator a (Maybe MultipleOf) MultipleOfInvalid-multipleOfValidator = Validator noEmbedded (run multipleOfVal)--maximumValidator :: Validator a (Maybe Maximum) MaximumInvalid-maximumValidator = Validator noEmbedded (run maximumVal)--minimumValidator :: Validator a (Maybe Minimum) MinimumInvalid-minimumValidator = Validator noEmbedded (run minimumVal)------------------------------------------------------- * Strings-----------------------------------------------------maxLengthValidator :: Validator a (Maybe MaxLength) MaxLengthInvalid-maxLengthValidator = Validator noEmbedded (run maxLengthVal)--minLengthValidator :: Validator a (Maybe MinLength) MinLengthInvalid-minLengthValidator = Validator noEmbedded (run minLengthVal)--patternValidator :: Validator a (Maybe PatternValidator) PatternInvalid-patternValidator = Validator noEmbedded (run patternVal)------------------------------------------------------- * Arrays-----------------------------------------------------maxItemsValidator :: Validator a (Maybe MaxItems) MaxItemsInvalid-maxItemsValidator = Validator noEmbedded (run maxItemsVal)--minItemsValidator :: Validator a (Maybe MinItems) MinItemsInvalid-minItemsValidator = Validator noEmbedded (run minItemsVal)--uniqueItemsValidator :: Validator a (Maybe UniqueItems) UniqueItemsInvalid-uniqueItemsValidator = Validator noEmbedded (run uniqueItemsVal)--itemsRelatedValidator-    :: (schema -> Value -> [err])-    -> Validator schema (ItemsRelated schema) (ItemsRelatedInvalid err)-itemsRelatedValidator f =-    Validator-        (\a -> ( mempty-               ,  case _irItems a of-                      Just (ItemsObject b) -> pure b-                      Just (ItemsArray cs) -> cs-                      Nothing              -> mempty-               <> case _irAdditional a of-                      Just (AdditionalObject b) -> pure b-                      _                         -> mempty-               ))-        (\a b -> case fromJSONEither b of-                     Left _  -> mempty-                     Right c -> itemsRelatedVal f a c)------------------------------------------------------- * Objects-----------------------------------------------------maxPropertiesValidator-    :: Validator-           a-           (Maybe MaxProperties)-           MaxPropertiesInvalid-maxPropertiesValidator = Validator noEmbedded (run maxPropertiesVal)--minPropertiesValidator-    :: Validator-           a-           (Maybe MinProperties)-           MinPropertiesInvalid-minPropertiesValidator = Validator noEmbedded (run minPropertiesVal)--requiredValidator :: Validator a (Maybe Required) ()-requiredValidator = Validator noEmbedded (run requiredVal)--dependenciesValidator-    :: (schema -> Value -> [err])-    -> Validator-           schema-           (Maybe (DependenciesValidator schema))-           (DependenciesInvalid err)-dependenciesValidator f =-    Validator-        (maybe mempty ( (\a -> (mempty, a))-                      . catMaybes . fmap checkDependency-                      . HM.elems . _unDependenciesValidator-                      ))-        (run (dependenciesVal f))-  where-    checkDependency :: Dependency schema -> Maybe schema-    checkDependency (PropertyDependency _) = Nothing-    checkDependency (SchemaDependency s)   = Just s--propertiesRelatedValidator-    :: (schema -> Value -> [err])-    -> Validator-           schema-           (PropertiesRelated schema)-           (PropertiesRelatedInvalid err)-propertiesRelatedValidator f =-    Validator-        (\a -> ( mempty-               ,  HM.elems (fromMaybe mempty (_propProperties a))-               <> HM.elems (fromMaybe mempty (_propPattern a))-               <> case _propAdditional a of-                      Just (AdditionalPropertiesObject b) -> [b]-                      _ -> mempty-               ))-        (\a b -> case fromJSONEither b of-                     Left _  -> mempty-                     Right c -> maybeToList (propertiesRelatedVal f a c))--newtype Definitions schema-    = Definitions { _unDefinitions :: HashMap Text schema }-    deriving (Eq, Show)--instance FromJSON schema => FromJSON (Definitions schema) where-    parseJSON = withObject "Definitions" $ \o ->-        Definitions <$> o .: "definitions"---- TODO: Add tests to the language agnostic test suite to--- make sure these schemas are embedded correctly--- (and do so for @"additionalItems"@ as well).-definitionsEmbedded-    :: Validator-           schema-           (Maybe (Definitions schema))-           err-definitionsEmbedded =-    Validator-        (\a -> case a of-                 Just (Definitions b) -> (mempty, HM.elems b)-                 Nothing              -> (mempty, mempty))-        (const (const mempty))------------------------------------------------------- * Any-----------------------------------------------------refValidator-    :: (FromJSON schema, ToJSON schema)-    => VisitedSchemas-    -> Maybe Text-    -> (Maybe Text -> Maybe schema)-    -> (VisitedSchemas -> Maybe Text -> schema -> Value -> [err])-    -> Validator a (Maybe Ref) (RefInvalid err)-refValidator visited scope getRef f =-    Validator-        noEmbedded-        (run (refVal visited scope getRef f))--enumValidator :: Validator a (Maybe EnumValidator) EnumInvalid-enumValidator = Validator noEmbedded (run enumVal)--typeValidator :: Validator a (Maybe TypeContext) TypeValidatorInvalid-typeValidator = Validator noEmbedded (run typeVal)--allOfValidator-    :: (schema -> Value -> [err])-    -> Validator schema (Maybe (AllOf schema)) (AllOfInvalid err)-allOfValidator f =-    Validator-        (\a -> case a of-                   Just (AllOf b) -> (NE.toList b, mempty)-                   Nothing        -> (mempty, mempty))-        (run (allOfVal f))--anyOfValidator-    :: (schema -> Value -> [err])-    -> Validator schema (Maybe (AnyOf schema)) (AnyOfInvalid err)-anyOfValidator f =-    Validator-        (\a -> case a of-                 Just (AnyOf b) -> (NE.toList b, mempty)-                 Nothing        -> (mempty, mempty))-        (run (anyOfVal f))--oneOfValidator-    :: ToJSON schema-    => (schema -> Value -> [err])-    -> Validator schema (Maybe (OneOf schema)) (OneOfInvalid err)-oneOfValidator f =-    Validator-        (\a -> case a of-                   Just (OneOf b) -> (NE.toList b, mempty)-                   Nothing        -> (mempty, mempty))-        (run (oneOfVal f))--notValidator-    :: ToJSON schema-    => (schema -> Value -> [err])-    -> Validator-           schema-           (Maybe (NotValidator schema))-           NotValidatorInvalid-notValidator f =-    Validator-        (\a -> case a of-                   Just (NotValidator b) -> (pure b, mempty)-                   Nothing               -> (mempty, mempty))-        (run (notVal f))

@@ -1,350 +0,0 @@--module Data.Validator.Draft4.Any where--import           Import--import           Data.List.NonEmpty       (NonEmpty((:|)))-import qualified Data.List.NonEmpty       as NE-import qualified Data.Scientific          as SCI-import           Data.Semigroup           (Semigroup) -- for older GHCs-import           Data.Set                 (Set)-import qualified Data.Set                 as S-import qualified JSONPointer              as JP--import qualified Data.Validator.Utils     as UT-import           Data.Validator.Reference (URIBaseAndFragment,-                                           resolveFragment, resolveReference)------------------------------------------------------- * $ref-----------------------------------------------------newtype Ref-    = Ref { _unRef :: Text }-    deriving (Eq, Show)--instance FromJSON Ref where-    parseJSON = withObject "Ref" $ \o ->-        Ref <$> o .: "$ref"--data RefInvalid err-    = RefResolution        Text-      -- ^ Indicates a reference that failed to resolve.-      ---      -- NOTE: The language agnostic test suite doesn't specify if this should-      -- cause a validation error or should allow data to pass. We choose to-      -- return a validation error.-      ---      -- Also note that ideally we would enforce in the type system that any-      -- failing references be dealt with before valididation. Then this could-      -- be removed entirely.-    | RefPointerResolution Text-    | RefLoop              Text VisitedSchemas URIBaseAndFragment-    | RefInvalid           Text Value (NonEmpty err)-      -- ^ 'Text' is the URI and 'Value' is the linked schema.-    deriving (Eq, Show)--newtype VisitedSchemas-    = VisitedSchemas { _unVisited :: [URIBaseAndFragment] }-    deriving (Eq, Show, Semigroup, Monoid)--refVal-    :: forall err schema. (FromJSON schema, ToJSON schema)-    => VisitedSchemas-    -> Maybe Text-    -> (Maybe Text -> Maybe schema)-    -> (VisitedSchemas -> Maybe Text -> schema -> Value -> [err])-    -> Ref-    -> Value-    -> Maybe (RefInvalid err)-refVal visited scope getRef f (Ref reference) x-    | (mURI, mFragment) `elem` _unVisited visited =-        Just (RefLoop reference visited (mURI, mFragment))-    | otherwise =-        case getRef mURI of-            Nothing     -> Just (RefResolution reference)-            Just schema ->-                case resolveFragment mFragment schema of-                    Nothing -> Just (RefPointerResolution reference)-                    Just s  ->-                        let newVisited = (VisitedSchemas [(mURI, mFragment)]-                                      <> visited)-                            errs = f newVisited mURI s x-                        in RefInvalid reference (toJSON schema)-                            <$> NE.nonEmpty errs-  where-    (mURI, mFragment) = resolveReference scope reference------------------------------------------------------- * enum------------------------------------------------------- | From the spec:--- <http://json-schema.org/latest/json-schema-validation.html#anchor76>------  > The value of this keyword MUST be an array.---  > This array MUST have at least one element.---  > Elements in the array MUST be unique.------ NOTE: We don't enforce the uniqueness constraint in the haskell code,--- but we do in the 'FromJSON' instance.-newtype EnumValidator-    = EnumValidator { _unEnumValidator :: NonEmpty Value }-    -- Given a choice, we'd prefer to enforce uniqueness through the type-    -- system over having at least one element. To use a 'Set' though we'd-    -- have to use 'OrdValue' here (there's no 'Ord' instance for plain Values)-    -- and we'd rather not make users mess with 'OrdValue'.-    deriving (Eq, Show)--instance FromJSON EnumValidator where-    parseJSON = withObject "EnumValidator" $ \o ->-        EnumValidator <$> o .: "enum"--instance Arbitrary EnumValidator where-    arbitrary = do-        xs <- (fmap.fmap) UT._unArbitraryValue arbitrary-        case NE.nonEmpty (toUnique xs) of-            Nothing -> EnumValidator . pure . UT._unArbitraryValue <$> arbitrary-            Just ne -> pure (EnumValidator ne)-      where-        toUnique :: [Value] -> [Value]-        toUnique = fmap UT._unOrdValue . S.toList . S.fromList . fmap UT.OrdValue--data EnumInvalid-    = EnumInvalid EnumValidator Value-    deriving (Eq, Show)--enumVal :: EnumValidator -> Value -> Maybe EnumInvalid-enumVal a@(EnumValidator vs) x-    | not (UT.allUniqueValues' vs) = Nothing-    | x `elem` vs                  = Nothing-    | otherwise                    = Just $ EnumInvalid a x------------------------------------------------------- * type------------------------------------------------------- | This is separate from 'TypeValidator' so that 'TypeValidator' can--- be used to write 'Data.JsonSchema.Draft4.Schema.Schema' without--- messing up the 'FromJSON' instance of that data type.-newtype TypeContext-    = TypeContext { _unTypeContext :: TypeValidator }-    deriving (Eq, Show)--instance FromJSON TypeContext where-    parseJSON = withObject "TypeContext" $ \o ->-        TypeContext <$> o .: "type"--data TypeValidator-    = TypeValidatorString Text-    | TypeValidatorArray  (Set Text)-    deriving (Eq, Show)--instance FromJSON TypeValidator where-    parseJSON v = fmap TypeValidatorString (parseJSON v)-              <|> fmap TypeValidatorArray (parseJSON v)--instance ToJSON TypeValidator where-    toJSON (TypeValidatorString t) = toJSON t-    toJSON (TypeValidatorArray ts) = toJSON ts--instance Arbitrary TypeValidator where-    arbitrary = oneof [ TypeValidatorString <$> UT.arbitraryText-                      , TypeValidatorArray <$> UT.arbitrarySetOfText-                      ]--data TypeValidatorInvalid-    = TypeValidatorInvalid TypeValidator Value-    deriving (Eq, Show)--typeVal :: TypeContext -> Value -> Maybe TypeValidatorInvalid-typeVal (TypeContext tv) x-    | S.null matches = Just (TypeValidatorInvalid tv x)-    | otherwise      = Nothing-  where-    -- There can be more than one match because a 'Value' can be both a-    -- @"number"@ and an @"integer"@.-    matches :: Set Text-    matches = S.intersection okTypes (setFromTypeValidator tv)--    okTypes :: Set Text-    okTypes =-        case x of-            Null       -> S.singleton "null"-            (Array _)  -> S.singleton "array"-            (Bool _)   -> S.singleton "boolean"-            (Object _) -> S.singleton "object"-            (String _) -> S.singleton "string"-            (Number y) ->-                if SCI.isInteger y-                    then S.fromList ["number", "integer"]-                    else S.singleton "number"---- | Internal.-setFromTypeValidator :: TypeValidator -> Set Text-setFromTypeValidator (TypeValidatorString t) = S.singleton t-setFromTypeValidator (TypeValidatorArray ts) = ts------------------------------------------------------- * allOf-----------------------------------------------------newtype AllOf schema-    = AllOf { _unAllOf :: NonEmpty schema }-    deriving (Eq, Show)--instance FromJSON schema => FromJSON (AllOf schema) where-    parseJSON = withObject "AllOf" $ \o ->-        AllOf <$> o .: "allOf"--newtype AllOfInvalid err-    = AllOfInvalid (NonEmpty (JP.Index, NonEmpty err))-    deriving (Eq, Show)--allOfVal-    :: forall err schema.-       (schema -> Value -> [err])-    -> AllOf schema-    -> Value-    -> Maybe (AllOfInvalid err)-allOfVal f (AllOf subSchemas) x = AllOfInvalid <$> NE.nonEmpty failures-  where-    perhapsFailures :: [(JP.Index, [err])]-    perhapsFailures = zip (JP.Index <$> [0..])-                          (flip f x <$> NE.toList subSchemas)--    failures :: [(JP.Index, NonEmpty err)]-    failures = mapMaybe (traverse NE.nonEmpty) perhapsFailures------------------------------------------------------- * anyOf-----------------------------------------------------newtype AnyOf schema-    = AnyOf { _unAnyOf :: NonEmpty schema }-    deriving (Eq, Show)--instance FromJSON schema => FromJSON (AnyOf schema) where-    parseJSON = withObject "AnyOf" $ \o ->-        AnyOf <$> o .: "anyOf"--newtype AnyOfInvalid err-    = AnyOfInvalid (NonEmpty (JP.Index, NonEmpty err))-    deriving (Eq, Show)--anyOfVal-    :: forall err schema.-       (schema -> Value -> [err])-    -> AnyOf schema-    -> Value-    -> Maybe (AnyOfInvalid err)-anyOfVal f (AnyOf subSchemas) x-    -- Replace with @null@ once we drop GHC 7.8:-    | any (((==) 0 . length) . snd) perhapsFailures = Nothing-    | otherwise = AnyOfInvalid <$> NE.nonEmpty failures-  where-    perhapsFailures :: [(JP.Index, [err])]-    perhapsFailures = zip (JP.Index <$> [0..])-                          (flip f x <$> NE.toList subSchemas)--    failures :: [(JP.Index, NonEmpty err)]-    failures = mapMaybe (traverse NE.nonEmpty) perhapsFailures------------------------------------------------------- * oneOf-----------------------------------------------------newtype OneOf schema-    = OneOf { _unOneOf :: NonEmpty schema }-    deriving (Eq, Show)--instance FromJSON schema => FromJSON (OneOf schema) where-    parseJSON = withObject "OneOf" $ \o ->-        OneOf <$> o .: "oneOf"--data OneOfInvalid err-    = TooManySuccesses (NonEmpty (JP.Index, Value)) Value-      -- ^ The NonEmpty lists contains tuples whose contents-      -- are the index of a schema that validated the data-      -- and the contents of that schema.-    | NoSuccesses      (NonEmpty (JP.Index, NonEmpty err)) Value-      -- ^ The NonEmpty lists contains tuples whose contents-      -- are the index of a schema that failed to validate the data-      -- and the failures it produced.-    deriving (Eq, Show)--oneOfVal-    :: forall err schema. ToJSON schema-    => (schema -> Value -> [err])-    -> OneOf schema-    -> Value-    -> Maybe (OneOfInvalid err)-oneOfVal f (OneOf (firstSubSchema :| otherSubSchemas)) x =-    -- Producing the NonEmpty lists needed by the error constructors-    -- is a little tricky. If we had a partition function like this-    -- it might help:-    -- @-    -- (a -> Either b c) -> NonEmpty a -> Either (NonEmpty b, [c])-    --                                           ([b], NonEmpty c)-    -- @-    case (firstSuccess, otherSuccesses) of-        (Right _, Nothing)        -> Nothing-        (Right a, Just successes) -> Just (TooManySuccesses-                                              (a NE.<| successes) x)-        (Left e, Nothing)        -> Just (NoSuccesses (e :| otherFailures) x)-        (Left _, Just (_ :| [])) -> Nothing-        (Left _, Just successes) -> Just (TooManySuccesses successes x)-  where-    firstSuccess :: Either (JP.Index, NonEmpty err) (JP.Index, Value)-    firstSuccess =-        case NE.nonEmpty (f firstSubSchema x) of-            Nothing   -> Right (JP.Index 0, toJSON firstSubSchema)-            Just errs -> Left (JP.Index 0, errs)--    otherPerhapsFailures :: [(JP.Index, Value, [err])]-    otherPerhapsFailures =-        zipWith-            (\index schema -> (index, toJSON schema, f schema x))-            (JP.Index <$> [0..])-            otherSubSchemas--    otherSuccesses :: Maybe (NonEmpty (JP.Index, Value))-    otherSuccesses = NE.nonEmpty-                   $ mapMaybe (\(index,val,errs) ->-                                  case errs of-                                      [] -> Just (index,val)-                                      _  -> Nothing-                              ) otherPerhapsFailures--    otherFailures :: [(JP.Index, NonEmpty err)]-    otherFailures = mapMaybe (traverse NE.nonEmpty . mid) otherPerhapsFailures--    mid :: (a,b,c) -> (a,c)-    mid (a,_,c) = (a,c)------------------------------------------------------- * not-----------------------------------------------------newtype NotValidator schema-    = NotValidator { _unNotValidator :: schema }-    deriving (Eq, Show)--instance FromJSON schema => FromJSON (NotValidator schema) where-    parseJSON = withObject "NotValidator" $ \o ->-        NotValidator <$> o .: "not"--data NotValidatorInvalid-    = NotValidatorInvalid Value Value-    deriving (Eq, Show)--notVal-    :: ToJSON schema =>-       (schema -> Value -> [err])-    -> NotValidator schema-    -> Value-    -> Maybe NotValidatorInvalid-notVal f (NotValidator schema) x =-    case f schema x of-        [] -> Just (NotValidatorInvalid (toJSON schema) x)-        _  -> Nothing

@@ -1,224 +0,0 @@--module Data.Validator.Draft4.Array where--import           Import--import qualified Data.List.NonEmpty   as NE-import qualified Data.Vector          as V-import qualified JSONPointer          as JP--import           Data.Validator.Utils (allUniqueValues)------------------------------------------------------- * maxItems-----------------------------------------------------newtype MaxItems-    = MaxItems { _unMaxItems :: Int }-    deriving (Eq, Show)--instance FromJSON MaxItems where-    parseJSON = withObject "MaxItems" $ \o ->-        MaxItems <$> o .: "maxItems"--data MaxItemsInvalid-    = MaxItemsInvalid MaxItems (Vector Value)-    deriving (Eq, Show)---- | The spec requires @"maxItems"@ to be non-negative.-maxItemsVal :: MaxItems -> Vector Value -> Maybe MaxItemsInvalid-maxItemsVal a@(MaxItems n) xs-    | n < 0           = Nothing-    | V.length xs > n = Just (MaxItemsInvalid a xs)-    | otherwise       = Nothing------------------------------------------------------- * minItems-----------------------------------------------------newtype MinItems-    = MinItems { _unMinItems :: Int }-    deriving (Eq, Show)--instance FromJSON MinItems where-    parseJSON = withObject "MinItems" $ \o ->-        MinItems <$> o .: "minItems"--data MinItemsInvalid-    = MinItemsInvalid MinItems (Vector Value)-    deriving (Eq, Show)---- | The spec requires @"minItems"@ to be non-negative.-minItemsVal :: MinItems -> Vector Value -> Maybe MinItemsInvalid-minItemsVal a@(MinItems n) xs-    | n < 0           = Nothing-    | V.length xs < n = Just (MinItemsInvalid a xs)-    | otherwise       = Nothing------------------------------------------------------- * uniqueItems-----------------------------------------------------newtype UniqueItems-    = UniqueItems { _unUniqueItems :: Bool }-    deriving (Eq, Show)--instance FromJSON UniqueItems where-    parseJSON = withObject "UniqueItems" $ \o ->-        UniqueItems <$> o .: "uniqueItems"--data UniqueItemsInvalid-    = UniqueItemsInvalid (Vector Value)-    deriving (Eq, Show)--uniqueItemsVal :: UniqueItems -> Vector Value -> Maybe UniqueItemsInvalid-uniqueItemsVal (UniqueItems True) xs-   | allUniqueValues xs = Nothing-   | otherwise          = Just (UniqueItemsInvalid xs)-uniqueItemsVal (UniqueItems False) _ = Nothing------------------------------------------------------- * items-----------------------------------------------------data ItemsRelated schema = ItemsRelated-    { _irItems      :: Maybe (Items schema)-    , _irAdditional :: Maybe (AdditionalItems schema)-    } deriving (Eq, Show)--instance FromJSON schema => FromJSON (ItemsRelated schema) where-    parseJSON = withObject "ItemsRelated" $ \o -> ItemsRelated-        <$> o .:! "items"-        <*> o .:! "additionalItems"--emptyItems :: ItemsRelated schema-emptyItems = ItemsRelated-    { _irItems      = Nothing-    , _irAdditional = Nothing-    }--data Items schema-    = ItemsObject schema-    | ItemsArray [schema]-    deriving (Eq, Show)--instance FromJSON schema => FromJSON (Items schema) where-    parseJSON v = fmap ItemsObject (parseJSON v)-              <|> fmap ItemsArray (parseJSON v)--instance ToJSON schema => ToJSON (Items schema) where-    toJSON (ItemsObject hm)     = toJSON hm-    toJSON (ItemsArray schemas) = toJSON schemas--instance Arbitrary schema => Arbitrary (Items schema) where-    arbitrary = oneof [ ItemsObject <$> arbitrary-                      , ItemsArray <$> arbitrary-                      ]--data ItemsRelatedInvalid err-    = IRInvalidItems      (ItemsInvalid err)-    | IRInvalidAdditional (AdditionalItemsInvalid err)-    deriving (Eq, Show)--data ItemsInvalid err-    = ItemsObjectInvalid (NonEmpty (JP.Index, NonEmpty err))-    | ItemsArrayInvalid  (NonEmpty (JP.Index, NonEmpty err))-    deriving (Eq, Show)---- | @"additionalItems"@ only matters if @"items"@ exists--- and is a JSON Array.-itemsRelatedVal-    :: forall err schema.-       (schema -> Value -> [err])-    -> ItemsRelated schema-    -> Vector Value-    -> [ItemsRelatedInvalid err] -- NOTE: 'Data.These' would help here.-itemsRelatedVal f a xs =-    let (itemsFailure, remaining) = case _irItems a of-                                        Nothing -> (Nothing, mempty)-                                        Just b  -> itemsVal f b xs-        additionalFailure = (\b -> additionalItemsVal f b remaining)-                        =<< _irAdditional a-    in catMaybes [ IRInvalidItems <$> itemsFailure-                 , IRInvalidAdditional <$> additionalFailure-                 ]---- | Internal.------ This is because 'itemsRelated' handles @"items"@ validation.-itemsVal-    :: forall err schema.-       (schema -> Value -> [err])-    -> Items schema-    -> Vector Value-    -> (Maybe (ItemsInvalid err), [(JP.Index, Value)])-       -- ^ The second item in the tuple is the elements of the original-       -- JSON Array still remaining to be checked by @"additionalItems"@.-itemsVal f a xs =-    case a of-        ItemsObject subSchema ->-            case NE.nonEmpty (mapMaybe (validateElem subSchema) indexed) of-                Nothing   -> (Nothing, mempty)-                Just errs -> (Just (ItemsObjectInvalid errs), mempty)-        ItemsArray subSchemas ->-            let remaining = drop (length subSchemas) indexed-                res = catMaybes (zipWith validateElem subSchemas indexed)-            in case NE.nonEmpty res of-                Nothing   -> (Nothing, remaining)-                Just errs -> (Just (ItemsArrayInvalid errs), remaining)-  where-    indexed :: [(JP.Index, Value)]-    indexed = zip (JP.Index <$> [0..]) (V.toList xs)--    validateElem-        :: schema-        -> (JP.Index, Value)-        -> Maybe (JP.Index, NonEmpty err)-    validateElem schema (index,x) = (index,) <$> NE.nonEmpty (f schema x)------------------------------------------------------- * additionalItems-----------------------------------------------------data AdditionalItems schema-    = AdditionalBool   Bool-    | AdditionalObject schema-    deriving (Eq, Show)--instance FromJSON schema => FromJSON (AdditionalItems schema) where-    parseJSON v = fmap AdditionalBool (parseJSON v)-              <|> fmap AdditionalObject (parseJSON v)--instance ToJSON schema => ToJSON (AdditionalItems schema) where-    toJSON (AdditionalBool b)    = toJSON b-    toJSON (AdditionalObject hm) = toJSON hm--instance Arbitrary schema => Arbitrary (AdditionalItems schema) where-    arbitrary = oneof [ AdditionalBool <$> arbitrary-                      , AdditionalObject <$> arbitrary-                      ]--data AdditionalItemsInvalid err-    = AdditionalItemsBoolInvalid   (NonEmpty (JP.Index, Value))-    | AdditionalItemsObjectInvalid (NonEmpty (JP.Index, NonEmpty err))-    deriving (Eq, Show)---- | Internal.------ This is because 'itemsRelated' handles @"additionalItems"@ validation.-additionalItemsVal-    :: forall err schema.-       (schema -> Value -> [err])-    -> AdditionalItems schema-    -> [(JP.Index, Value)]-       -- ^ The elements remaining to validate after the ones covered by-       -- @"items"@ have been removed.-    -> Maybe (AdditionalItemsInvalid err)-additionalItemsVal _ (AdditionalBool True) _ = Nothing-additionalItemsVal _ (AdditionalBool False) xs =-    AdditionalItemsBoolInvalid <$> NE.nonEmpty xs-additionalItemsVal f (AdditionalObject subSchema) xs =-    let res = mapMaybe-                  (\(index,x) -> (index,) <$> NE.nonEmpty (f subSchema x))-                  xs-    in AdditionalItemsObjectInvalid <$> NE.nonEmpty res

@@ -1,84 +0,0 @@--module Data.Validator.Draft4.Number where--import           Import--import           Data.Fixed      (mod')-import           Data.Scientific (Scientific)------------------------------------------------------- * multipleOf-----------------------------------------------------newtype MultipleOf-    = MultipleOf { _unMultipleOf :: Scientific }-    deriving (Eq, Show)--instance FromJSON MultipleOf where-    parseJSON = withObject "MultipleOf" $ \o ->-        MultipleOf <$> o .: "multipleOf"--data MultipleOfInvalid-    = MultipleOfInvalid MultipleOf Scientific-    deriving (Eq, Show)---- | The spec requires @"multipleOf"@ to be positive.-multipleOfVal :: MultipleOf -> Scientific -> Maybe MultipleOfInvalid-multipleOfVal a@(MultipleOf n) x-    | n <= 0          = Nothing-    | x `mod'` n /= 0 = Just (MultipleOfInvalid a x)-    | otherwise       = Nothing------------------------------------------------------- * maximum-----------------------------------------------------data Maximum = Maximum-    { _maximumExclusive :: Bool-    , _maximumValue     :: Scientific-    } deriving (Eq, Show)--instance FromJSON Maximum where-    parseJSON = withObject "Maximum" $ \o -> Maximum-        <$> o .:! "exclusiveMaximum" .!= False-        <*> o .: "maximum"--data MaximumInvalid-    = MaximumInvalid Maximum Scientific-    deriving (Eq, Show)--maximumVal-    :: Maximum-    -> Scientific-    -> Maybe MaximumInvalid-maximumVal a@(Maximum exclusive n) x-    | exclusive && x >= n = Just (MaximumInvalid a x)-    | x > n               = Just (MaximumInvalid a x)-    | otherwise           = Nothing------------------------------------------------------- * minimum-----------------------------------------------------data Minimum = Minimum-    { _minimumExclusive :: Bool-    , _minimumValue     :: Scientific-    } deriving (Eq, Show)--instance FromJSON Minimum where-    parseJSON = withObject "Minimum" $ \o -> Minimum-        <$> o .:! "exclusiveMinimum" .!= False-        <*> o .: "minimum"--data MinimumInvalid-    = MinimumInvalid Minimum Scientific-    deriving (Eq, Show)--minimumVal-    :: Minimum-    -> Scientific-    -> Maybe MinimumInvalid-minimumVal a@(Minimum exclusive n) x-    | exclusive && x <= n = Just (MinimumInvalid a x)-    | x < n               = Just (MinimumInvalid a x)-    | otherwise           = Nothing

@@ -1,179 +0,0 @@--module Data.Validator.Draft4.Object-  ( module Data.Validator.Draft4.Object-  , module Data.Validator.Draft4.Object.Properties-  ) where--import           Import--import qualified Data.HashMap.Strict                     as HM-import qualified Data.List.NonEmpty                      as NE-import           Data.Set                                (Set)-import qualified Data.Set                                as S-import qualified Data.Text                               as T--import           Data.Validator.Draft4.Object.Properties-import           Data.Validator.Utils------------------------------------------------------- * maxProperties-----------------------------------------------------newtype MaxProperties-    = MaxProperties { _unMaxProperties :: Int }-    deriving (Eq, Show)--instance FromJSON MaxProperties where-    parseJSON = withObject "MaxProperties" $ \o ->-        MaxProperties <$> o .: "maxProperties"--data MaxPropertiesInvalid-    = MaxPropertiesInvalid MaxProperties (HashMap Text Value)-    deriving (Eq, Show)---- | The spec requires @"maxProperties"@ to be non-negative.-maxPropertiesVal-    :: MaxProperties-    -> HashMap Text Value-    -> Maybe MaxPropertiesInvalid-maxPropertiesVal a@(MaxProperties n) x-    | n < 0         = Nothing-    | HM.size x > n = Just (MaxPropertiesInvalid a x)-    | otherwise     = Nothing------------------------------------------------------- * minProperties-----------------------------------------------------newtype MinProperties-    = MinProperties { _unMinProperties :: Int }-    deriving (Eq, Show)--instance FromJSON MinProperties where-    parseJSON = withObject "MinProperties" $ \o ->-        MinProperties <$> o .: "minProperties"--data MinPropertiesInvalid-    = MinPropertiesInvalid MinProperties (HashMap Text Value)-    deriving (Eq, Show)---- | The spec requires @"minProperties"@ to be non-negative.-minPropertiesVal-    :: MinProperties-    -> HashMap Text Value-    -> Maybe MinPropertiesInvalid-minPropertiesVal a@(MinProperties n) x-    | n < 0         = Nothing-    | HM.size x < n = Just (MinPropertiesInvalid a x)-    | otherwise     = Nothing------------------------------------------------------- * required------------------------------------------------------- | From the spec:------ > The value of this keyword MUST be an array.--- > This array MUST have at least one element.--- > Elements of this array MUST be strings, and MUST be unique.-newtype Required-    = Required { _unRequired :: Set Text }-    deriving (Eq, Show)--instance FromJSON Required where-    parseJSON = withObject "Required" $ \o ->-        Required <$> o .: "required"--instance Arbitrary Required where-    arbitrary = do-        x  <- arbitraryText -- Guarantee at least one element.-        xs <- (fmap.fmap) T.pack arbitrary-        pure . Required . S.fromList $ x:xs--requiredVal :: Required -> HashMap Text Value -> Maybe ()-requiredVal (Required ts) x-    -- NOTE: When we no longer need to support GHCs before 7.10-    -- we can use null from Prelude throughout the library-    -- instead of specialized versions.-    | S.null ts                    = Nothing-    | HM.null (HM.difference hm x) = Nothing-    | otherwise                    = Just () -- TODO-  where-    hm :: HashMap Text Bool-    hm = foldl (\b a -> HM.insert a True b) mempty ts------------------------------------------------------- * dependencies-----------------------------------------------------newtype DependenciesValidator schema-    = DependenciesValidator-        { _unDependenciesValidator :: HashMap Text (Dependency schema) }-    deriving (Eq, Show)--instance FromJSON schema => FromJSON (DependenciesValidator schema) where-    parseJSON = withObject "DependenciesValidator" $ \o ->-        DependenciesValidator <$> o .: "dependencies"--data Dependency schema-    = SchemaDependency schema-    | PropertyDependency (Set Text)-    deriving (Eq, Show)--instance FromJSON schema => FromJSON (Dependency schema) where-    parseJSON v = fmap SchemaDependency (parseJSON v)-              <|> fmap PropertyDependency (parseJSON v)--instance ToJSON schema => ToJSON (Dependency schema) where-    toJSON (SchemaDependency schema) = toJSON schema-    toJSON (PropertyDependency ts)   = toJSON ts--instance Arbitrary schema => Arbitrary (Dependency schema) where-    arbitrary = oneof [ SchemaDependency <$> arbitrary-                      , PropertyDependency <$> arbitrarySetOfText-                      ]--data DependencyMemberInvalid err-    = SchemaDepInvalid   (NonEmpty err)-    | PropertyDepInvalid (Set Text) (HashMap Text Value)-    deriving (Eq, Show)--data DependenciesInvalid err-    = DependenciesInvalid (HashMap Text (DependencyMemberInvalid err))-    deriving (Eq, Show)---- | From the spec:--- <http://json-schema.org/latest/json-schema-validation.html#anchor70>------ > This keyword's value MUST be an object.--- > Each value of this object MUST be either an object or an array.--- >--- > If the value is an object, it MUST be a valid JSON Schema.--- > This is called a schema dependency.--- >--- > If the value is an array, it MUST have at least one element.--- > Each element MUST be a string, and elements in the array MUST be unique.--- > This is called a property dependency.-dependenciesVal-    :: forall err schema.-       (schema -> Value -> [err])-    -> DependenciesValidator schema-    -> HashMap Text Value-    -> Maybe (DependenciesInvalid err)-dependenciesVal f (DependenciesValidator hm) x =-    let res = HM.mapMaybeWithKey g hm-    in if HM.null res-        then Nothing-        else Just (DependenciesInvalid res)-    where-      g :: Text -> Dependency schema -> Maybe (DependencyMemberInvalid err)-      g k (SchemaDependency schema)-          | HM.member k x = SchemaDepInvalid-                        <$> NE.nonEmpty (f schema (Object x))-          | otherwise = Nothing-      g k (PropertyDependency ts)-          | HM.member k x && not allPresent = Just (PropertyDepInvalid ts x)-          | otherwise                       = Nothing-        where-          allPresent :: Bool-          allPresent = all (`HM.member` x) ts

@@ -1,209 +0,0 @@--module Data.Validator.Draft4.Object.Properties where--import           Import--import qualified Data.Hashable         as HA-import qualified Data.HashMap.Strict   as HM-import qualified Data.List.NonEmpty    as NE-import           Data.Text.Encoding    (encodeUtf8)-import qualified JSONPointer           as JP-import qualified Text.Regex.PCRE.Heavy as RE--data PropertiesRelated schema = PropertiesRelated-    { _propProperties :: Maybe (HashMap Text schema)-    , _propPattern    :: Maybe (HashMap Text schema)-    , _propAdditional :: Maybe (AdditionalProperties schema)-    } deriving (Eq, Show)--instance FromJSON schema => FromJSON (PropertiesRelated schema) where-    parseJSON = withObject "PropertiesRelated" $ \o -> PropertiesRelated-        <$> o .:! "properties"-        <*> o .:! "patternProperties"-        <*> o .:! "additionalProperties"--emptyProperties :: PropertiesRelated schema-emptyProperties = PropertiesRelated-    { _propProperties = Nothing-    , _propPattern    = Nothing-    , _propAdditional = Nothing-    }--data AdditionalProperties schema-    = AdditionalPropertiesBool Bool-    | AdditionalPropertiesObject schema-    deriving (Eq, Show)--instance FromJSON schema => FromJSON (AdditionalProperties schema) where-    parseJSON v = fmap AdditionalPropertiesBool (parseJSON v)-              <|> fmap AdditionalPropertiesObject (parseJSON v)--instance ToJSON schema => ToJSON (AdditionalProperties schema) where-    toJSON (AdditionalPropertiesBool b)    = toJSON b-    toJSON (AdditionalPropertiesObject hm) = toJSON hm--instance Arbitrary schema => Arbitrary (AdditionalProperties schema) where-    arbitrary = oneof [ AdditionalPropertiesBool <$> arbitrary-                      , AdditionalPropertiesObject <$> arbitrary-                      ]---- | A glorified @type@ alias.-newtype Regex-    = Regex { _unRegex :: Text }-    deriving (Eq, Show, Generic)--instance HA.Hashable Regex---- NOTE: We'd like to enforce that at least one error exists here.-data PropertiesRelatedInvalid err = PropertiesRelatedInvalid-    { _prInvalidProperties :: HashMap Text [err]-    , _prInvalidPattern    :: HashMap (Regex, JP.Key) [err]-    , _prInvalidAdditional :: Maybe (APInvalid err)-    } deriving (Eq, Show)--data APInvalid err-    = APBoolInvalid   (HashMap Text Value)-    | APObjectInvalid (HashMap Text (NonEmpty err))-    deriving (Eq, Show)---- | First @"properties"@ and @"patternProperties"@ are run simultaneously--- on the data, then @"additionalProperties"@ is run on the remainder.-propertiesRelatedVal-    :: forall err schema.-       (schema -> Value -> [err])-    -> PropertiesRelated schema-    -> HashMap Text Value-    -> Maybe (PropertiesRelatedInvalid err)-propertiesRelatedVal f props x-    |  all null (HM.elems propFailures)-    && all null (HM.elems patFailures)-    && isNothing addFailures = Nothing-    | otherwise =-        Just PropertiesRelatedInvalid-            { _prInvalidProperties = propFailures-            , _prInvalidPattern    = patFailures-            , _prInvalidAdditional = addFailures-            }-  where-    propertiesHm :: HashMap Text schema-    propertiesHm = fromMaybe mempty (_propProperties props)--    patHm :: HashMap Text schema-    patHm = fromMaybe mempty (_propPattern props)--    propAndUnmatched :: (HashMap Text [err], Remaining)-    propAndUnmatched = ( HM.intersectionWith f propertiesHm x-                       , Remaining (HM.difference x propertiesHm)-                       )--    (propFailures, propRemaining) = propAndUnmatched--    patAndUnmatched :: (HashMap (Regex, JP.Key) [err], Remaining)-    patAndUnmatched = patternAndUnmatched f patHm x--    (patFailures, patRemaining) = patAndUnmatched--    finalRemaining :: Remaining-    finalRemaining = Remaining (HM.intersection (_unRemaining patRemaining)-                                                (_unRemaining propRemaining))--    addFailures :: Maybe (APInvalid err)-    addFailures = (\addProp -> additionalProperties f addProp finalRemaining)-              =<< _propAdditional props---- | Internal.-newtype Remaining-    = Remaining { _unRemaining :: HashMap Text Value }---- | Internal.-patternAndUnmatched-    :: forall err schema.-       (schema -> Value -> [err])-    -> HashMap Text schema-    -> HashMap Text Value-    -> (HashMap (Regex, JP.Key) [err], Remaining)-patternAndUnmatched f patPropertiesHm x =-    (HM.foldlWithKey' runMatches mempty perhapsMatches, remaining)-  where-    -- @[(Regex, schema)]@ will have one item per match.-    perhapsMatches :: HashMap Text ([(Regex, schema)], Value)-    perhapsMatches =-        HM.foldlWithKey' (matchingSchemas patPropertiesHm) mempty x-      where-        matchingSchemas-            :: HashMap Text schema-            -> HashMap Text ([(Regex, schema)], Value)-            -> Text-            -> Value-            -> HashMap Text ([(Regex, schema)], Value)-        matchingSchemas subSchemas acc k v =-            HM.insert k-                      (HM.foldlWithKey' (checkKey k) mempty subSchemas, v)-                      acc--        checkKey-            :: Text-            -> [(Regex, schema)]-            -> Text-            -> schema-            -> [(Regex, schema)]-        checkKey k acc r subSchema =-            case RE.compileM (encodeUtf8 r) mempty of-                Left _   -> acc-                Right re -> if k RE.=~ re-                                then (Regex r, subSchema) : acc-                                else acc--    runMatches-        :: HashMap (Regex, JP.Key) [err]-        -> Text-        -> ([(Regex, schema)], Value)-        -> HashMap (Regex, JP.Key) [err]-    runMatches acc k (matches,v) =-        foldr runMatch acc matches-      where-        runMatch-            :: (Regex, schema)-            -> HashMap (Regex, JP.Key) [err]-            -> HashMap (Regex, JP.Key) [err]-        runMatch (r,schema) = HM.insert (r, JP.Key k) (f schema v)--    remaining :: Remaining-    remaining = Remaining . fmap snd . HM.filter (null . fst) $ perhapsMatches---- Internal.-additionalProperties-    :: forall err schema.-       (schema -> Value -> [err])-    -> AdditionalProperties schema-    -> Remaining-    -> Maybe (APInvalid err)-additionalProperties f a x =-    case a of-        AdditionalPropertiesBool b ->-            APBoolInvalid <$> additionalPropertiesBool b x-        AdditionalPropertiesObject b ->-            APObjectInvalid <$> additionalPropertiesObject f b x---- | Internal.-additionalPropertiesBool-    :: Bool-    -> Remaining-    -> Maybe (HashMap Text Value)-additionalPropertiesBool True _ = Nothing-additionalPropertiesBool False (Remaining x)-    | HM.size x > 0 = Just x-    | otherwise     = Nothing---- | Internal.-additionalPropertiesObject-    :: forall err schema.-       (schema -> Value -> [err])-    -> schema-    -> Remaining-    -> Maybe (HashMap Text (NonEmpty err))-additionalPropertiesObject f schema (Remaining x) =-    let errs = HM.mapMaybe (NE.nonEmpty . f schema) x-    in if HM.null errs-        then Nothing-        else Just errs

@@ -1,79 +0,0 @@--module Data.Validator.Draft4.String where--import           Import--import qualified Data.Text             as T-import           Data.Text.Encoding    (encodeUtf8)-import qualified Text.Regex.PCRE.Heavy as RE------------------------------------------------------- * maxLength-----------------------------------------------------newtype MaxLength-    = MaxLength { _unMaxLength :: Int }-    deriving (Eq, Show)--instance FromJSON MaxLength where-    parseJSON = withObject "MaxLength" $ \o ->-        MaxLength <$> o .: "maxLength"--data MaxLengthInvalid-    = MaxLengthInvalid MaxLength Text-    deriving (Eq, Show)---- | The spec requires @"maxLength"@ to be non-negative.-maxLengthVal :: MaxLength -> Text -> Maybe MaxLengthInvalid-maxLengthVal a@(MaxLength n) x-    | n <= 0         = Nothing-    | T.length x > n = Just (MaxLengthInvalid a x)-    | otherwise      = Nothing------------------------------------------------------- * minLength-----------------------------------------------------newtype MinLength-    = MinLength { _unMinLength :: Int }-    deriving (Eq, Show)--instance FromJSON MinLength where-    parseJSON = withObject "MinLength" $ \o ->-        MinLength <$> o .: "minLength"--data MinLengthInvalid-    = MinLengthInvalid MinLength Text-    deriving (Eq, Show)---- | The spec requires @"minLength"@ to be non-negative.-minLengthVal :: MinLength -> Text -> Maybe MinLengthInvalid-minLengthVal a@(MinLength n) x-    | n <= 0         = Nothing-    | T.length x < n = Just (MinLengthInvalid a x)-    | otherwise      = Nothing------------------------------------------------------- * pattern-----------------------------------------------------newtype PatternValidator-    = PatternValidator { _unPatternValidator :: Text }-    deriving (Eq, Show)--instance FromJSON PatternValidator where-    parseJSON = withObject "PatternValidator" $ \o ->-        PatternValidator <$> o .: "pattern"--data PatternInvalid-    = PatternNotRegex -- TODO: let these pass successfully?-    | PatternInvalid PatternValidator Text-    deriving (Eq, Show)--patternVal :: PatternValidator -> Text -> Maybe PatternInvalid-patternVal a@(PatternValidator t) x =-    case RE.compileM (encodeUtf8 t) mempty of-        Left _   -> Just PatternNotRegex-        Right re -> if x RE.=~ re-                        then Nothing-                        else Just (PatternInvalid a x)

@@ -1,79 +0,0 @@--- | JSON Reference is described here:--- <http://tools.ietf.org/html/draft-pbryan-zyp-json-ref-03>------ And is extended for JSON Schema here:--- <http://json-schema.org/latest/json-schema-core.html#anchor26>--module Data.Validator.Reference where--import           Import--import qualified Data.Text              as T-import           Data.Text.Encoding     (decodeUtf8, encodeUtf8)-import qualified JSONPointer            as JP-import           Network.HTTP.Types.URI (urlDecode)-import           System.FilePath        ((</>), dropFileName)---- | TODO: Replace these with actual URI data types.-type URIBase = Maybe Text-type URIBaseAndFragment = (Maybe Text, Maybe Text)--updateResolutionScope :: URIBase -> Maybe Text -> URIBase-updateResolutionScope mScope idKeyword-    | Just t <- idKeyword = fst . baseAndFragment $ resolveScopeAgainst mScope t-    | otherwise           = mScope--resolveReference :: URIBase -> Text -> URIBaseAndFragment-resolveReference mScope t = baseAndFragment $ resolveScopeAgainst mScope t--resolveFragment-    :: (FromJSON schema, ToJSON schema)-    => Maybe Text-    -> schema-    -> Maybe schema-resolveFragment Nothing schema        = Just schema-resolveFragment (Just pointer) schema = do-    let urlDecoded = decodeUtf8 . urlDecode True . encodeUtf8 $ pointer-    p <- either (const Nothing) Just (JP.unescape urlDecoded)-    x <- either (const Nothing) Just (JP.resolve p (toJSON schema))-    case fromJSON x of-        Error _         -> Nothing-        Success schema' -> Just schema'------------------------------------------------------- * Helpers-----------------------------------------------------isRemoteReference :: Text -> Bool-isRemoteReference = T.isInfixOf "://"--baseAndFragment :: Text -> URIBaseAndFragment-baseAndFragment = f . T.splitOn "#"-  where-    f :: [Text] -> URIBaseAndFragment-    f [x]   = (g x, Nothing)-    f [x,y] = (g x, g y)-    f _     = (Nothing, Nothing)--    g "" = Nothing-    g x  = Just x--resolveScopeAgainst :: Maybe Text -> Text -> Text-resolveScopeAgainst Nothing t = t-resolveScopeAgainst (Just scope) t-    | isRemoteReference t = t-    | otherwise           = smartAppend-  where-    -- There shouldn't be a fragment at the end of a scope URI,-    -- but just in case a user leaves one in we want to be sure-    -- to cut it off before appending.-    smartAppend :: Text-    smartAppend =-        case baseAndFragment scope of-            (Just base,_) ->-                case T.unpack t of-                    -- We want "/foo" and "#/bar" to combine into-                    -- "/foo#/bar" not "/foo/#/bar".-                    '#':_ -> base <> t-                    _     -> T.pack (dropFileName (T.unpack base) </> T.unpack t)-            _ -> t

@@ -1,23 +0,0 @@--module Data.Validator.Types where--import           Import--import           Data.Profunctor (Profunctor(..))--data Validator schema val err = Validator-    { _embedded :: val -> ([schema], [schema])-      -- ^ The first list is embedded schemas that validate the same piece-      -- of data this schema validates (such as schemas embedded in 'allOf').-      -- The second is embedded schemas that validate a subset of that data-      -- (such as the schemas embedded in 'items').-      ---      -- This is done to allow static detection of loops, though this isn't-      -- implemented yet (though the Draft4 code does do live loop detection-      -- during validation).-    , _validate :: val -> Value -> [err]-    } deriving Functor--instance Profunctor (Validator schema) where-    lmap f (Validator a b) = Validator (lmap f a) (lmap f b)-    rmap = fmap

@@ -1,135 +0,0 @@--module Data.Validator.Utils where--import           Import--import           Control.Monad        (fail)-import qualified Data.HashMap.Strict  as HM-import qualified Data.List.NonEmpty   as NE-import           Data.Scientific      (Scientific, fromFloatDigits)-import           Data.Set             (Set)-import qualified Data.Set             as S-import qualified Data.Text            as T-import qualified Data.Vector          as V------------------------------------------------------- * QuickCheck-----------------------------------------------------arbitraryText :: Gen Text-arbitraryText = T.pack <$> arbitrary--arbitraryScientific :: Gen Scientific-arbitraryScientific = (fromFloatDigits :: Double -> Scientific) <$> arbitrary--arbitraryPositiveScientific :: Gen Scientific-arbitraryPositiveScientific = (fromFloatDigits :: Double -> Scientific)-                            . getPositive-                          <$> arbitrary--newtype ArbitraryValue-    = ArbitraryValue { _unArbitraryValue :: Value }-    deriving (Eq, Show)--instance Arbitrary ArbitraryValue where-    arbitrary = ArbitraryValue <$> sized f-      where-        f :: Int -> Gen Value-        f n | n <= 1    = oneof nonRecursive-            | otherwise = oneof $-                  fmap (Array . V.fromList) (traverse (const (f (n `div` 10)))-                    =<< (arbitrary :: Gen [()]))-                : fmap (Object . HM.fromList) (traverse (const (g (n `div` 10)))-                    =<< (arbitrary :: Gen [()]))-                : nonRecursive--        g :: Int -> Gen (Text, Value)-        g n = (,) <$> arbitraryText <*> f n--        nonRecursive :: [Gen Value]-        nonRecursive =-            [ pure Null-            , Bool <$> arbitrary-            , String <$> arbitraryText-            , Number <$> arbitraryScientific-            ]--arbitraryHashMap :: Arbitrary a => Gen (HashMap Text a)-arbitraryHashMap = HM.fromList . fmap (first T.pack) <$> arbitrary--arbitrarySetOfText :: Gen (Set Text)-arbitrarySetOfText = S.fromList . fmap T.pack <$> arbitrary--newtype NonEmpty' a = NonEmpty' { _unNonEmpty' :: NonEmpty a }--instance FromJSON a => FromJSON (NonEmpty' a) where-    parseJSON v = do-        xs <- parseJSON v-        case NE.nonEmpty xs of-            Nothing -> fail "Must have at least one item."-            Just ne -> pure (NonEmpty' ne)--instance ToJSON a => ToJSON (NonEmpty' a) where-    toJSON = toJSON . NE.toList . _unNonEmpty'--instance Arbitrary a => Arbitrary (NonEmpty' a) where-    arbitrary = do-        xs <- arbitrary-        case NE.nonEmpty xs of-            Nothing -> NonEmpty' . pure <$> arbitrary-            Just ne -> pure (NonEmpty' ne)------------------------------------------------------- * allUniqueValues-----------------------------------------------------allUniqueValues :: Vector Value -> Bool-allUniqueValues = allUnique . fmap OrdValue . V.toList---- NOTE: When we no longer support GHC 7.8 we can generalize--- allUnique to work on any Foldable and remove this function.-allUniqueValues' :: NonEmpty Value -> Bool-allUniqueValues' = allUnique . fmap OrdValue . NE.toList--allUnique :: (Ord a) => [a] -> Bool-allUnique xs = S.size (S.fromList xs) == length xs---- | OrdValue's Ord instance needs benchmarking, but it allows us to--- use our 'allUnique' function instead of O(n^2) nub, so it's probably--- worth it.-newtype OrdValue = OrdValue { _unOrdValue :: Value } deriving Eq--instance Ord OrdValue where-    (OrdValue Null) `compare` (OrdValue Null) = EQ-    (OrdValue Null) `compare` _               = LT-    _               `compare` (OrdValue Null) = GT--    (OrdValue (Bool x)) `compare` (OrdValue (Bool y)) = x `compare` y-    (OrdValue (Bool _)) `compare` _                   = LT-    _                   `compare` (OrdValue (Bool _)) = GT--    (OrdValue (Number x)) `compare` (OrdValue (Number y)) = x `compare` y-    (OrdValue (Number _)) `compare` _                     = LT-    _                     `compare` (OrdValue (Number _)) = GT--    (OrdValue (String x)) `compare` (OrdValue (String y)) = x `compare` y-    (OrdValue (String _)) `compare` _                     = LT-    _                     `compare` (OrdValue (String _)) = GT--    (OrdValue (Array xs)) `compare` (OrdValue (Array ys)) =-        (OrdValue <$> xs) `compare` (OrdValue <$> ys)-    (OrdValue (Array _))  `compare` _                     = LT-    _                     `compare` (OrdValue (Array _))  = GT--    (OrdValue (Object x)) `compare` (OrdValue (Object y)) =-        HM.toList (OrdValue <$> x) `compare` HM.toList (OrdValue <$> y)------------------------------------------------------- * other-----------------------------------------------------fromJSONEither :: FromJSON a => Value -> Either Text a-fromJSONEither a =-    case fromJSON a of-        Error e   -> Left (T.pack e)-        Success b -> Right b

@@ -0,0 +1,195 @@+{-# LANGUAGE TemplateHaskell #-}++module JSONSchema.Draft4+    ( -- * Draft 4 Schema+      SchemaWithURI(..)+    , Schema(..)+    , SC.emptySchema++      -- * One-step validation (getting references over HTTP)+    , fetchHTTPAndValidate+    , HTTPValidationFailure(..)+    , FE.HTTPFailure(..)+    , SchemaInvalid(..)++      -- * One-step validation (getting references from the filesystem)+    , fetchFilesystemAndValidate+    , FilesystemValidationFailure(..)+    , FE.FilesystemFailure(..)++      -- * Validation failure+    , Invalid(..)+    , ValidatorFailure(..)++      -- * Fetching tools+    , ReferencedSchemas(..)+    , FE.URISchemaMap(..)+    , referencesViaHTTP+    , referencesViaFilesystem++      -- * Other Draft 4 things exported just in case+    , metaSchema+    , metaSchemaBytes+    , schemaValidity+    , referencesValidity+    , checkSchema+    , draft4FetchInfo+    ) where++import           Import++import           Control.Arrow             (left)+import qualified Data.ByteString           as BS+import           Data.FileEmbed            (embedFile,+                                            makeRelativeToProject)+import qualified Data.HashMap.Strict       as HM+import qualified Data.List.NonEmpty        as NE+import           Data.Maybe                (fromMaybe)++import           JSONSchema.Draft4.Failure (Invalid(..),+                                            SchemaInvalid(..),+                                            ValidatorFailure(..))+import           JSONSchema.Draft4.Schema  (Schema)+import qualified JSONSchema.Draft4.Schema  as SC+import qualified JSONSchema.Draft4.Spec    as Spec+import           JSONSchema.Fetch          (ReferencedSchemas(..),+                                            SchemaWithURI(..))+import qualified JSONSchema.Fetch          as FE++data HTTPValidationFailure+    = HVRequest FE.HTTPFailure+    | HVSchema  SchemaInvalid+    | HVData    Invalid+    deriving Show++-- | Fetch recursively referenced schemas over HTTP, check that both the+-- original and referenced schemas are valid, then validate then data.+fetchHTTPAndValidate+    :: SchemaWithURI Schema+    -> Value+    -> IO (Either HTTPValidationFailure ())+fetchHTTPAndValidate sw v = do+    res <- referencesViaHTTP sw+    pure (g =<< f =<< left HVRequest res)+  where+    f :: FE.URISchemaMap Schema+      -> Either HTTPValidationFailure (Value -> [ValidatorFailure])+    f references = left HVSchema (checkSchema references sw)++    g :: (Value -> [ValidatorFailure]) -> Either HTTPValidationFailure ()+    g val = case NE.nonEmpty (val v) of+                Nothing       -> Right ()+                Just failures -> Left (HVData Invalid+                                     { _invalidSchema   = _swSchema sw+                                     , _invalidInstance = v+                                     , _invalidFailures = failures+                                     })++data FilesystemValidationFailure+    = FVRead   FE.FilesystemFailure+    | FVSchema SchemaInvalid+    | FVData   Invalid+    deriving (Show, Eq)++-- | Fetch recursively referenced schemas from the filesystem, check+-- that both the original and referenced schemas are valid, then validate+-- the data.+fetchFilesystemAndValidate+    :: SchemaWithURI Schema+    -> Value+    -> IO (Either FilesystemValidationFailure ())+fetchFilesystemAndValidate sw v = do+    res <- referencesViaFilesystem sw+    pure (g =<< f =<< left FVRead res)+  where+    f :: FE.URISchemaMap Schema+      -> Either FilesystemValidationFailure (Value -> [ValidatorFailure])+    f references = left FVSchema (checkSchema references sw)++    g :: (Value -> [ValidatorFailure]) -> Either FilesystemValidationFailure ()+    g val = case NE.nonEmpty (val v) of+                Nothing      -> Right ()+                Just invalid -> Left (FVData Invalid+                                    { _invalidSchema   = _swSchema sw+                                    , _invalidInstance = v+                                    , _invalidFailures = invalid+                                    })++-- | An instance of 'JSONSchema.Fetch.FetchInfo' specialized for+-- JSON Schema Draft 4.+draft4FetchInfo :: FE.FetchInfo Schema+draft4FetchInfo = FE.FetchInfo Spec.embedded SC._schemaId SC._schemaRef++-- | Fetch the schemas recursively referenced by a starting schema over HTTP.+referencesViaHTTP+    :: SchemaWithURI Schema+    -> IO (Either FE.HTTPFailure (FE.URISchemaMap Schema))+referencesViaHTTP = FE.referencesViaHTTP' draft4FetchInfo++-- | Fetch the schemas recursively referenced by a starting schema from+-- the filesystem.+referencesViaFilesystem+    :: SchemaWithURI Schema+    -> IO (Either FE.FilesystemFailure (FE.URISchemaMap Schema))+referencesViaFilesystem = FE.referencesViaFilesystem' draft4FetchInfo++-- | Checks if a schema and a set of referenced schemas are valid.+--+-- Return a function to validate data.+checkSchema+    :: FE.URISchemaMap Schema+    -> SchemaWithURI Schema+    -> Either SchemaInvalid (Value -> [ValidatorFailure])+checkSchema sm sw =+    case NE.nonEmpty failures of+        Just fs -> Left (SchemaInvalid fs)+        Nothing -> Right (Spec.specValidate+                             (ReferencedSchemas (_swSchema sw)+                                                (FE._unURISchemaMap sm))+                             sw)+  where+    failures :: [(Maybe Text, NonEmpty ValidatorFailure)]+    failures =+        let refFailures = first Just <$> referencesValidity sm+        in case NE.nonEmpty (schemaValidity (_swSchema sw)) of+                     Nothing   -> refFailures+                     Just errs -> (Nothing,errs) : refFailures++metaSchema :: Schema+metaSchema =+      fromMaybe (panic "Schema decode failed (this should never happen)")+    . decodeStrict+    $ metaSchemaBytes++metaSchemaBytes :: BS.ByteString+metaSchemaBytes =+    $(makeRelativeToProject "src/draft4.json" >>= embedFile)++-- | Check that a schema itself is valid+-- (if so the returned list will be empty).+schemaValidity :: Schema -> [ValidatorFailure]+schemaValidity =+    Spec.specValidate referenced (SchemaWithURI metaSchema Nothing) . toJSON+  where+    referenced :: ReferencedSchemas Schema+    referenced = ReferencedSchemas+                     metaSchema+                     (HM.singleton "http://json-schema.org/draft-04/schema"+                                   metaSchema)++-- | Check that a set of referenced schemas are valid+-- (if so the returned list will be empty).+referencesValidity+  :: FE.URISchemaMap Schema+  -> [(Text, NonEmpty ValidatorFailure)]+  -- ^ The first item of the tuple is the URI of a schema, the second+  -- is that schema's validation errors.+referencesValidity = HM.foldlWithKey' f mempty . FE._unURISchemaMap+  where+    f :: [(Text, NonEmpty ValidatorFailure)]+      -> Text+      -> Schema+      -> [(Text, NonEmpty ValidatorFailure)]+    f acc k v = case NE.nonEmpty (schemaValidity v) of+                    Nothing   -> acc+                    Just errs -> (k,errs) : acc

@@ -0,0 +1,59 @@++module JSONSchema.Draft4.Failure where++import           Import++import           JSONSchema.Draft4.Schema    (Schema)+import qualified JSONSchema.Validator.Draft4 as D4++-- | Used to report an entire instance being invalidated, as opposed+-- to the failure of a single validator.+data Invalid = Invalid+    { _invalidSchema   :: Schema+    , _invalidInstance :: Value+    , _invalidFailures :: NonEmpty ValidatorFailure+    } deriving (Eq, Show)++data ValidatorFailure+    = FailureMultipleOf D4.MultipleOfInvalid+    | FailureMaximum    D4.MaximumInvalid+    | FailureMinimum    D4.MinimumInvalid++    | FailureMaxLength D4.MaxLengthInvalid+    | FailureMinLength D4.MinLengthInvalid+    | FailurePattern   D4.PatternInvalid++    | FailureMaxItems        D4.MaxItemsInvalid+    | FailureMinItems        D4.MinItemsInvalid+    | FailureUniqueItems     D4.UniqueItemsInvalid+    | FailureItems           (D4.ItemsInvalid ValidatorFailure)+    | FailureAdditionalItems (D4.AdditionalItemsInvalid ValidatorFailure)++    | FailureMaxProperties     D4.MaxPropertiesInvalid+    | FailureMinProperties     D4.MinPropertiesInvalid+    | FailureRequired          ()+    | FailureDependencies      (D4.DependenciesInvalid ValidatorFailure)+    | FailurePropertiesRelated (D4.PropertiesRelatedInvalid ValidatorFailure)++    | FailureRef   (D4.RefInvalid ValidatorFailure)+    | FailureEnum  D4.EnumInvalid+    | FailureType  D4.TypeValidatorInvalid+    | FailureAllOf (D4.AllOfInvalid ValidatorFailure)+    | FailureAnyOf (D4.AnyOfInvalid ValidatorFailure)+    | FailureOneOf (D4.OneOfInvalid ValidatorFailure)+    | FailureNot   D4.NotValidatorInvalid+    deriving (Eq, Show)++-- | A description of why a schema (or one of its reference) is itself+-- invalid.+--+-- 'Nothing' indicates the starting schema. 'Just' indicates a referenced+-- schema. The contents of the 'Just' is the schema's URI.+--+-- NOTE: 'HashMap (Maybe Text) Invalid' would be a nicer way of+-- defining this, but then we lose the guarantee that there's at least+-- one key.+newtype SchemaInvalid+    = SchemaInvalid {+        _unSchemaInvalid :: NonEmpty (Maybe Text, NonEmpty ValidatorFailure) }+    deriving (Eq, Show)

@@ -0,0 +1,342 @@++module JSONSchema.Draft4.Schema where++import           Import                      hiding (mapMaybe)++import qualified Data.HashMap.Strict         as HM+import           Data.List.NonEmpty          (NonEmpty)+import           Data.Maybe                  (fromJust, isJust)+import           Data.Scientific+import qualified Data.Set                    as Set+import qualified Data.Text                   as T++import qualified JSONSchema.Validator.Draft4 as D4+import           JSONSchema.Validator.Utils++data Schema = Schema+    { _schemaVersion              :: Maybe Text+    , _schemaId                   :: Maybe Text+    , _schemaRef                  :: Maybe Text+    , _schemaDefinitions          :: Maybe (HashMap Text Schema)+    -- ^ A standardized location for embedding schemas+    -- to be referenced from elsewhere in the document.+    , _schemaOther                :: HashMap Text Value+    -- ^ Since the JSON document this schema was built from could+    -- contain schemas anywhere (not just in "definitions" or any+    -- of the other official keys) we save any leftover key/value+    -- pairs not covered by them here.+    --+    -- TODO: This field is the source of most of the complication in this+    -- module and needs to be removed. It should be doable, though it will+    -- involve some modification to the fetching code.++    , _schemaMultipleOf           :: Maybe Scientific+    , _schemaMaximum              :: Maybe Scientific+    , _schemaExclusiveMaximum     :: Maybe Bool+    , _schemaMinimum              :: Maybe Scientific+    , _schemaExclusiveMinimum     :: Maybe Bool++    , _schemaMaxLength            :: Maybe Int+    , _schemaMinLength            :: Maybe Int+    , _schemaPattern              :: Maybe Text++    , _schemaMaxItems             :: Maybe Int+    , _schemaMinItems             :: Maybe Int+    , _schemaUniqueItems          :: Maybe Bool+    , _schemaItems                :: Maybe (D4.Items Schema)+    -- Note that '_schemaAdditionalItems' is left out of 'runValidate'+    -- because its functionality is handled by '_schemaItems'. It always+    -- validates data unless 'Items' is present.+    , _schemaAdditionalItems      :: Maybe (D4.AdditionalItems Schema)++    , _schemaMaxProperties        :: Maybe Int+    , _schemaMinProperties        :: Maybe Int+    , _schemaRequired             :: Maybe (Set Text)+    , _schemaDependencies         :: Maybe (HashMap Text (D4.Dependency Schema))+    , _schemaProperties           :: Maybe (HashMap Text Schema)+    , _schemaPatternProperties    :: Maybe (HashMap Text Schema)+    , _schemaAdditionalProperties :: Maybe (D4.AdditionalProperties Schema)++    , _schemaEnum                 :: Maybe (NonEmpty Value)+    , _schemaType                 :: Maybe D4.TypeValidator+    , _schemaAllOf                :: Maybe (NonEmpty Schema)+    , _schemaAnyOf                :: Maybe (NonEmpty Schema)+    , _schemaOneOf                :: Maybe (NonEmpty Schema)+    , _schemaNot                  :: Maybe Schema+    } deriving (Eq, Show)++emptySchema :: Schema+emptySchema = Schema+    { _schemaVersion              = Nothing+    , _schemaId                   = Nothing+    , _schemaRef                  = Nothing+    , _schemaDefinitions          = Nothing+    , _schemaOther                = mempty++    , _schemaMultipleOf           = Nothing+    , _schemaMaximum              = Nothing+    , _schemaExclusiveMaximum     = Nothing+    , _schemaMinimum              = Nothing+    , _schemaExclusiveMinimum     = Nothing++    , _schemaMaxLength            = Nothing+    , _schemaMinLength            = Nothing+    , _schemaPattern              = Nothing++    , _schemaMaxItems             = Nothing+    , _schemaMinItems             = Nothing+    , _schemaUniqueItems          = Nothing+    , _schemaItems                = Nothing+    , _schemaAdditionalItems      = Nothing++    , _schemaMaxProperties        = Nothing+    , _schemaMinProperties        = Nothing+    , _schemaRequired             = Nothing+    , _schemaDependencies         = Nothing+    , _schemaProperties           = Nothing+    , _schemaPatternProperties    = Nothing+    , _schemaAdditionalProperties = Nothing++    , _schemaEnum                 = Nothing+    , _schemaType                 = Nothing+    , _schemaAllOf                = Nothing+    , _schemaAnyOf                = Nothing+    , _schemaOneOf                = Nothing+    , _schemaNot                  = Nothing+    }++instance FromJSON Schema where+    parseJSON = withObject "Schema" $ \o -> do+        a  <- o .:! "$schema"+        b  <- o .:! "id"+        c  <- o .:! "$ref"+        d  <- o .:! "definitions"+        e  <- parseJSON (Object (HM.difference o internalSchemaHashMap))++        f  <- o .:! "multipleOf"+        g  <- o .:! "maximum"+        h  <- o .:! "exclusiveMaximum"+        i  <- o .:! "minimum"+        j  <- o .:! "exclusiveMinimum"++        k  <- o .:! "maxLength"+        l  <- o .:! "minLength"+        m  <- o .:! "pattern"++        n  <- o .:! "maxItems"+        o' <- o .:! "minItems"+        p  <- o .:! "uniqueItems"+        q  <- o .:! "items"+        r  <- o .:! "additionalItems"++        s  <- o .:! "maxProperties"+        t  <- o .:! "minProperties"+        u  <- o .:! "required"+        v  <- o .:! "dependencies"+        w  <- o .:! "properties"+        x  <- o .:! "patternProperties"+        y  <- o .:! "additionalProperties"++        z  <- o .:! "enum"+        a2 <- o .:! "type"+        b2 <- fmap _unNonEmpty' <$> o .:! "allOf"+        c2 <- fmap _unNonEmpty' <$> o .:! "anyOf"+        d2 <- fmap _unNonEmpty' <$> o .:! "oneOf"+        e2 <- o .:! "not"+        pure Schema+            { _schemaVersion              = a+            , _schemaId                   = b+            , _schemaRef                  = c+            , _schemaDefinitions          = d+            , _schemaOther                = e++            , _schemaMultipleOf           = f+            , _schemaMaximum              = g+            , _schemaExclusiveMaximum     = h+            , _schemaMinimum              = i+            , _schemaExclusiveMinimum     = j++            , _schemaMaxLength            = k+            , _schemaMinLength            = l+            , _schemaPattern              = m++            , _schemaMaxItems             = n+            , _schemaMinItems             = o'+            , _schemaUniqueItems          = p+            , _schemaItems                = q+            , _schemaAdditionalItems      = r++            , _schemaMaxProperties        = s+            , _schemaMinProperties        = t+            , _schemaRequired             = u+            , _schemaDependencies         = v+            , _schemaProperties           = w+            , _schemaPatternProperties    = x+            , _schemaAdditionalProperties = y++            , _schemaEnum                 = z+            , _schemaType                 = a2+            , _schemaAllOf                = b2+            , _schemaAnyOf                = c2+            , _schemaOneOf                = d2+            , _schemaNot                  = e2+            }++instance ToJSON Schema where+    -- | The way we resolve JSON Pointers to embedded schemas is by+    -- serializing the containing schema to a value and then resolving the+    -- pointer against it. This means that FromJSON and ToJSON must be+    -- isomorphic.+    --+    -- This influences the design choices in the library. E.g. right now+    -- there are two false values for "exclusiveMaximum" -- Nothing and+    -- Just False. We could have condensed them down by using () instead+    -- of Bool for "exclusiveMaximum". This would have made writing schemas+    -- in haskell easier, but we could no longer round trip through/from+    -- JSON without losing information.+    toJSON s = Object $ HM.union (mapMaybe ($ s) internalSchemaHashMap)+                                 (toJSON <$> _schemaOther s)+      where+        -- 'mapMaybe' is provided by unordered-containers after+        -- unordered-container-2.6.0.0, but until that is a little older+        -- (and has time to get into Stackage etc.) we use our own+        -- implementation.+        mapMaybe :: (v1 -> Maybe v2) -> HashMap k v1 -> HashMap k v2+        mapMaybe f = fmap fromJust . HM.filter isJust . fmap f++-- | Internal. Separate from ToJSON because it's also used+-- by FromJSON to determine what keys aren't official schema+-- keys and therefor should be included in _schemaOther.+internalSchemaHashMap :: HashMap Text (Schema -> Maybe Value)+internalSchemaHashMap = HM.fromList+    [ ("$schema"             , f _schemaVersion)+    , ("id"                  , f _schemaId)+    , ("$ref"                , f _schemaRef)+    , ("definitions"         , f _schemaDefinitions)++    , ("multipleOf"          , f _schemaMultipleOf)+    , ("maximum"             , f _schemaMaximum)+    , ("exclusiveMaximum"    , f _schemaExclusiveMaximum)+    , ("minimum"             , f _schemaMinimum)+    , ("exclusiveMinimum"    , f _schemaExclusiveMinimum)++    , ("maxLength"           , f _schemaMaxLength)+    , ("minLength"           , f _schemaMinLength)+    , ("pattern"             , f _schemaPattern)++    , ("maxItems"            , f _schemaMaxItems)+    , ("minItems"            , f _schemaMinItems)+    , ("uniqueItems"         , f _schemaUniqueItems)+    , ("items"               , f _schemaItems)+    , ("additionalItems"     , f _schemaAdditionalItems)++    , ("maxProperties"       , f _schemaMaxProperties)+    , ("minProperties"       , f _schemaMinProperties)+    , ("required"            , f _schemaRequired)+    , ("dependencies"        , f _schemaDependencies)+    , ("properties"          , f _schemaProperties)+    , ("patternProperties"   , f _schemaPatternProperties)+    , ("additionalProperties", f _schemaAdditionalProperties)++    , ("enum"                , f _schemaEnum)+    , ("type"                , f _schemaType)+    , ("allOf"               , f (fmap NonEmpty' . _schemaAllOf))+    , ("anyOf"               , f (fmap NonEmpty' . _schemaAnyOf))+    , ("oneOf"               , f (fmap NonEmpty' . _schemaOneOf))+    , ("not"                 , f _schemaNot)+    ]+  where+    f :: ToJSON a => (Schema -> Maybe a) -> Schema -> Maybe Value+    f = (fmap.fmap) toJSON++instance Arbitrary Schema where+    arbitrary = sized f+      where+        maybeGen :: Gen a -> Gen (Maybe a)+        maybeGen a = oneof [pure Nothing, Just <$> a]++        maybeRecurse :: Int -> Gen a -> Gen (Maybe a)+        maybeRecurse n a+            | n < 1     = pure Nothing+            | otherwise = maybeGen $ resize (n `div` 10) a++        f :: Int -> Gen Schema+        f n = do+            a  <- maybeGen arbitraryText+            b  <- maybeGen arbitraryText+            c  <- maybeGen arbitraryText+               -- NOTE: The next two fields are empty to generate cleaner+               -- schemas, but note that this means we don't test the+               -- invertability of these fields.+            d  <- pure Nothing -- _schemaDefinitions+            e  <- pure mempty -- _otherPairs++            f' <- maybeGen arbitraryPositiveScientific+            g  <- maybeGen arbitraryScientific+            h  <- arbitrary+            i  <- maybeGen arbitraryScientific+            j  <- arbitrary++            k  <- maybeGen (getPositive <$> arbitrary)+            l  <- maybeGen (getPositive <$> arbitrary)+            m  <- maybeGen arbitraryText++            n' <- maybeGen (getPositive <$> arbitrary)+            o  <- maybeGen (getPositive <$> arbitrary)+            p  <- arbitrary+            q  <- maybeRecurse n arbitrary+            r  <- maybeRecurse n arbitrary++            s  <- maybeGen (getPositive <$> arbitrary)+            t  <- maybeGen (getPositive <$> arbitrary)+            u  <- maybeGen (Set.map T.pack <$> arbitrary)+            v  <- maybeRecurse n arbitraryHashMap+            w  <- maybeRecurse n arbitraryHashMap+            x  <- maybeRecurse n arbitraryHashMap+            y  <- maybeRecurse n arbitrary++            z  <- maybeRecurse n ( fmap _unArbitraryValue . _unNonEmpty'+                               <$> arbitrary)+            a2 <- arbitrary+            b2 <- maybeRecurse n (_unNonEmpty' <$> arbitrary)+            c2 <- maybeRecurse n (_unNonEmpty' <$> arbitrary)+            d2 <- maybeRecurse n (_unNonEmpty' <$> arbitrary)+            e2 <- maybeRecurse n arbitrary+            pure Schema+                { _schemaVersion              = a+                , _schemaId                   = b+                , _schemaRef                  = c+                , _schemaDefinitions          = d+                , _schemaOther                = e++                , _schemaMultipleOf           = f'+                , _schemaMaximum              = g+                , _schemaExclusiveMaximum     = h+                , _schemaMinimum              = i+                , _schemaExclusiveMinimum     = j++                , _schemaMaxLength            = k+                , _schemaMinLength            = l+                , _schemaPattern              = m++                , _schemaMaxItems             = n'+                , _schemaMinItems             = o+                , _schemaUniqueItems          = p+                , _schemaItems                = q+                , _schemaAdditionalItems      = r++                , _schemaMaxProperties        = s+                , _schemaMinProperties        = t+                , _schemaRequired             = u+                , _schemaDependencies         = v+                , _schemaProperties           = w+                , _schemaPatternProperties    = x+                , _schemaAdditionalProperties = y++                , _schemaEnum                 = z+                , _schemaType                 = a2+                , _schemaAllOf                = b2+                , _schemaAnyOf                = c2+                , _schemaOneOf                = d2+                , _schemaNot                  = e2+                }

@@ -0,0 +1,128 @@++module JSONSchema.Draft4.Spec where++import           Import++import           Data.Maybe                     (fromMaybe)+import           Data.Profunctor                (Profunctor(..))++import           JSONSchema.Draft4.Failure+import           JSONSchema.Draft4.Schema       (Schema(..))+import           JSONSchema.Fetch               (ReferencedSchemas(..),+                                                 SchemaWithURI(..))+import qualified JSONSchema.Fetch               as FE+import           JSONSchema.Types               (Spec(..))+import qualified JSONSchema.Types               as JT+import           JSONSchema.Validator.Draft4+import           JSONSchema.Validator.Reference (updateResolutionScope)++embedded :: Schema -> ([Schema], [Schema])+embedded s = JT.embedded (d4Spec (ReferencedSchemas s mempty) mempty Nothing) s++specValidate+    :: ReferencedSchemas Schema+    -> SchemaWithURI Schema+    -> Value+    -> [ValidatorFailure]+specValidate rs =+    continueValidating rs (VisitedSchemas [(Nothing, Nothing)])++continueValidating+    :: ReferencedSchemas Schema+    -> VisitedSchemas+    -> SchemaWithURI Schema+    -> Value+    -> [ValidatorFailure]+continueValidating referenced visited sw =+    JT.validate (d4Spec referenced visited currentScope)+                (_swSchema sw)+  where+    currentScope :: Maybe Text+    currentScope = updateResolutionScope+                       (_swURI sw)+                       (_schemaId (_swSchema sw))++d4Spec+    :: ReferencedSchemas Schema+    -> VisitedSchemas+    -> Maybe Text+    -> Spec Schema ValidatorFailure+d4Spec referenced visited scope = Spec+    [ dimap (fmap MultipleOf . _schemaMultipleOf) FailureMultipleOf multipleOfValidator+    , dimap+        (\s -> Maximum (fromMaybe False (_schemaExclusiveMaximum s)) <$> _schemaMaximum s)+        FailureMaximum+        maximumValidator+    , dimap+        (\s -> Minimum (fromMaybe False (_schemaExclusiveMinimum s)) <$> _schemaMinimum s)+        FailureMinimum+        minimumValidator++    , dimap (fmap MaxLength . _schemaMaxLength) FailureMaxLength maxLengthValidator+    , dimap (fmap MinLength . _schemaMinLength) FailureMinLength minLengthValidator+    , dimap (fmap PatternValidator . _schemaPattern) FailurePattern patternValidator++    , dimap (fmap MaxItems . _schemaMaxItems) FailureMaxItems maxItemsValidator+    , dimap (fmap MinItems . _schemaMinItems) FailureMinItems minItemsValidator+    , dimap (fmap UniqueItems . _schemaUniqueItems) FailureUniqueItems uniqueItemsValidator+    , dimap+        (\s -> ItemsRelated+                   { _irItems      = _schemaItems s+                   , _irAdditional = _schemaAdditionalItems s+                   })+        (\err -> case err of+                     IRInvalidItems e      -> FailureItems e+                     IRInvalidAdditional e -> FailureAdditionalItems e)+        (itemsRelatedValidator descend)+    , lmap (fmap Definitions . _schemaDefinitions) definitionsEmbedded++    , dimap+        (fmap MaxProperties . _schemaMaxProperties)+        FailureMaxProperties+        maxPropertiesValidator+    , dimap+        (fmap MinProperties . _schemaMinProperties)+        FailureMinProperties+        minPropertiesValidator+    , dimap (fmap Required . _schemaRequired) FailureRequired requiredValidator+    , dimap+        (fmap DependenciesValidator . _schemaDependencies)+        FailureDependencies+        (dependenciesValidator descend)+    , dimap+        (\s -> PropertiesRelated+                   { _propProperties = _schemaProperties s+                   , _propPattern    = _schemaPatternProperties s+                   , _propAdditional = _schemaAdditionalProperties s+                   })+        FailurePropertiesRelated+        (propertiesRelatedValidator descend)++    , dimap+        (\s -> Ref <$> _schemaRef s)+        FailureRef+        (refValidator visited scope (FE.getReference referenced) getRef)+    , dimap (fmap EnumValidator . _schemaEnum) FailureEnum enumValidator+    , dimap (fmap TypeContext . _schemaType) FailureType typeValidator+    , dimap (fmap AllOf . _schemaAllOf) FailureAllOf (allOfValidator lateral)+    , dimap (fmap AnyOf . _schemaAnyOf) FailureAnyOf (anyOfValidator lateral)+    , dimap (fmap OneOf . _schemaOneOf) FailureOneOf (oneOfValidator lateral)+    , dimap (fmap NotValidator . _schemaNot) FailureNot (notValidator lateral)+    ]+  where+    getRef+        :: VisitedSchemas+        -> Maybe Text+        -> Schema+        -> Value+        -> [ValidatorFailure]+    getRef newVisited newScope schema =+        continueValidating referenced newVisited (SchemaWithURI schema newScope)++    descend :: Schema -> Value -> [ValidatorFailure]+    descend schema =+        continueValidating referenced mempty (SchemaWithURI schema scope)++    lateral :: Schema -> Value -> [ValidatorFailure]+    lateral schema =+        continueValidating referenced visited (SchemaWithURI schema scope)

@@ -0,0 +1,194 @@++module JSONSchema.Fetch where++import           Import++import           Control.Arrow                  (left)+import           Control.Exception              (IOException, catch)+import           Control.Monad                  (foldM)+import qualified Data.ByteString                as BS+import qualified Data.ByteString.Lazy           as LBS+import qualified Data.HashMap.Strict            as HM+import qualified Data.Text                      as T+import qualified Network.HTTP.Client            as NC++import           JSONSchema.Validator.Reference (resolveReference,+                                                 updateResolutionScope)++--------------------------------------------------+-- * Types+--------------------------------------------------++-- | This is all the fetching functions need to know about a particular+-- JSON Schema draft, e.g. JSON Schema Draft 4.+data FetchInfo schema = FetchInfo+    { _fiEmbedded :: schema -> ([schema], [schema])+    , _fiId       :: schema -> Maybe Text+    , _fiRef      :: schema -> Maybe Text+    }++data ReferencedSchemas schema = ReferencedSchemas+    { _rsStarting  :: !schema+      -- ^ Used to resolve relative references when we don't know what the scope+      -- of the current schema is. This only happens with starting schemas+      -- because if we're using a remote schema we had to know its URI in order+      -- to fetch it.+      --+      -- Tracking the starting schema (instead of just resolving the reference to+      -- the current schema being used for validation) is necessary for cases+      -- where schemas are embedded inside one another. For instance in this+      -- case not distinguishing the starting and "foo" schemas sends the code+      -- into an infinite loop:+      --+      -- {+      --   "additionalProperties": false,+      --   "properties": {+      --     "foo": {+      --       "$ref": "#"+      --     }+      --   }+      -- }+    , _rsSchemaMap :: !(HashMap Text schema)+      -- ^ Map of URIs to schemas.+    } deriving (Eq, Show)++-- | Keys are URIs (without URI fragments).+newtype URISchemaMap schema+    = URISchemaMap { _unURISchemaMap :: HashMap Text schema }+    deriving (Eq, Show)++data SchemaWithURI schema = SchemaWithURI+    { _swSchema :: !schema+    , _swURI    :: !(Maybe Text)+      -- ^ This is the URI identifying the document containing the schema.+      -- It's different than the schema's "id" field, which controls scope+      -- when resolving references contained in the schema.++      -- TODO: Make the no URI fragment requirement unnecessary.+    } deriving (Eq, Show)++getReference :: ReferencedSchemas schema -> Maybe Text -> Maybe schema+getReference referenced Nothing  = Just (_rsStarting referenced)+getReference referenced (Just t) = HM.lookup t (_rsSchemaMap referenced)++--------------------------------------------------+-- * Fetch via HTTP+--------------------------------------------------++data HTTPFailure+    = HTTPParseFailure   Text+    | HTTPRequestFailure NC.HttpException+    deriving Show++-- | Take a schema. Retrieve every document either it or its subschemas+-- include via the "$ref" keyword.+referencesViaHTTP'+    :: forall schema. FromJSON schema+    => FetchInfo schema+    -> SchemaWithURI schema+    -> IO (Either HTTPFailure (URISchemaMap schema))+referencesViaHTTP' info sw = do+    manager <- NC.newManager NC.defaultManagerSettings+    let f = referencesMethodAgnostic (getURL manager) info sw+    catch (left HTTPParseFailure <$> f) handler+  where+    getURL :: NC.Manager -> Text -> IO BS.ByteString+    getURL man url = do+        request <- NC.parseUrlThrow (T.unpack url)+        LBS.toStrict . NC.responseBody <$> NC.httpLbs request man++    handler+        :: NC.HttpException+        -> IO (Either HTTPFailure (URISchemaMap schema))+    handler = pure . Left . HTTPRequestFailure++--------------------------------------------------+-- * Fetch via Filesystem+--------------------------------------------------++data FilesystemFailure+    = FSParseFailure Text+    | FSReadFailure  IOException+    deriving (Show, Eq)++referencesViaFilesystem'+    :: forall schema. FromJSON schema+    => FetchInfo schema+    -> SchemaWithURI schema+    -> IO (Either FilesystemFailure (URISchemaMap schema))+referencesViaFilesystem' info sw = catch (left FSParseFailure <$> f) handler+  where+    f :: IO (Either Text (URISchemaMap schema))+    f = referencesMethodAgnostic (BS.readFile . T.unpack) info sw++    handler+        :: IOException+        -> IO (Either FilesystemFailure (URISchemaMap schema))+    handler = pure . Left . FSReadFailure++--------------------------------------------------+-- * Method Agnostic Fetching Tools+--------------------------------------------------++-- | A version of 'fetchReferencedSchema's where the function to fetch+-- schemas is provided by the user. This allows restrictions to be added,+-- e.g. rejecting non-local URIs.+referencesMethodAgnostic+    :: forall schema. FromJSON schema+    => (Text -> IO BS.ByteString)+    -> FetchInfo schema+    -> SchemaWithURI schema+    -> IO (Either Text (URISchemaMap schema))+referencesMethodAgnostic fetchRef info =+    getRecursiveReferences fetchRef info (URISchemaMap mempty)++getRecursiveReferences+    :: forall schema. FromJSON schema+    => (Text -> IO BS.ByteString)+    -> FetchInfo schema+    -> URISchemaMap schema+    -> SchemaWithURI schema+    -> IO (Either Text (URISchemaMap schema))+getRecursiveReferences fetchRef info referenced sw =+    foldM f (Right referenced) (includeSubschemas info sw)+  where+    f :: Either Text (URISchemaMap schema)+      -> SchemaWithURI schema+      -> IO (Either Text (URISchemaMap schema))+    f (Left e) _                            = pure (Left e)+    f (Right (URISchemaMap usm)) (SchemaWithURI schema mUri) =+        case newRef of+            Nothing  -> pure (Right (URISchemaMap usm))+            Just uri -> do+                bts <- fetchRef uri+                case eitherDecodeStrict bts of+                    Left e     -> pure . Left . T.pack $ e+                    Right schm -> getRecursiveReferences+                                      fetchRef+                                      info+                                      (URISchemaMap (HM.insert uri schm usm))+                                      (SchemaWithURI schm (Just uri))+      where+        newRef :: Maybe Text+        newRef+          | Just (Just uri,_) <- resolveReference mUri <$> _fiRef info schema+              = case HM.lookup uri usm of+                    Nothing -> Just uri+                    Just _  -> Nothing+          | otherwise = Nothing++-- | Return the schema passed in as an argument, as well as every+-- subschema contained within it.+includeSubschemas+    :: forall schema.+       FetchInfo schema+    -> SchemaWithURI schema+    -> [SchemaWithURI schema]+includeSubschemas info (SchemaWithURI schema mUri) =+    SchemaWithURI schema mUri+    : (includeSubschemas info =<< subSchemas)+  where+    subSchemas :: [SchemaWithURI schema]+    subSchemas =+      (\a -> SchemaWithURI a (updateResolutionScope mUri (_fiId info schema)))+         <$> uncurry (<>) (_fiEmbedded info schema)

@@ -0,0 +1,36 @@++module JSONSchema.Types where++import           Import++import           JSONSchema.Validator.Types (Validator(..))++newtype Spec schema err+    = Spec { _unSpec :: [Validator schema schema err] }++-- | Return a schema's immediate subschemas.+--+-- The first list is subschemas validating the same level of the document,+-- the second list is subschemas validating lower levels (see+-- 'JSONSchema.Validator.Types.Fail' for a full explanation).+embedded :: Spec schema a -> schema -> ([schema], [schema])+embedded spec schema =+    let embeds = (\val -> _embedded val schema) <$> _unSpec spec+    in foldl' (\(a,b) (x,y) -> (x <> a, y <> b)) (mempty, mempty) embeds++validate+    :: Spec schema err+    -> schema+    -> Value+    -> [err]+validate spec schema v =+    (\val -> _validate val schema v) =<< _unSpec spec++-- | A basic schema type that doesn't impose much structure.+--+-- 'JSONSchema.Draft4' doesn't use this, but instead uses the record based+-- one defined in 'JSONSchema.Draft4.Schema' to make it easier to write+-- draft 4 schemas in Haskell.+newtype Schema+    = Schema { _unSchema :: HashMap Text Value }+    deriving (Eq, Show, FromJSON, ToJSON)

@@ -0,0 +1,242 @@+-- | Turn the validation functions into actual 'Validator's.++module JSONSchema.Validator.Draft4+    ( module JSONSchema.Validator.Draft4+    , module Export+    ) where++import           Import++import qualified Data.HashMap.Strict                as HM+import qualified Data.List.NonEmpty                 as NE+import           Data.Maybe                         (catMaybes, maybe, maybeToList)+import           Data.Text                          (Text)++import           JSONSchema.Validator.Draft4.Any    as Export+import           JSONSchema.Validator.Draft4.Array  as Export+import           JSONSchema.Validator.Draft4.Number as Export+import           JSONSchema.Validator.Draft4.Object as Export+import           JSONSchema.Validator.Draft4.String as Export+import           JSONSchema.Validator.Types         (Validator(..))+import           JSONSchema.Validator.Utils         (fromJSONEither)++-- | For internal use.+--+-- Take a validation function, a possibly existing validator, and some data.+-- If the validator is exists and can validate the type of data we have,+-- attempt to do so and return any failures.+run :: FromJSON b => (a -> b -> Maybe c) -> Maybe a -> Value -> [c]+run _ Nothing _  = mempty+run f (Just a) b =+    case fromJSONEither b of+        Left _  -> mempty+        Right c -> maybeToList (f a c)++-- | For internal use.+noEmbedded :: a -> ([b], [b])+noEmbedded = const (mempty, mempty)++--------------------------------------------------+-- * Numbers+--------------------------------------------------++multipleOfValidator :: Validator a (Maybe MultipleOf) MultipleOfInvalid+multipleOfValidator = Validator noEmbedded (run multipleOfVal)++maximumValidator :: Validator a (Maybe Maximum) MaximumInvalid+maximumValidator = Validator noEmbedded (run maximumVal)++minimumValidator :: Validator a (Maybe Minimum) MinimumInvalid+minimumValidator = Validator noEmbedded (run minimumVal)++--------------------------------------------------+-- * Strings+--------------------------------------------------++maxLengthValidator :: Validator a (Maybe MaxLength) MaxLengthInvalid+maxLengthValidator = Validator noEmbedded (run maxLengthVal)++minLengthValidator :: Validator a (Maybe MinLength) MinLengthInvalid+minLengthValidator = Validator noEmbedded (run minLengthVal)++patternValidator :: Validator a (Maybe PatternValidator) PatternInvalid+patternValidator = Validator noEmbedded (run patternVal)++--------------------------------------------------+-- * Arrays+--------------------------------------------------++maxItemsValidator :: Validator a (Maybe MaxItems) MaxItemsInvalid+maxItemsValidator = Validator noEmbedded (run maxItemsVal)++minItemsValidator :: Validator a (Maybe MinItems) MinItemsInvalid+minItemsValidator = Validator noEmbedded (run minItemsVal)++uniqueItemsValidator :: Validator a (Maybe UniqueItems) UniqueItemsInvalid+uniqueItemsValidator = Validator noEmbedded (run uniqueItemsVal)++itemsRelatedValidator+    :: (schema -> Value -> [err])+    -> Validator schema (ItemsRelated schema) (ItemsRelatedInvalid err)+itemsRelatedValidator f =+    Validator+        (\a -> ( mempty+               ,  case _irItems a of+                      Just (ItemsObject b) -> pure b+                      Just (ItemsArray cs) -> cs+                      Nothing              -> mempty+               <> case _irAdditional a of+                      Just (AdditionalObject b) -> pure b+                      _                         -> mempty+               ))+        (\a b -> case fromJSONEither b of+                     Left _  -> mempty+                     Right c -> itemsRelatedVal f a c)++--------------------------------------------------+-- * Objects+--------------------------------------------------++maxPropertiesValidator+    :: Validator+           a+           (Maybe MaxProperties)+           MaxPropertiesInvalid+maxPropertiesValidator = Validator noEmbedded (run maxPropertiesVal)++minPropertiesValidator+    :: Validator+           a+           (Maybe MinProperties)+           MinPropertiesInvalid+minPropertiesValidator = Validator noEmbedded (run minPropertiesVal)++requiredValidator :: Validator a (Maybe Required) ()+requiredValidator = Validator noEmbedded (run requiredVal)++dependenciesValidator+    :: (schema -> Value -> [err])+    -> Validator+           schema+           (Maybe (DependenciesValidator schema))+           (DependenciesInvalid err)+dependenciesValidator f =+    Validator+        (maybe mempty ( (\a -> (mempty, a))+                      . catMaybes . fmap checkDependency+                      . HM.elems . _unDependenciesValidator+                      ))+        (run (dependenciesVal f))+  where+    checkDependency :: Dependency schema -> Maybe schema+    checkDependency (PropertyDependency _) = Nothing+    checkDependency (SchemaDependency s)   = Just s++propertiesRelatedValidator+    :: (schema -> Value -> [err])+    -> Validator+           schema+           (PropertiesRelated schema)+           (PropertiesRelatedInvalid err)+propertiesRelatedValidator f =+    Validator+        (\a -> ( mempty+               ,  HM.elems (fromMaybe mempty (_propProperties a))+               <> HM.elems (fromMaybe mempty (_propPattern a))+               <> case _propAdditional a of+                      Just (AdditionalPropertiesObject b) -> [b]+                      _ -> mempty+               ))+        (\a b -> case fromJSONEither b of+                     Left _  -> mempty+                     Right c -> maybeToList (propertiesRelatedVal f a c))++newtype Definitions schema+    = Definitions { _unDefinitions :: HashMap Text schema }+    deriving (Eq, Show)++instance FromJSON schema => FromJSON (Definitions schema) where+    parseJSON = withObject "Definitions" $ \o ->+        Definitions <$> o .: "definitions"++-- TODO: Add tests to the language agnostic test suite to+-- make sure these schemas are embedded correctly+-- (and do so for @"additionalItems"@ as well).+definitionsEmbedded+    :: Validator+           schema+           (Maybe (Definitions schema))+           err+definitionsEmbedded =+    Validator+        (\a -> case a of+                 Just (Definitions b) -> (mempty, HM.elems b)+                 Nothing              -> (mempty, mempty))+        (const (const mempty))++--------------------------------------------------+-- * Any+--------------------------------------------------++refValidator+    :: (FromJSON schema, ToJSON schema)+    => VisitedSchemas+    -> Maybe Text+    -> (Maybe Text -> Maybe schema)+    -> (VisitedSchemas -> Maybe Text -> schema -> Value -> [err])+    -> Validator a (Maybe Ref) (RefInvalid err)+refValidator visited scope getRef f =+    Validator+        noEmbedded+        (run (refVal visited scope getRef f))++enumValidator :: Validator a (Maybe EnumValidator) EnumInvalid+enumValidator = Validator noEmbedded (run enumVal)++typeValidator :: Validator a (Maybe TypeContext) TypeValidatorInvalid+typeValidator = Validator noEmbedded (run typeVal)++allOfValidator+    :: (schema -> Value -> [err])+    -> Validator schema (Maybe (AllOf schema)) (AllOfInvalid err)+allOfValidator f =+    Validator+        (\a -> case a of+                   Just (AllOf b) -> (NE.toList b, mempty)+                   Nothing        -> (mempty, mempty))+        (run (allOfVal f))++anyOfValidator+    :: (schema -> Value -> [err])+    -> Validator schema (Maybe (AnyOf schema)) (AnyOfInvalid err)+anyOfValidator f =+    Validator+        (\a -> case a of+                 Just (AnyOf b) -> (NE.toList b, mempty)+                 Nothing        -> (mempty, mempty))+        (run (anyOfVal f))++oneOfValidator+    :: ToJSON schema+    => (schema -> Value -> [err])+    -> Validator schema (Maybe (OneOf schema)) (OneOfInvalid err)+oneOfValidator f =+    Validator+        (\a -> case a of+                   Just (OneOf b) -> (NE.toList b, mempty)+                   Nothing        -> (mempty, mempty))+        (run (oneOfVal f))++notValidator+    :: ToJSON schema+    => (schema -> Value -> [err])+    -> Validator+           schema+           (Maybe (NotValidator schema))+           NotValidatorInvalid+notValidator f =+    Validator+        (\a -> case a of+                   Just (NotValidator b) -> (pure b, mempty)+                   Nothing               -> (mempty, mempty))+        (run (notVal f))

@@ -0,0 +1,351 @@++module JSONSchema.Validator.Draft4.Any where++import           Import++import           Data.List.NonEmpty             (NonEmpty((:|)))+import qualified Data.List.NonEmpty             as NE+import qualified Data.Scientific                as SCI+import           Data.Semigroup                 (Semigroup) -- for older GHCs+import           Data.Set                       (Set)+import qualified Data.Set                       as S+import qualified JSONPointer                    as JP++import qualified JSONSchema.Validator.Utils     as UT+import           JSONSchema.Validator.Reference (URIBaseAndFragment,+                                                 resolveFragment,+                                                 resolveReference)++--------------------------------------------------+-- * $ref+--------------------------------------------------++newtype Ref+    = Ref { _unRef :: Text }+    deriving (Eq, Show)++instance FromJSON Ref where+    parseJSON = withObject "Ref" $ \o ->+        Ref <$> o .: "$ref"++data RefInvalid err+    = RefResolution        Text+      -- ^ Indicates a reference that failed to resolve.+      --+      -- NOTE: The language agnostic test suite doesn't specify if this should+      -- cause a validation error or should allow data to pass. We choose to+      -- return a validation error.+      --+      -- Also note that ideally we would enforce in the type system that any+      -- failing references be dealt with before valididation. Then this could+      -- be removed entirely.+    | RefPointerResolution Text+    | RefLoop              Text VisitedSchemas URIBaseAndFragment+    | RefInvalid           Text Value (NonEmpty err)+      -- ^ 'Text' is the URI and 'Value' is the linked schema.+    deriving (Eq, Show)++newtype VisitedSchemas+    = VisitedSchemas { _unVisited :: [URIBaseAndFragment] }+    deriving (Eq, Show, Semigroup, Monoid)++refVal+    :: forall err schema. (FromJSON schema, ToJSON schema)+    => VisitedSchemas+    -> Maybe Text+    -> (Maybe Text -> Maybe schema)+    -> (VisitedSchemas -> Maybe Text -> schema -> Value -> [err])+    -> Ref+    -> Value+    -> Maybe (RefInvalid err)+refVal visited scope getRef f (Ref reference) x+    | (mURI, mFragment) `elem` _unVisited visited =+        Just (RefLoop reference visited (mURI, mFragment))+    | otherwise =+        case getRef mURI of+            Nothing     -> Just (RefResolution reference)+            Just schema ->+                case resolveFragment mFragment schema of+                    Nothing -> Just (RefPointerResolution reference)+                    Just s  ->+                        let newVisited = (VisitedSchemas [(mURI, mFragment)]+                                      <> visited)+                            errs = f newVisited mURI s x+                        in RefInvalid reference (toJSON schema)+                            <$> NE.nonEmpty errs+  where+    (mURI, mFragment) = resolveReference scope reference++--------------------------------------------------+-- * enum+--------------------------------------------------++-- | From the spec:+-- <http://json-schema.org/latest/json-schema-validation.html#anchor76>+--+--  > The value of this keyword MUST be an array.+--  > This array MUST have at least one element.+--  > Elements in the array MUST be unique.+--+-- NOTE: We don't enforce the uniqueness constraint in the haskell code,+-- but we do in the 'FromJSON' instance.+newtype EnumValidator+    = EnumValidator { _unEnumValidator :: NonEmpty Value }+    -- Given a choice, we'd prefer to enforce uniqueness through the type+    -- system over having at least one element. To use a 'Set' though we'd+    -- have to use 'OrdValue' here (there's no 'Ord' instance for plain Values)+    -- and we'd rather not make users mess with 'OrdValue'.+    deriving (Eq, Show)++instance FromJSON EnumValidator where+    parseJSON = withObject "EnumValidator" $ \o ->+        EnumValidator <$> o .: "enum"++instance Arbitrary EnumValidator where+    arbitrary = do+        xs <- (fmap.fmap) UT._unArbitraryValue arbitrary+        case NE.nonEmpty (toUnique xs) of+            Nothing -> EnumValidator . pure . UT._unArbitraryValue <$> arbitrary+            Just ne -> pure (EnumValidator ne)+      where+        toUnique :: [Value] -> [Value]+        toUnique = fmap UT._unOrdValue . S.toList . S.fromList . fmap UT.OrdValue++data EnumInvalid+    = EnumInvalid EnumValidator Value+    deriving (Eq, Show)++enumVal :: EnumValidator -> Value -> Maybe EnumInvalid+enumVal a@(EnumValidator vs) x+    | not (UT.allUniqueValues' vs) = Nothing+    | x `elem` vs                  = Nothing+    | otherwise                    = Just $ EnumInvalid a x++--------------------------------------------------+-- * type+--------------------------------------------------++-- | This is separate from 'TypeValidator' so that 'TypeValidator' can+-- be used to write 'JSONSchema.Draft4.Schema.Schema' without+-- messing up the 'FromJSON' instance of that data type.+newtype TypeContext+    = TypeContext { _unTypeContext :: TypeValidator }+    deriving (Eq, Show)++instance FromJSON TypeContext where+    parseJSON = withObject "TypeContext" $ \o ->+        TypeContext <$> o .: "type"++data TypeValidator+    = TypeValidatorString Text+    | TypeValidatorArray  (Set Text)+    deriving (Eq, Show)++instance FromJSON TypeValidator where+    parseJSON v = fmap TypeValidatorString (parseJSON v)+              <|> fmap TypeValidatorArray (parseJSON v)++instance ToJSON TypeValidator where+    toJSON (TypeValidatorString t) = toJSON t+    toJSON (TypeValidatorArray ts) = toJSON ts++instance Arbitrary TypeValidator where+    arbitrary = oneof [ TypeValidatorString <$> UT.arbitraryText+                      , TypeValidatorArray <$> UT.arbitrarySetOfText+                      ]++data TypeValidatorInvalid+    = TypeValidatorInvalid TypeValidator Value+    deriving (Eq, Show)++typeVal :: TypeContext -> Value -> Maybe TypeValidatorInvalid+typeVal (TypeContext tv) x+    | S.null matches = Just (TypeValidatorInvalid tv x)+    | otherwise      = Nothing+  where+    -- There can be more than one match because a 'Value' can be both a+    -- @"number"@ and an @"integer"@.+    matches :: Set Text+    matches = S.intersection okTypes (setFromTypeValidator tv)++    okTypes :: Set Text+    okTypes =+        case x of+            Null       -> S.singleton "null"+            (Array _)  -> S.singleton "array"+            (Bool _)   -> S.singleton "boolean"+            (Object _) -> S.singleton "object"+            (String _) -> S.singleton "string"+            (Number y) ->+                if SCI.isInteger y+                    then S.fromList ["number", "integer"]+                    else S.singleton "number"++-- | Internal.+setFromTypeValidator :: TypeValidator -> Set Text+setFromTypeValidator (TypeValidatorString t) = S.singleton t+setFromTypeValidator (TypeValidatorArray ts) = ts++--------------------------------------------------+-- * allOf+--------------------------------------------------++newtype AllOf schema+    = AllOf { _unAllOf :: NonEmpty schema }+    deriving (Eq, Show)++instance FromJSON schema => FromJSON (AllOf schema) where+    parseJSON = withObject "AllOf" $ \o ->+        AllOf <$> o .: "allOf"++newtype AllOfInvalid err+    = AllOfInvalid (NonEmpty (JP.Index, NonEmpty err))+    deriving (Eq, Show)++allOfVal+    :: forall err schema.+       (schema -> Value -> [err])+    -> AllOf schema+    -> Value+    -> Maybe (AllOfInvalid err)+allOfVal f (AllOf subSchemas) x = AllOfInvalid <$> NE.nonEmpty failures+  where+    perhapsFailures :: [(JP.Index, [err])]+    perhapsFailures = zip (JP.Index <$> [0..])+                          (flip f x <$> NE.toList subSchemas)++    failures :: [(JP.Index, NonEmpty err)]+    failures = mapMaybe (traverse NE.nonEmpty) perhapsFailures++--------------------------------------------------+-- * anyOf+--------------------------------------------------++newtype AnyOf schema+    = AnyOf { _unAnyOf :: NonEmpty schema }+    deriving (Eq, Show)++instance FromJSON schema => FromJSON (AnyOf schema) where+    parseJSON = withObject "AnyOf" $ \o ->+        AnyOf <$> o .: "anyOf"++newtype AnyOfInvalid err+    = AnyOfInvalid (NonEmpty (JP.Index, NonEmpty err))+    deriving (Eq, Show)++anyOfVal+    :: forall err schema.+       (schema -> Value -> [err])+    -> AnyOf schema+    -> Value+    -> Maybe (AnyOfInvalid err)+anyOfVal f (AnyOf subSchemas) x+    -- Replace with @null@ once we drop GHC 7.8:+    | any (((==) 0 . length) . snd) perhapsFailures = Nothing+    | otherwise = AnyOfInvalid <$> NE.nonEmpty failures+  where+    perhapsFailures :: [(JP.Index, [err])]+    perhapsFailures = zip (JP.Index <$> [0..])+                          (flip f x <$> NE.toList subSchemas)++    failures :: [(JP.Index, NonEmpty err)]+    failures = mapMaybe (traverse NE.nonEmpty) perhapsFailures++--------------------------------------------------+-- * oneOf+--------------------------------------------------++newtype OneOf schema+    = OneOf { _unOneOf :: NonEmpty schema }+    deriving (Eq, Show)++instance FromJSON schema => FromJSON (OneOf schema) where+    parseJSON = withObject "OneOf" $ \o ->+        OneOf <$> o .: "oneOf"++data OneOfInvalid err+    = TooManySuccesses (NonEmpty (JP.Index, Value)) Value+      -- ^ The NonEmpty lists contains tuples whose contents+      -- are the index of a schema that validated the data+      -- and the contents of that schema.+    | NoSuccesses      (NonEmpty (JP.Index, NonEmpty err)) Value+      -- ^ The NonEmpty lists contains tuples whose contents+      -- are the index of a schema that failed to validate the data+      -- and the failures it produced.+    deriving (Eq, Show)++oneOfVal+    :: forall err schema. ToJSON schema+    => (schema -> Value -> [err])+    -> OneOf schema+    -> Value+    -> Maybe (OneOfInvalid err)+oneOfVal f (OneOf (firstSubSchema :| otherSubSchemas)) x =+    -- Producing the NonEmpty lists needed by the error constructors+    -- is a little tricky. If we had a partition function like this+    -- it might help:+    -- @+    -- (a -> Either b c) -> NonEmpty a -> Either (NonEmpty b, [c])+    --                                           ([b], NonEmpty c)+    -- @+    case (firstSuccess, otherSuccesses) of+        (Right _, Nothing)        -> Nothing+        (Right a, Just successes) -> Just (TooManySuccesses+                                              (a NE.<| successes) x)+        (Left e, Nothing)        -> Just (NoSuccesses (e :| otherFailures) x)+        (Left _, Just (_ :| [])) -> Nothing+        (Left _, Just successes) -> Just (TooManySuccesses successes x)+  where+    firstSuccess :: Either (JP.Index, NonEmpty err) (JP.Index, Value)+    firstSuccess =+        case NE.nonEmpty (f firstSubSchema x) of+            Nothing   -> Right (JP.Index 0, toJSON firstSubSchema)+            Just errs -> Left (JP.Index 0, errs)++    otherPerhapsFailures :: [(JP.Index, Value, [err])]+    otherPerhapsFailures =+        zipWith+            (\index schema -> (index, toJSON schema, f schema x))+            (JP.Index <$> [0..])+            otherSubSchemas++    otherSuccesses :: Maybe (NonEmpty (JP.Index, Value))+    otherSuccesses = NE.nonEmpty+                   $ mapMaybe (\(index,val,errs) ->+                                  case errs of+                                      [] -> Just (index,val)+                                      _  -> Nothing+                              ) otherPerhapsFailures++    otherFailures :: [(JP.Index, NonEmpty err)]+    otherFailures = mapMaybe (traverse NE.nonEmpty . mid) otherPerhapsFailures++    mid :: (a,b,c) -> (a,c)+    mid (a,_,c) = (a,c)++--------------------------------------------------+-- * not+--------------------------------------------------++newtype NotValidator schema+    = NotValidator { _unNotValidator :: schema }+    deriving (Eq, Show)++instance FromJSON schema => FromJSON (NotValidator schema) where+    parseJSON = withObject "NotValidator" $ \o ->+        NotValidator <$> o .: "not"++data NotValidatorInvalid+    = NotValidatorInvalid Value Value+    deriving (Eq, Show)++notVal+    :: ToJSON schema =>+       (schema -> Value -> [err])+    -> NotValidator schema+    -> Value+    -> Maybe NotValidatorInvalid+notVal f (NotValidator schema) x =+    case f schema x of+        [] -> Just (NotValidatorInvalid (toJSON schema) x)+        _  -> Nothing

@@ -0,0 +1,224 @@++module JSONSchema.Validator.Draft4.Array where++import           Import++import qualified Data.List.NonEmpty         as NE+import qualified Data.Vector                as V+import qualified JSONPointer                as JP++import           JSONSchema.Validator.Utils (allUniqueValues)++--------------------------------------------------+-- * maxItems+--------------------------------------------------++newtype MaxItems+    = MaxItems { _unMaxItems :: Int }+    deriving (Eq, Show)++instance FromJSON MaxItems where+    parseJSON = withObject "MaxItems" $ \o ->+        MaxItems <$> o .: "maxItems"++data MaxItemsInvalid+    = MaxItemsInvalid MaxItems (Vector Value)+    deriving (Eq, Show)++-- | The spec requires @"maxItems"@ to be non-negative.+maxItemsVal :: MaxItems -> Vector Value -> Maybe MaxItemsInvalid+maxItemsVal a@(MaxItems n) xs+    | n < 0           = Nothing+    | V.length xs > n = Just (MaxItemsInvalid a xs)+    | otherwise       = Nothing++--------------------------------------------------+-- * minItems+--------------------------------------------------++newtype MinItems+    = MinItems { _unMinItems :: Int }+    deriving (Eq, Show)++instance FromJSON MinItems where+    parseJSON = withObject "MinItems" $ \o ->+        MinItems <$> o .: "minItems"++data MinItemsInvalid+    = MinItemsInvalid MinItems (Vector Value)+    deriving (Eq, Show)++-- | The spec requires @"minItems"@ to be non-negative.+minItemsVal :: MinItems -> Vector Value -> Maybe MinItemsInvalid+minItemsVal a@(MinItems n) xs+    | n < 0           = Nothing+    | V.length xs < n = Just (MinItemsInvalid a xs)+    | otherwise       = Nothing++--------------------------------------------------+-- * uniqueItems+--------------------------------------------------++newtype UniqueItems+    = UniqueItems { _unUniqueItems :: Bool }+    deriving (Eq, Show)++instance FromJSON UniqueItems where+    parseJSON = withObject "UniqueItems" $ \o ->+        UniqueItems <$> o .: "uniqueItems"++data UniqueItemsInvalid+    = UniqueItemsInvalid (Vector Value)+    deriving (Eq, Show)++uniqueItemsVal :: UniqueItems -> Vector Value -> Maybe UniqueItemsInvalid+uniqueItemsVal (UniqueItems True) xs+   | allUniqueValues xs = Nothing+   | otherwise          = Just (UniqueItemsInvalid xs)+uniqueItemsVal (UniqueItems False) _ = Nothing++--------------------------------------------------+-- * items+--------------------------------------------------++data ItemsRelated schema = ItemsRelated+    { _irItems      :: Maybe (Items schema)+    , _irAdditional :: Maybe (AdditionalItems schema)+    } deriving (Eq, Show)++instance FromJSON schema => FromJSON (ItemsRelated schema) where+    parseJSON = withObject "ItemsRelated" $ \o -> ItemsRelated+        <$> o .:! "items"+        <*> o .:! "additionalItems"++emptyItems :: ItemsRelated schema+emptyItems = ItemsRelated+    { _irItems      = Nothing+    , _irAdditional = Nothing+    }++data Items schema+    = ItemsObject schema+    | ItemsArray [schema]+    deriving (Eq, Show)++instance FromJSON schema => FromJSON (Items schema) where+    parseJSON v = fmap ItemsObject (parseJSON v)+              <|> fmap ItemsArray (parseJSON v)++instance ToJSON schema => ToJSON (Items schema) where+    toJSON (ItemsObject hm)     = toJSON hm+    toJSON (ItemsArray schemas) = toJSON schemas++instance Arbitrary schema => Arbitrary (Items schema) where+    arbitrary = oneof [ ItemsObject <$> arbitrary+                      , ItemsArray <$> arbitrary+                      ]++data ItemsRelatedInvalid err+    = IRInvalidItems      (ItemsInvalid err)+    | IRInvalidAdditional (AdditionalItemsInvalid err)+    deriving (Eq, Show)++data ItemsInvalid err+    = ItemsObjectInvalid (NonEmpty (JP.Index, NonEmpty err))+    | ItemsArrayInvalid  (NonEmpty (JP.Index, NonEmpty err))+    deriving (Eq, Show)++-- | @"additionalItems"@ only matters if @"items"@ exists+-- and is a JSON Array.+itemsRelatedVal+    :: forall err schema.+       (schema -> Value -> [err])+    -> ItemsRelated schema+    -> Vector Value+    -> [ItemsRelatedInvalid err] -- NOTE: 'Data.These' would help here.+itemsRelatedVal f a xs =+    let (itemsFailure, remaining) = case _irItems a of+                                        Nothing -> (Nothing, mempty)+                                        Just b  -> itemsVal f b xs+        additionalFailure = (\b -> additionalItemsVal f b remaining)+                        =<< _irAdditional a+    in catMaybes [ IRInvalidItems <$> itemsFailure+                 , IRInvalidAdditional <$> additionalFailure+                 ]++-- | Internal.+--+-- This is because 'itemsRelated' handles @"items"@ validation.+itemsVal+    :: forall err schema.+       (schema -> Value -> [err])+    -> Items schema+    -> Vector Value+    -> (Maybe (ItemsInvalid err), [(JP.Index, Value)])+       -- ^ The second item in the tuple is the elements of the original+       -- JSON Array still remaining to be checked by @"additionalItems"@.+itemsVal f a xs =+    case a of+        ItemsObject subSchema ->+            case NE.nonEmpty (mapMaybe (validateElem subSchema) indexed) of+                Nothing   -> (Nothing, mempty)+                Just errs -> (Just (ItemsObjectInvalid errs), mempty)+        ItemsArray subSchemas ->+            let remaining = drop (length subSchemas) indexed+                res = catMaybes (zipWith validateElem subSchemas indexed)+            in case NE.nonEmpty res of+                Nothing   -> (Nothing, remaining)+                Just errs -> (Just (ItemsArrayInvalid errs), remaining)+  where+    indexed :: [(JP.Index, Value)]+    indexed = zip (JP.Index <$> [0..]) (V.toList xs)++    validateElem+        :: schema+        -> (JP.Index, Value)+        -> Maybe (JP.Index, NonEmpty err)+    validateElem schema (index,x) = (index,) <$> NE.nonEmpty (f schema x)++--------------------------------------------------+-- * additionalItems+--------------------------------------------------++data AdditionalItems schema+    = AdditionalBool   Bool+    | AdditionalObject schema+    deriving (Eq, Show)++instance FromJSON schema => FromJSON (AdditionalItems schema) where+    parseJSON v = fmap AdditionalBool (parseJSON v)+              <|> fmap AdditionalObject (parseJSON v)++instance ToJSON schema => ToJSON (AdditionalItems schema) where+    toJSON (AdditionalBool b)    = toJSON b+    toJSON (AdditionalObject hm) = toJSON hm++instance Arbitrary schema => Arbitrary (AdditionalItems schema) where+    arbitrary = oneof [ AdditionalBool <$> arbitrary+                      , AdditionalObject <$> arbitrary+                      ]++data AdditionalItemsInvalid err+    = AdditionalItemsBoolInvalid   (NonEmpty (JP.Index, Value))+    | AdditionalItemsObjectInvalid (NonEmpty (JP.Index, NonEmpty err))+    deriving (Eq, Show)++-- | Internal.+--+-- This is because 'itemsRelated' handles @"additionalItems"@ validation.+additionalItemsVal+    :: forall err schema.+       (schema -> Value -> [err])+    -> AdditionalItems schema+    -> [(JP.Index, Value)]+       -- ^ The elements remaining to validate after the ones covered by+       -- @"items"@ have been removed.+    -> Maybe (AdditionalItemsInvalid err)+additionalItemsVal _ (AdditionalBool True) _ = Nothing+additionalItemsVal _ (AdditionalBool False) xs =+    AdditionalItemsBoolInvalid <$> NE.nonEmpty xs+additionalItemsVal f (AdditionalObject subSchema) xs =+    let res = mapMaybe+                  (\(index,x) -> (index,) <$> NE.nonEmpty (f subSchema x))+                  xs+    in AdditionalItemsObjectInvalid <$> NE.nonEmpty res

@@ -0,0 +1,84 @@++module JSONSchema.Validator.Draft4.Number where++import           Import++import           Data.Fixed      (mod')+import           Data.Scientific (Scientific)++--------------------------------------------------+-- * multipleOf+--------------------------------------------------++newtype MultipleOf+    = MultipleOf { _unMultipleOf :: Scientific }+    deriving (Eq, Show)++instance FromJSON MultipleOf where+    parseJSON = withObject "MultipleOf" $ \o ->+        MultipleOf <$> o .: "multipleOf"++data MultipleOfInvalid+    = MultipleOfInvalid MultipleOf Scientific+    deriving (Eq, Show)++-- | The spec requires @"multipleOf"@ to be positive.+multipleOfVal :: MultipleOf -> Scientific -> Maybe MultipleOfInvalid+multipleOfVal a@(MultipleOf n) x+    | n <= 0          = Nothing+    | x `mod'` n /= 0 = Just (MultipleOfInvalid a x)+    | otherwise       = Nothing++--------------------------------------------------+-- * maximum+--------------------------------------------------++data Maximum = Maximum+    { _maximumExclusive :: Bool+    , _maximumValue     :: Scientific+    } deriving (Eq, Show)++instance FromJSON Maximum where+    parseJSON = withObject "Maximum" $ \o -> Maximum+        <$> o .:! "exclusiveMaximum" .!= False+        <*> o .: "maximum"++data MaximumInvalid+    = MaximumInvalid Maximum Scientific+    deriving (Eq, Show)++maximumVal+    :: Maximum+    -> Scientific+    -> Maybe MaximumInvalid+maximumVal a@(Maximum exclusive n) x+    | exclusive && x >= n = Just (MaximumInvalid a x)+    | x > n               = Just (MaximumInvalid a x)+    | otherwise           = Nothing++--------------------------------------------------+-- * minimum+--------------------------------------------------++data Minimum = Minimum+    { _minimumExclusive :: Bool+    , _minimumValue     :: Scientific+    } deriving (Eq, Show)++instance FromJSON Minimum where+    parseJSON = withObject "Minimum" $ \o -> Minimum+        <$> o .:! "exclusiveMinimum" .!= False+        <*> o .: "minimum"++data MinimumInvalid+    = MinimumInvalid Minimum Scientific+    deriving (Eq, Show)++minimumVal+    :: Minimum+    -> Scientific+    -> Maybe MinimumInvalid+minimumVal a@(Minimum exclusive n) x+    | exclusive && x <= n = Just (MinimumInvalid a x)+    | x < n               = Just (MinimumInvalid a x)+    | otherwise           = Nothing

@@ -0,0 +1,179 @@++module JSONSchema.Validator.Draft4.Object+  ( module JSONSchema.Validator.Draft4.Object+  , module JSONSchema.Validator.Draft4.Object.Properties+  ) where++import           Import++import qualified Data.HashMap.Strict                           as HM+import qualified Data.List.NonEmpty                            as NE+import           Data.Set                                      (Set)+import qualified Data.Set                                      as S+import qualified Data.Text                                     as T++import           JSONSchema.Validator.Draft4.Object.Properties+import           JSONSchema.Validator.Utils++--------------------------------------------------+-- * maxProperties+--------------------------------------------------++newtype MaxProperties+    = MaxProperties { _unMaxProperties :: Int }+    deriving (Eq, Show)++instance FromJSON MaxProperties where+    parseJSON = withObject "MaxProperties" $ \o ->+        MaxProperties <$> o .: "maxProperties"++data MaxPropertiesInvalid+    = MaxPropertiesInvalid MaxProperties (HashMap Text Value)+    deriving (Eq, Show)++-- | The spec requires @"maxProperties"@ to be non-negative.+maxPropertiesVal+    :: MaxProperties+    -> HashMap Text Value+    -> Maybe MaxPropertiesInvalid+maxPropertiesVal a@(MaxProperties n) x+    | n < 0         = Nothing+    | HM.size x > n = Just (MaxPropertiesInvalid a x)+    | otherwise     = Nothing++--------------------------------------------------+-- * minProperties+--------------------------------------------------++newtype MinProperties+    = MinProperties { _unMinProperties :: Int }+    deriving (Eq, Show)++instance FromJSON MinProperties where+    parseJSON = withObject "MinProperties" $ \o ->+        MinProperties <$> o .: "minProperties"++data MinPropertiesInvalid+    = MinPropertiesInvalid MinProperties (HashMap Text Value)+    deriving (Eq, Show)++-- | The spec requires @"minProperties"@ to be non-negative.+minPropertiesVal+    :: MinProperties+    -> HashMap Text Value+    -> Maybe MinPropertiesInvalid+minPropertiesVal a@(MinProperties n) x+    | n < 0         = Nothing+    | HM.size x < n = Just (MinPropertiesInvalid a x)+    | otherwise     = Nothing++--------------------------------------------------+-- * required+--------------------------------------------------++-- | From the spec:+--+-- > The value of this keyword MUST be an array.+-- > This array MUST have at least one element.+-- > Elements of this array MUST be strings, and MUST be unique.+newtype Required+    = Required { _unRequired :: Set Text }+    deriving (Eq, Show)++instance FromJSON Required where+    parseJSON = withObject "Required" $ \o ->+        Required <$> o .: "required"++instance Arbitrary Required where+    arbitrary = do+        x  <- arbitraryText -- Guarantee at least one element.+        xs <- (fmap.fmap) T.pack arbitrary+        pure . Required . S.fromList $ x:xs++requiredVal :: Required -> HashMap Text Value -> Maybe ()+requiredVal (Required ts) x+    -- NOTE: When we no longer need to support GHCs before 7.10+    -- we can use null from Prelude throughout the library+    -- instead of specialized versions.+    | S.null ts                    = Nothing+    | HM.null (HM.difference hm x) = Nothing+    | otherwise                    = Just () -- TODO+  where+    hm :: HashMap Text Bool+    hm = foldl (\b a -> HM.insert a True b) mempty ts++--------------------------------------------------+-- * dependencies+--------------------------------------------------++newtype DependenciesValidator schema+    = DependenciesValidator+        { _unDependenciesValidator :: HashMap Text (Dependency schema) }+    deriving (Eq, Show)++instance FromJSON schema => FromJSON (DependenciesValidator schema) where+    parseJSON = withObject "DependenciesValidator" $ \o ->+        DependenciesValidator <$> o .: "dependencies"++data Dependency schema+    = SchemaDependency schema+    | PropertyDependency (Set Text)+    deriving (Eq, Show)++instance FromJSON schema => FromJSON (Dependency schema) where+    parseJSON v = fmap SchemaDependency (parseJSON v)+              <|> fmap PropertyDependency (parseJSON v)++instance ToJSON schema => ToJSON (Dependency schema) where+    toJSON (SchemaDependency schema) = toJSON schema+    toJSON (PropertyDependency ts)   = toJSON ts++instance Arbitrary schema => Arbitrary (Dependency schema) where+    arbitrary = oneof [ SchemaDependency <$> arbitrary+                      , PropertyDependency <$> arbitrarySetOfText+                      ]++data DependencyMemberInvalid err+    = SchemaDepInvalid   (NonEmpty err)+    | PropertyDepInvalid (Set Text) (HashMap Text Value)+    deriving (Eq, Show)++data DependenciesInvalid err+    = DependenciesInvalid (HashMap Text (DependencyMemberInvalid err))+    deriving (Eq, Show)++-- | From the spec:+-- <http://json-schema.org/latest/json-schema-validation.html#anchor70>+--+-- > This keyword's value MUST be an object.+-- > Each value of this object MUST be either an object or an array.+-- >+-- > If the value is an object, it MUST be a valid JSON Schema.+-- > This is called a schema dependency.+-- >+-- > If the value is an array, it MUST have at least one element.+-- > Each element MUST be a string, and elements in the array MUST be unique.+-- > This is called a property dependency.+dependenciesVal+    :: forall err schema.+       (schema -> Value -> [err])+    -> DependenciesValidator schema+    -> HashMap Text Value+    -> Maybe (DependenciesInvalid err)+dependenciesVal f (DependenciesValidator hm) x =+    let res = HM.mapMaybeWithKey g hm+    in if HM.null res+        then Nothing+        else Just (DependenciesInvalid res)+    where+      g :: Text -> Dependency schema -> Maybe (DependencyMemberInvalid err)+      g k (SchemaDependency schema)+          | HM.member k x = SchemaDepInvalid+                        <$> NE.nonEmpty (f schema (Object x))+          | otherwise = Nothing+      g k (PropertyDependency ts)+          | HM.member k x && not allPresent = Just (PropertyDepInvalid ts x)+          | otherwise                       = Nothing+        where+          allPresent :: Bool+          allPresent = all (`HM.member` x) ts

@@ -0,0 +1,209 @@++module JSONSchema.Validator.Draft4.Object.Properties where++import           Import++import qualified Data.Hashable         as HA+import qualified Data.HashMap.Strict   as HM+import qualified Data.List.NonEmpty    as NE+import           Data.Text.Encoding    (encodeUtf8)+import qualified JSONPointer           as JP+import qualified Text.Regex.PCRE.Heavy as RE++data PropertiesRelated schema = PropertiesRelated+    { _propProperties :: Maybe (HashMap Text schema)+    , _propPattern    :: Maybe (HashMap Text schema)+    , _propAdditional :: Maybe (AdditionalProperties schema)+    } deriving (Eq, Show)++instance FromJSON schema => FromJSON (PropertiesRelated schema) where+    parseJSON = withObject "PropertiesRelated" $ \o -> PropertiesRelated+        <$> o .:! "properties"+        <*> o .:! "patternProperties"+        <*> o .:! "additionalProperties"++emptyProperties :: PropertiesRelated schema+emptyProperties = PropertiesRelated+    { _propProperties = Nothing+    , _propPattern    = Nothing+    , _propAdditional = Nothing+    }++data AdditionalProperties schema+    = AdditionalPropertiesBool Bool+    | AdditionalPropertiesObject schema+    deriving (Eq, Show)++instance FromJSON schema => FromJSON (AdditionalProperties schema) where+    parseJSON v = fmap AdditionalPropertiesBool (parseJSON v)+              <|> fmap AdditionalPropertiesObject (parseJSON v)++instance ToJSON schema => ToJSON (AdditionalProperties schema) where+    toJSON (AdditionalPropertiesBool b)    = toJSON b+    toJSON (AdditionalPropertiesObject hm) = toJSON hm++instance Arbitrary schema => Arbitrary (AdditionalProperties schema) where+    arbitrary = oneof [ AdditionalPropertiesBool <$> arbitrary+                      , AdditionalPropertiesObject <$> arbitrary+                      ]++-- | A glorified @type@ alias.+newtype Regex+    = Regex { _unRegex :: Text }+    deriving (Eq, Show, Generic)++instance HA.Hashable Regex++-- NOTE: We'd like to enforce that at least one error exists here.+data PropertiesRelatedInvalid err = PropertiesRelatedInvalid+    { _prInvalidProperties :: HashMap Text [err]+    , _prInvalidPattern    :: HashMap (Regex, JP.Key) [err]+    , _prInvalidAdditional :: Maybe (APInvalid err)+    } deriving (Eq, Show)++data APInvalid err+    = APBoolInvalid   (HashMap Text Value)+    | APObjectInvalid (HashMap Text (NonEmpty err))+    deriving (Eq, Show)++-- | First @"properties"@ and @"patternProperties"@ are run simultaneously+-- on the data, then @"additionalProperties"@ is run on the remainder.+propertiesRelatedVal+    :: forall err schema.+       (schema -> Value -> [err])+    -> PropertiesRelated schema+    -> HashMap Text Value+    -> Maybe (PropertiesRelatedInvalid err)+propertiesRelatedVal f props x+    |  all null (HM.elems propFailures)+    && all null (HM.elems patFailures)+    && isNothing addFailures = Nothing+    | otherwise =+        Just PropertiesRelatedInvalid+            { _prInvalidProperties = propFailures+            , _prInvalidPattern    = patFailures+            , _prInvalidAdditional = addFailures+            }+  where+    propertiesHm :: HashMap Text schema+    propertiesHm = fromMaybe mempty (_propProperties props)++    patHm :: HashMap Text schema+    patHm = fromMaybe mempty (_propPattern props)++    propAndUnmatched :: (HashMap Text [err], Remaining)+    propAndUnmatched = ( HM.intersectionWith f propertiesHm x+                       , Remaining (HM.difference x propertiesHm)+                       )++    (propFailures, propRemaining) = propAndUnmatched++    patAndUnmatched :: (HashMap (Regex, JP.Key) [err], Remaining)+    patAndUnmatched = patternAndUnmatched f patHm x++    (patFailures, patRemaining) = patAndUnmatched++    finalRemaining :: Remaining+    finalRemaining = Remaining (HM.intersection (_unRemaining patRemaining)+                                                (_unRemaining propRemaining))++    addFailures :: Maybe (APInvalid err)+    addFailures = (\addProp -> additionalProperties f addProp finalRemaining)+              =<< _propAdditional props++-- | Internal.+newtype Remaining+    = Remaining { _unRemaining :: HashMap Text Value }++-- | Internal.+patternAndUnmatched+    :: forall err schema.+       (schema -> Value -> [err])+    -> HashMap Text schema+    -> HashMap Text Value+    -> (HashMap (Regex, JP.Key) [err], Remaining)+patternAndUnmatched f patPropertiesHm x =+    (HM.foldlWithKey' runMatches mempty perhapsMatches, remaining)+  where+    -- @[(Regex, schema)]@ will have one item per match.+    perhapsMatches :: HashMap Text ([(Regex, schema)], Value)+    perhapsMatches =+        HM.foldlWithKey' (matchingSchemas patPropertiesHm) mempty x+      where+        matchingSchemas+            :: HashMap Text schema+            -> HashMap Text ([(Regex, schema)], Value)+            -> Text+            -> Value+            -> HashMap Text ([(Regex, schema)], Value)+        matchingSchemas subSchemas acc k v =+            HM.insert k+                      (HM.foldlWithKey' (checkKey k) mempty subSchemas, v)+                      acc++        checkKey+            :: Text+            -> [(Regex, schema)]+            -> Text+            -> schema+            -> [(Regex, schema)]+        checkKey k acc r subSchema =+            case RE.compileM (encodeUtf8 r) mempty of+                Left _   -> acc+                Right re -> if k RE.=~ re+                                then (Regex r, subSchema) : acc+                                else acc++    runMatches+        :: HashMap (Regex, JP.Key) [err]+        -> Text+        -> ([(Regex, schema)], Value)+        -> HashMap (Regex, JP.Key) [err]+    runMatches acc k (matches,v) =+        foldr runMatch acc matches+      where+        runMatch+            :: (Regex, schema)+            -> HashMap (Regex, JP.Key) [err]+            -> HashMap (Regex, JP.Key) [err]+        runMatch (r,schema) = HM.insert (r, JP.Key k) (f schema v)++    remaining :: Remaining+    remaining = Remaining . fmap snd . HM.filter (null . fst) $ perhapsMatches++-- Internal.+additionalProperties+    :: forall err schema.+       (schema -> Value -> [err])+    -> AdditionalProperties schema+    -> Remaining+    -> Maybe (APInvalid err)+additionalProperties f a x =+    case a of+        AdditionalPropertiesBool b ->+            APBoolInvalid <$> additionalPropertiesBool b x+        AdditionalPropertiesObject b ->+            APObjectInvalid <$> additionalPropertiesObject f b x++-- | Internal.+additionalPropertiesBool+    :: Bool+    -> Remaining+    -> Maybe (HashMap Text Value)+additionalPropertiesBool True _ = Nothing+additionalPropertiesBool False (Remaining x)+    | HM.size x > 0 = Just x+    | otherwise     = Nothing++-- | Internal.+additionalPropertiesObject+    :: forall err schema.+       (schema -> Value -> [err])+    -> schema+    -> Remaining+    -> Maybe (HashMap Text (NonEmpty err))+additionalPropertiesObject f schema (Remaining x) =+    let errs = HM.mapMaybe (NE.nonEmpty . f schema) x+    in if HM.null errs+        then Nothing+        else Just errs

@@ -0,0 +1,79 @@++module JSONSchema.Validator.Draft4.String where++import           Import++import qualified Data.Text             as T+import           Data.Text.Encoding    (encodeUtf8)+import qualified Text.Regex.PCRE.Heavy as RE++--------------------------------------------------+-- * maxLength+--------------------------------------------------++newtype MaxLength+    = MaxLength { _unMaxLength :: Int }+    deriving (Eq, Show)++instance FromJSON MaxLength where+    parseJSON = withObject "MaxLength" $ \o ->+        MaxLength <$> o .: "maxLength"++data MaxLengthInvalid+    = MaxLengthInvalid MaxLength Text+    deriving (Eq, Show)++-- | The spec requires @"maxLength"@ to be non-negative.+maxLengthVal :: MaxLength -> Text -> Maybe MaxLengthInvalid+maxLengthVal a@(MaxLength n) x+    | n <= 0         = Nothing+    | T.length x > n = Just (MaxLengthInvalid a x)+    | otherwise      = Nothing++--------------------------------------------------+-- * minLength+--------------------------------------------------++newtype MinLength+    = MinLength { _unMinLength :: Int }+    deriving (Eq, Show)++instance FromJSON MinLength where+    parseJSON = withObject "MinLength" $ \o ->+        MinLength <$> o .: "minLength"++data MinLengthInvalid+    = MinLengthInvalid MinLength Text+    deriving (Eq, Show)++-- | The spec requires @"minLength"@ to be non-negative.+minLengthVal :: MinLength -> Text -> Maybe MinLengthInvalid+minLengthVal a@(MinLength n) x+    | n <= 0         = Nothing+    | T.length x < n = Just (MinLengthInvalid a x)+    | otherwise      = Nothing++--------------------------------------------------+-- * pattern+--------------------------------------------------++newtype PatternValidator+    = PatternValidator { _unPatternValidator :: Text }+    deriving (Eq, Show)++instance FromJSON PatternValidator where+    parseJSON = withObject "PatternValidator" $ \o ->+        PatternValidator <$> o .: "pattern"++data PatternInvalid+    = PatternNotRegex -- TODO: let these pass successfully?+    | PatternInvalid PatternValidator Text+    deriving (Eq, Show)++patternVal :: PatternValidator -> Text -> Maybe PatternInvalid+patternVal a@(PatternValidator t) x =+    case RE.compileM (encodeUtf8 t) mempty of+        Left _   -> Just PatternNotRegex+        Right re -> if x RE.=~ re+                        then Nothing+                        else Just (PatternInvalid a x)

@@ -0,0 +1,79 @@+-- | JSON Reference is described here:+-- <http://tools.ietf.org/html/draft-pbryan-zyp-json-ref-03>+--+-- And is extended for JSON Schema here:+-- <http://json-schema.org/latest/json-schema-core.html#anchor26>++module JSONSchema.Validator.Reference where++import           Import++import qualified Data.Text              as T+import           Data.Text.Encoding     (decodeUtf8, encodeUtf8)+import qualified JSONPointer            as JP+import           Network.HTTP.Types.URI (urlDecode)+import           System.FilePath        ((</>), dropFileName)++-- | TODO: Replace these with actual URI data types.+type URIBase = Maybe Text+type URIBaseAndFragment = (Maybe Text, Maybe Text)++updateResolutionScope :: URIBase -> Maybe Text -> URIBase+updateResolutionScope mScope idKeyword+    | Just t <- idKeyword = fst . baseAndFragment $ resolveScopeAgainst mScope t+    | otherwise           = mScope++resolveReference :: URIBase -> Text -> URIBaseAndFragment+resolveReference mScope t = baseAndFragment $ resolveScopeAgainst mScope t++resolveFragment+    :: (FromJSON schema, ToJSON schema)+    => Maybe Text+    -> schema+    -> Maybe schema+resolveFragment Nothing schema        = Just schema+resolveFragment (Just pointer) schema = do+    let urlDecoded = decodeUtf8 . urlDecode True . encodeUtf8 $ pointer+    p <- either (const Nothing) Just (JP.unescape urlDecoded)+    x <- either (const Nothing) Just (JP.resolve p (toJSON schema))+    case fromJSON x of+        Error _         -> Nothing+        Success schema' -> Just schema'++--------------------------------------------------+-- * Helpers+--------------------------------------------------++isRemoteReference :: Text -> Bool+isRemoteReference = T.isInfixOf "://"++baseAndFragment :: Text -> URIBaseAndFragment+baseAndFragment = f . T.splitOn "#"+  where+    f :: [Text] -> URIBaseAndFragment+    f [x]   = (g x, Nothing)+    f [x,y] = (g x, g y)+    f _     = (Nothing, Nothing)++    g "" = Nothing+    g x  = Just x++resolveScopeAgainst :: Maybe Text -> Text -> Text+resolveScopeAgainst Nothing t = t+resolveScopeAgainst (Just scope) t+    | isRemoteReference t = t+    | otherwise           = smartAppend+  where+    -- There shouldn't be a fragment at the end of a scope URI,+    -- but just in case a user leaves one in we want to be sure+    -- to cut it off before appending.+    smartAppend :: Text+    smartAppend =+        case baseAndFragment scope of+            (Just base,_) ->+                case T.unpack t of+                    -- We want "/foo" and "#/bar" to combine into+                    -- "/foo#/bar" not "/foo/#/bar".+                    '#':_ -> base <> t+                    _     -> T.pack (dropFileName (T.unpack base) </> T.unpack t)+            _ -> t

@@ -0,0 +1,23 @@++module JSONSchema.Validator.Types where++import           Import++import           Data.Profunctor (Profunctor(..))++data Validator schema val err = Validator+    { _embedded :: val -> ([schema], [schema])+      -- ^ The first list is embedded schemas that validate the same piece+      -- of data this schema validates (such as schemas embedded in 'allOf').+      -- The second is embedded schemas that validate a subset of that data+      -- (such as the schemas embedded in 'items').+      --+      -- This is done to allow static detection of loops, though this isn't+      -- implemented yet (though the Draft4 code does do live loop detection+      -- during validation).+    , _validate :: val -> Value -> [err]+    } deriving Functor++instance Profunctor (Validator schema) where+    lmap f (Validator a b) = Validator (lmap f a) (lmap f b)+    rmap = fmap

@@ -0,0 +1,135 @@++module JSONSchema.Validator.Utils where++import           Import++import           Control.Monad       (fail)+import qualified Data.HashMap.Strict as HM+import qualified Data.List.NonEmpty  as NE+import           Data.Scientific     (Scientific, fromFloatDigits)+import           Data.Set            (Set)+import qualified Data.Set            as S+import qualified Data.Text           as T+import qualified Data.Vector         as V++--------------------------------------------------+-- * QuickCheck+--------------------------------------------------++arbitraryText :: Gen Text+arbitraryText = T.pack <$> arbitrary++arbitraryScientific :: Gen Scientific+arbitraryScientific = (fromFloatDigits :: Double -> Scientific) <$> arbitrary++arbitraryPositiveScientific :: Gen Scientific+arbitraryPositiveScientific = (fromFloatDigits :: Double -> Scientific)+                            . getPositive+                          <$> arbitrary++newtype ArbitraryValue+    = ArbitraryValue { _unArbitraryValue :: Value }+    deriving (Eq, Show)++instance Arbitrary ArbitraryValue where+    arbitrary = ArbitraryValue <$> sized f+      where+        f :: Int -> Gen Value+        f n | n <= 1    = oneof nonRecursive+            | otherwise = oneof $+                  fmap (Array . V.fromList) (traverse (const (f (n `div` 10)))+                    =<< (arbitrary :: Gen [()]))+                : fmap (Object . HM.fromList) (traverse (const (g (n `div` 10)))+                    =<< (arbitrary :: Gen [()]))+                : nonRecursive++        g :: Int -> Gen (Text, Value)+        g n = (,) <$> arbitraryText <*> f n++        nonRecursive :: [Gen Value]+        nonRecursive =+            [ pure Null+            , Bool <$> arbitrary+            , String <$> arbitraryText+            , Number <$> arbitraryScientific+            ]++arbitraryHashMap :: Arbitrary a => Gen (HashMap Text a)+arbitraryHashMap = HM.fromList . fmap (first T.pack) <$> arbitrary++arbitrarySetOfText :: Gen (Set Text)+arbitrarySetOfText = S.fromList . fmap T.pack <$> arbitrary++newtype NonEmpty' a = NonEmpty' { _unNonEmpty' :: NonEmpty a }++instance FromJSON a => FromJSON (NonEmpty' a) where+    parseJSON v = do+        xs <- parseJSON v+        case NE.nonEmpty xs of+            Nothing -> fail "Must have at least one item."+            Just ne -> pure (NonEmpty' ne)++instance ToJSON a => ToJSON (NonEmpty' a) where+    toJSON = toJSON . NE.toList . _unNonEmpty'++instance Arbitrary a => Arbitrary (NonEmpty' a) where+    arbitrary = do+        xs <- arbitrary+        case NE.nonEmpty xs of+            Nothing -> NonEmpty' . pure <$> arbitrary+            Just ne -> pure (NonEmpty' ne)++--------------------------------------------------+-- * allUniqueValues+--------------------------------------------------++allUniqueValues :: Vector Value -> Bool+allUniqueValues = allUnique . fmap OrdValue . V.toList++-- NOTE: When we no longer support GHC 7.8 we can generalize+-- allUnique to work on any Foldable and remove this function.+allUniqueValues' :: NonEmpty Value -> Bool+allUniqueValues' = allUnique . fmap OrdValue . NE.toList++allUnique :: (Ord a) => [a] -> Bool+allUnique xs = S.size (S.fromList xs) == length xs++-- | OrdValue's Ord instance needs benchmarking, but it allows us to+-- use our 'allUnique' function instead of O(n^2) nub, so it's probably+-- worth it.+newtype OrdValue = OrdValue { _unOrdValue :: Value } deriving Eq++instance Ord OrdValue where+    (OrdValue Null) `compare` (OrdValue Null) = EQ+    (OrdValue Null) `compare` _               = LT+    _               `compare` (OrdValue Null) = GT++    (OrdValue (Bool x)) `compare` (OrdValue (Bool y)) = x `compare` y+    (OrdValue (Bool _)) `compare` _                   = LT+    _                   `compare` (OrdValue (Bool _)) = GT++    (OrdValue (Number x)) `compare` (OrdValue (Number y)) = x `compare` y+    (OrdValue (Number _)) `compare` _                     = LT+    _                     `compare` (OrdValue (Number _)) = GT++    (OrdValue (String x)) `compare` (OrdValue (String y)) = x `compare` y+    (OrdValue (String _)) `compare` _                     = LT+    _                     `compare` (OrdValue (String _)) = GT++    (OrdValue (Array xs)) `compare` (OrdValue (Array ys)) =+        (OrdValue <$> xs) `compare` (OrdValue <$> ys)+    (OrdValue (Array _))  `compare` _                     = LT+    _                     `compare` (OrdValue (Array _))  = GT++    (OrdValue (Object x)) `compare` (OrdValue (Object y)) =+        HM.toList (OrdValue <$> x) `compare` HM.toList (OrdValue <$> y)++--------------------------------------------------+-- * other+--------------------------------------------------++fromJSONEither :: FromJSON a => Value -> Either Text a+fromJSONEither a =+    case fromJSON a of+        Error e   -> Left (T.pack e)+        Success b -> Right b

@@ -4,15 +4,15 @@ import           Protolude  import           Data.Aeson-import qualified Data.List.NonEmpty     as NE-import qualified System.Timeout         as TO+import qualified Data.List.NonEmpty as NE+import qualified System.Timeout     as TO import           Test.Hspec-import           Test.QuickCheck        (property)+import           Test.QuickCheck    (property) -import qualified Data.JsonSchema.Draft4 as D4-import           Data.JsonSchema.Fetch  (ReferencedSchemas(..),-                                         URISchemaMap(..))-import qualified Data.JsonSchema.Types  as JT+import qualified JSONSchema.Draft4  as D4+import           JSONSchema.Fetch   (ReferencedSchemas(..),+                                     URISchemaMap(..))+import qualified JSONSchema.Types   as JT import qualified Local.Failure import qualified Local.Validation import qualified Local.Reference@@ -46,7 +46,7 @@         describe "Examples" exampleTests         describe "QuickCheck" quickCheckTests         describe "Failure" Local.Failure.spec-        describe "Data.Validator.Reference" Local.Reference.spec+        describe "JSONSchema.Validator.Reference" Local.Reference.spec         describe "Supplementary validation tests written in Haskell"             Local.Validation.spec 

@@ -8,9 +8,9 @@ import qualified Data.Vector                 as V import qualified JSONPointer                 as JP -import           Data.JsonSchema.Draft4-import qualified Data.JsonSchema.Draft4.Spec as Spec-import qualified Data.Validator.Draft4       as D4+import           JSONSchema.Draft4+import qualified JSONSchema.Draft4.Spec      as Spec+import qualified JSONSchema.Validator.Draft4 as VAL  spec :: Spec spec = do@@ -21,9 +21,9 @@ itemsArray :: Expectation itemsArray =     failures `shouldBe`-        [ FailureItems (D4.ItemsArrayInvalid (+        [ FailureItems (VAL.ItemsArrayInvalid (             pure ( JP.Index 0-                 , pure (FailureUniqueItems (D4.UniqueItemsInvalid+                 , pure (FailureUniqueItems (VAL.UniqueItemsInvalid                        (V.fromList [Null, Null])                    ))                  )@@ -35,7 +35,7 @@      schema :: Schema     schema = emptySchema-        { _schemaItems = Just $ D4.ItemsArray+        { _schemaItems = Just $ VAL.ItemsArray             [emptySchema { _schemaUniqueItems = Just True }]         } @@ -51,9 +51,9 @@ itemsObject :: Expectation itemsObject =     failures `shouldBe`-        [ FailureItems (D4.ItemsObjectInvalid (+        [ FailureItems (VAL.ItemsObjectInvalid (             pure ( JP.Index 1-                 , pure (FailureUniqueItems (D4.UniqueItemsInvalid+                 , pure (FailureUniqueItems (VAL.UniqueItemsInvalid                        (V.fromList [Null, Null])                    ))                  )@@ -65,7 +65,7 @@      schema :: Schema     schema = emptySchema-        { _schemaItems = Just $ D4.ItemsObject+        { _schemaItems = Just $ VAL.ItemsObject             (emptySchema { _schemaUniqueItems = Just True })         } @@ -81,9 +81,9 @@ loopRef :: Expectation loopRef =     failures `shouldBe`-        [ FailureRef (D4.RefLoop+        [ FailureRef (VAL.RefLoop             "#"-            (D4.VisitedSchemas [(Nothing, Nothing)])+            (VAL.VisitedSchemas [(Nothing, Nothing)])             (Nothing, Nothing)           )         ]

@@ -5,7 +5,7 @@  import           Test.Hspec -import           Data.Validator.Reference+import           JSONSchema.Validator.Reference  spec :: Spec spec = do

@@ -1,18 +1,17 @@  module Local.Validation where -import           Protolude              hiding (msg)+import           Protolude           hiding (msg)  import           Data.Aeson-import qualified Data.Aeson             as AE-import qualified Data.HashMap.Strict    as HM-import           Data.String            (String)+import qualified Data.Aeson          as AE+import qualified Data.HashMap.Strict as HM+import           Data.String         (String) import           Test.Hspec -import           Data.JsonSchema.Draft4-import qualified Data.JsonSchema.Types  as JT--import qualified AlternateSchema        as AS+import           JSONSchema.Draft4+import qualified JSONSchema.Types    as JT+import qualified AlternateSchema     as AS  spec :: Spec spec = do

@@ -10,10 +10,10 @@ import           Network.Wai.Handler.Warp       (run) import           Test.Hspec -import qualified Data.JsonSchema.Draft4         as D4-import           Data.JsonSchema.Fetch          (ReferencedSchemas(..),-                                                URISchemaMap(..))-import qualified Data.JsonSchema.Types          as JT+import qualified JSONSchema.Draft4              as D4+import           JSONSchema.Fetch               (ReferencedSchemas(..),+                                                     URISchemaMap(..))+import qualified JSONSchema.Types               as JT import           Shared  -- Examples