diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,8 @@ +# 1.5.0.0 + ++ Report details of `"required"` validator failure. ++ Bump `directory`. + # 1.4.0.0 + Rename `Data.JsonSchema.*` modules to `JSONSchema.*`. diff --git a/examples/AlternateSchema.hs b/examples/AlternateSchema.hs --- a/examples/AlternateSchema.hs +++ b/examples/AlternateSchema.hs @@ -11,9 +11,8 @@ import Protolude import Data.Aeson (FromJSON(..), Value(..), - decode) + decodeStrict) 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 (..)) @@ -66,8 +65,7 @@ metaSchema :: Schema metaSchema = fromMaybe (panic "Schema decode failed (this should never happen)") - . decode - . LBS.fromStrict + . decodeStrict $ metaSchemaBytes checkSchema :: Schema -> [ValidatorFailure] diff --git a/examples/Simple.hs b/examples/Simple.hs --- a/examples/Simple.hs +++ b/examples/Simple.hs @@ -3,20 +3,20 @@ 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(..), decodeStrict, toJSON) +import qualified Data.ByteString as BS +import qualified Data.List.NonEmpty as NE +import Data.Maybe (fromMaybe) -import qualified JSONSchema.Draft4 as D4 +import qualified JSONSchema.Draft4 as D4 badData :: Value badData = toJSON [True, True] example :: IO () example = do - bts <- LBS.readFile "./examples/json/unique.json" - let schema = fromMaybe (panic "Invalid schema JSON.") (decode bts) + bts <- BS.readFile "./examples/json/unique.json" + let schema = fromMaybe (panic "Invalid schema JSON.") (decodeStrict bts) schemaWithURI = D4.SchemaWithURI schema Nothing -- This would be the URI of the schema diff --git a/hjsonschema.cabal b/hjsonschema.cabal --- a/hjsonschema.cabal +++ b/hjsonschema.cabal @@ -1,5 +1,5 @@ name: hjsonschema -version: 1.4.0.0 +version: 1.5.0.0 synopsis: JSON Schema library homepage: https://github.com/seagreen/hjsonschema license: MIT @@ -119,7 +119,7 @@ , vector -- directory-1.2.5 required for `listDirectory`: - , directory >= 1.2.5 && < 1.3 + , directory >= 1.2.5 && < 1.4 , hspec >= 2.2 && < 2.4 test-suite remote diff --git a/src/JSONSchema/Draft4/Failure.hs b/src/JSONSchema/Draft4/Failure.hs --- a/src/JSONSchema/Draft4/Failure.hs +++ b/src/JSONSchema/Draft4/Failure.hs @@ -4,7 +4,7 @@ import Import import JSONSchema.Draft4.Schema (Schema) -import qualified JSONSchema.Validator.Draft4 as D4 +import qualified JSONSchema.Validator.Draft4 as VAL -- | Used to report an entire instance being invalidated, as opposed -- to the failure of a single validator. @@ -15,33 +15,33 @@ } deriving (Eq, Show) data ValidatorFailure - = FailureMultipleOf D4.MultipleOfInvalid - | FailureMaximum D4.MaximumInvalid - | FailureMinimum D4.MinimumInvalid + = FailureMultipleOf VAL.MultipleOfInvalid + | FailureMaximum VAL.MaximumInvalid + | FailureMinimum VAL.MinimumInvalid - | FailureMaxLength D4.MaxLengthInvalid - | FailureMinLength D4.MinLengthInvalid - | FailurePattern D4.PatternInvalid + | FailureMaxLength VAL.MaxLengthInvalid + | FailureMinLength VAL.MinLengthInvalid + | FailurePattern VAL.PatternInvalid - | FailureMaxItems D4.MaxItemsInvalid - | FailureMinItems D4.MinItemsInvalid - | FailureUniqueItems D4.UniqueItemsInvalid - | FailureItems (D4.ItemsInvalid ValidatorFailure) - | FailureAdditionalItems (D4.AdditionalItemsInvalid ValidatorFailure) + | FailureMaxItems VAL.MaxItemsInvalid + | FailureMinItems VAL.MinItemsInvalid + | FailureUniqueItems VAL.UniqueItemsInvalid + | FailureItems (VAL.ItemsInvalid ValidatorFailure) + | FailureAdditionalItems (VAL.AdditionalItemsInvalid ValidatorFailure) - | FailureMaxProperties D4.MaxPropertiesInvalid - | FailureMinProperties D4.MinPropertiesInvalid - | FailureRequired () - | FailureDependencies (D4.DependenciesInvalid ValidatorFailure) - | FailurePropertiesRelated (D4.PropertiesRelatedInvalid ValidatorFailure) + | FailureMaxProperties VAL.MaxPropertiesInvalid + | FailureMinProperties VAL.MinPropertiesInvalid + | FailureRequired VAL.RequiredInvalid + | FailureDependencies (VAL.DependenciesInvalid ValidatorFailure) + | FailurePropertiesRelated (VAL.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 + | FailureRef (VAL.RefInvalid ValidatorFailure) + | FailureEnum VAL.EnumInvalid + | FailureType VAL.TypeValidatorInvalid + | FailureAllOf (VAL.AllOfInvalid ValidatorFailure) + | FailureAnyOf (VAL.AnyOfInvalid ValidatorFailure) + | FailureOneOf (VAL.OneOfInvalid ValidatorFailure) + | FailureNot VAL.NotValidatorInvalid deriving (Eq, Show) -- | A description of why a schema (or one of its reference) is itself diff --git a/src/JSONSchema/Validator/Draft4.hs b/src/JSONSchema/Validator/Draft4.hs --- a/src/JSONSchema/Validator/Draft4.hs +++ b/src/JSONSchema/Validator/Draft4.hs @@ -111,7 +111,7 @@ MinPropertiesInvalid minPropertiesValidator = Validator noEmbedded (run minPropertiesVal) -requiredValidator :: Validator a (Maybe Required) () +requiredValidator :: Validator a (Maybe Required) RequiredInvalid requiredValidator = Validator noEmbedded (run requiredVal) dependenciesValidator diff --git a/src/JSONSchema/Validator/Draft4/Object.hs b/src/JSONSchema/Validator/Draft4/Object.hs --- a/src/JSONSchema/Validator/Draft4/Object.hs +++ b/src/JSONSchema/Validator/Draft4/Object.hs @@ -9,7 +9,7 @@ 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.Set as Set import qualified Data.Text as T import JSONSchema.Validator.Draft4.Object.Properties @@ -88,19 +88,26 @@ arbitrary = do x <- arbitraryText -- Guarantee at least one element. xs <- (fmap.fmap) T.pack arbitrary - pure . Required . S.fromList $ x:xs + pure . Required . Set.fromList $ x:xs -requiredVal :: Required -> HashMap Text Value -> Maybe () -requiredVal (Required ts) x +data RequiredInvalid + = RequiredInvalid Required (Set Text) (HashMap Text Value) + deriving (Eq, Show) + +requiredVal :: Required -> HashMap Text Value -> Maybe RequiredInvalid +requiredVal r@(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 + | Set.null ts = Nothing + | Set.null leftovers = Nothing + | otherwise = Just (RequiredInvalid r leftovers x) where - hm :: HashMap Text Bool - hm = foldl (\b a -> HM.insert a True b) mempty ts + leftovers :: Set Text + leftovers = + Set.difference -- Items of the first set not in the second. + ts + (Set.fromList (HM.keys x)) -------------------------------------------------- -- * dependencies diff --git a/test/Shared.hs b/test/Shared.hs --- a/test/Shared.hs +++ b/test/Shared.hs @@ -3,15 +3,15 @@ import Protolude -import Control.Monad (fail) +import Control.Monad (fail) import Data.Aeson -import Data.Aeson.TH -import qualified Data.ByteString.Lazy as LBS -import Data.Char (toLower) -import Data.List (stripPrefix, unlines) -import qualified Data.Text as T -import qualified System.Directory as SD -import System.FilePath (()) +import Data.Aeson.TH (fieldLabelModifier) +import qualified Data.ByteString as BS +import Data.Char (toLower) +import Data.List (stripPrefix, unlines) +import qualified Data.Text as T +import qualified System.Directory as SD +import System.FilePath (()) import Test.Hspec -- Recursively return the contents of a directory @@ -86,8 +86,8 @@ fileToCases :: FilePath -> IO [SchemaTest] fileToCases name = do let fullPath = dir name - jsonBS <- LBS.readFile fullPath - case eitherDecode jsonBS of + jsonBS <- BS.readFile fullPath + case eitherDecodeStrict jsonBS of Left e -> fail $ "couldn't parse file '" <> fullPath <> "': " <> e Right schemaTests -> pure $ prependFileName name <$> schemaTests