hjsonschema 0.5.3.2 → 0.6.0.0

raw patch · 7 files changed

+144/−113 lines, 7 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• changelog.txt +12/−0
• hjsonschema.cabal +1/−1
• src/Data/JsonSchema.hs +4/−12
• src/Data/JsonSchema/Core.hs +10/−9
• src/Data/JsonSchema/Helpers.hs +19/−24
• src/Data/JsonSchema/Validators.hs +86/−56
• tests/Lib.hs +12/−11

@@ -1,3 +1,15 @@+# 0.6++Break the API so the library doesn't induce boolean blindness.++Change validate+  was: Schema -> Value -> Vector ValErr+  now: Schema -> Value -> Either (Vector ValErr) Value++Change Schema+  was: type Schema = Vector Validator+  now: newtype Schema = Schema { _unSchema :: [Validator] }+ # 0.5.3  + Switch from http-conduit to http-client.

@@ -1,5 +1,5 @@ name:                   hjsonschema-version:                0.5.3.2+version:                0.6.0.0 synopsis:               JSON Schema Draft 4 library homepage:               https://github.com/seagreen/hjsonschema license:                MIT

@@ -64,15 +64,11 @@ -- NOTE: It's not actually required to run 'isValidSchema' on -- prospective draft 4 schemas at all. However, it's a good way to -- catch unintentional mistakes in schema documents.-isValidSchema :: RawSchema -> Vector ValErr+isValidSchema :: RawSchema -> Either (Vector ValErr) Value isValidSchema r =   case decode . fromStrict $ $(embedFile "draft4.json") of-    Nothing -> V.singleton "Schema decode failed (this should never happen)"-    Just s  -> do-      let draft4Schema = RawSchema { _rsURI = "", _rsObject = s }-      validate-        (compile draft4 H.empty draft4Schema)-        (Object . _rsObject $ r)+    Nothing -> Left $ V.singleton "Schema decode failed (this should never happen)"+    Just s  -> validate (compile draft4 H.empty $ RawSchema "" s) $ Object (_rsObject r)  -- | Check that a 'RawSchema' conforms to the JSON Schema Draft 4 -- master schema document. Compile it if it does.@@ -80,11 +76,7 @@ -- This is just a convenience function built by combining -- 'isValidSchema' and 'compile'. compileDraft4 :: Graph -> RawSchema -> Either (Vector ValErr) Schema-compileDraft4 g r =-  let es = isValidSchema r-  in case V.length es of-    0 -> Right $ compile draft4 g r-    _ -> Left es+compileDraft4 g r = isValidSchema r >> return (compile draft4 g r)  -------------------------------------------------- -- * Graph Builder

@@ -14,31 +14,32 @@ --------------------------------------------------  compile :: Spec -> Graph -> RawSchema -> Schema-compile spec g (RawSchema t o) =-  V.fromList . catMaybes . H.elems $ H.intersectionWith f (_unSpec spec) o+compile spec g (RawSchema t o) = Schema . catMaybes . H.elems $ H.intersectionWith f (_unSpec spec) o   where     f :: (ValidatorGen, a) -> Value -> Maybe Validator     f (vGen,_) = vGen spec g $ RawSchema (newResolutionScope t o) o -validate :: Schema -> Value -> Vector ValErr-validate s x = s >>= ($ x)+validate :: Schema -> Value -> Either (Vector ValErr) Value+validate schema x =+  let errs = V.concatMap ($ x) $ V.fromList (_unSchema schema)+  in if V.null errs+    then Right x+    else Left errs  -------------------------------------------------- -- * Types -------------------------------------------------- -newtype Spec = Spec-  { _unSpec :: HashMap Text (ValidatorGen, EmbeddedSchemas)-  }+newtype Spec = Spec { _unSpec :: HashMap Text (ValidatorGen, EmbeddedSchemas) }  -- | Set of potentially mutually recursive schemas. type Graph = HashMap Text (HashMap Text Value)  type ValErr = Text -type Validator = Value -> Vector ValErr+newtype Schema = Schema { _unSchema :: [Validator] } -type Schema = Vector Validator+type Validator = Value -> Vector ValErr  type ValidatorGen = Spec -> Graph -> RawSchema -> Value -> Maybe Validator 

@@ -46,22 +46,6 @@ -- * Validator Helpers -------------------------------------------------- -propertiesMatches-  :: Spec-  -> Graph-  -> RawSchema-  -> Value-  -> Maybe (Value -> (Vector ValErr, Value))-propertiesMatches spec g s (Object val) = do-  os <- traverse toObj val-  let oss = compile spec g . RawSchema (_rsURI s) <$> os-  Just (\x ->-    case x of-      Object y -> ( join . vectorOfElems $ H.intersectionWith validate oss y-                  , Object $ H.difference y oss)-      z        -> (mempty, z))-propertiesMatches _ _ _ _ = Nothing- patternPropertiesMatches   :: Spec   -> Graph@@ -90,13 +74,12 @@         Just _  -> V.singleton sc      runVals :: (Text, Value, Vector Schema) -> Vector ValErr-    runVals (_,v,ss) = join $ validate <$> ss <*> pure v+    runVals (_,v,ss) = join . vLefts $ validate <$> ss <*> pure v      leftovers :: Vector (Text, Value, Vector Schema) -> Value     leftovers possiblyMatched =       let unmatched = V.filter (\(_,_,ss) -> V.length ss == 0) possiblyMatched       in Object . vectorToHm $ (\(v,k,_) -> (v,k)) <$> unmatched- patternPropertiesMatches _ _ _ _ = Nothing  isJsonType :: Value -> Vector Text -> Vector ValErr@@ -115,15 +98,31 @@                      else mkErr y xs   where     f :: (Show a) => Text -> Vector Text -> a -> Vector ValErr-    f t ts d = if V.elem t ts then mempty else mkErr d ts+    f t ts d = if V.elem t ts+                 then mempty+                 else mkErr d ts      mkErr :: (Show a) => a -> Vector Text -> Vector ValErr-    mkErr y ts = V.singleton $ tshow y <> " is not one of the types " <> tshow ts+    mkErr y ts = V.singleton (tshow y <> " is not one of the types " <> tshow ts)  -------------------------------------------------- -- * Utils -------------------------------------------------- +vLefts :: Vector (Either a b) -> Vector a+vLefts = V.concatMap f+  where+    f :: Either a b -> Vector a+    f (Left e)  = V.singleton e+    f (Right _) = mempty++vRights :: Vector (Either a b) -> Vector b+vRights = V.concatMap f+  where+    f :: Either a b -> Vector b+    f (Left _)  = mempty+    f (Right a) = V.singleton a+ eitherToMaybe :: Either a b -> Maybe b eitherToMaybe (Left _)  = Nothing eitherToMaybe (Right a) = Just a@@ -152,10 +151,6 @@ -- see here: http://comments.gmane.org/gmane.comp.lang.haskell.cafe/106242 allUnique :: (Eq a) => Vector a -> Bool allUnique bs = length (nub (V.toList bs)) == V.length bs---- TODO: optimize-count :: (Eq a) => a -> Vector a -> Int-count b bs = V.length $ V.filter (== b) bs  toObj :: Value -> Maybe (HashMap Text Value) toObj (Object a) = Just a

@@ -8,6 +8,7 @@ import           Control.Applicative import           Control.Monad import           Data.Aeson+import           Data.Either import           Data.Fixed                (mod') import           Data.Hashable import           Data.HashMap.Strict       (HashMap)@@ -18,6 +19,7 @@ import           Data.JsonSchema.Reference import           Data.Maybe import           Data.Monoid+import           Data.Scientific import           Data.Text                 (Text) import qualified Data.Text                 as T import           Data.Text.Encoding@@ -38,37 +40,43 @@     case x of       Number y ->         if y `mod'` val /= 0-          then V.singleton $ tshow y <> " isn't a multiple of " <> tshow val+          then V.singleton (tshow y <> " isn't a multiple of " <> tshow val)           else mempty       _ -> mempty) multipleOf _ _ _ _ = Nothing  maximumVal :: ValidatorGen maximumVal _ _ s (Number val) =-  let f = case H.lookup "exclusiveMaximum" (_rsObject s) of-            Just (Bool a) -> if a then (>=) else (>)-            _             -> (>)-  in Just (\x ->+  Just (\x ->     case x of       Number y ->-        if y `f` val-          then V.singleton $ tshow y <> " fails to validate against maximum " <> tshow val+        if y `greater` val+          then V.singleton (tshow y <> " fails to validate against maximum " <> tshow val)           else mempty       _ -> mempty)+  where+    greater :: Scientific -> Scientific -> Bool+    greater =+      case H.lookup "exclusiveMaximum" (_rsObject s) of+        Just (Bool a) -> if a then (>=) else (>)+        _             -> (>) maximumVal _ _ _ _ = Nothing  minimumVal :: ValidatorGen minimumVal _ _ s (Number val) =-  let f = case H.lookup "exclusiveMinimum" (_rsObject s) of-            Just (Bool a) -> if a then (<=) else (<)-            _             -> (<)-  in Just (\x ->+  Just (\x ->     case x of       Number y ->-        if y `f` val-          then V.singleton $ tshow y <> " fails to validate against minimum " <> tshow val+        if y `lesser` val+          then V.singleton (tshow y <> " fails to validate against minimum " <> tshow val)           else mempty       _ -> mempty)+  where+    lesser :: Scientific -> Scientific -> Bool+    lesser =+      case H.lookup "exclusiveMinimum" (_rsObject s) of+        Just (Bool a) -> if a then (<=) else (<)+        _             -> (<) minimumVal _ _ _ _ = Nothing  --------------------------------------------------@@ -83,7 +91,7 @@     case x of       String y ->         if T.length y > val-          then V.singleton $ y <> " is greater than maxLength " <> tshow val+          then V.singleton (y <> " is greater than maxLength " <> tshow val)           else mempty       _ -> mempty) @@ -95,7 +103,7 @@     case x of       String y ->         if T.length y < val-          then V.singleton $ y <> " is less than minLength " <> tshow val+          then V.singleton (y <> " is less than minLength " <> tshow val)           else mempty       _ -> mempty) @@ -105,7 +113,7 @@     case x of       String t ->         case matchRegexPR (T.unpack val) (T.unpack t) of-          Nothing -> V.singleton $ t <> " fails to validate against pattern " <> val+          Nothing -> V.singleton (t <> " fails to validate against pattern " <> val)           Just _  -> mempty       _ -> mempty) pattern _ _ _ _ = Nothing@@ -120,7 +128,7 @@   let sub = compile spec g (RawSchema (_rsURI s) val)   in Just (\x ->     case x of-      Array ys -> ys >>= validate sub+      Array ys -> ys >>= either id mempty . validate sub       _        -> mempty) items spec g s (Array vs) = do   os <- traverse toObj vs@@ -132,7 +140,8 @@     case x of       (Array ys) ->         let extras = V.drop (V.length os) ys-        in join (V.zipWith validate ss ys) <> runMaybeVal addItems (Array extras)+        in join (either id mempty <$> V.zipWith validate ss ys)+           <> runMaybeVal addItems (Array extras)       _ -> mempty) items _ _ _ _ = Nothing @@ -152,7 +161,7 @@   let sub = compile spec g (RawSchema (_rsURI s) val)   in Just (\x ->     case x of-      Array ys -> ys >>= validate sub+      Array ys -> ys >>= either id mempty . validate sub       _        -> mempty) additionalItems _ _ _ _ = Nothing @@ -164,7 +173,7 @@     case x of       Array ys ->         if V.length ys > val-          then V.singleton $ tshow ys <> " has more items than maxItems " <> tshow val+          then V.singleton (tshow ys <> " has more items than maxItems " <> tshow val)           else mempty       _ -> mempty) @@ -176,7 +185,7 @@     case x of       Array ys ->         if V.length ys < val-          then V.singleton $ tshow ys <> " has fewer items than minItems " <> tshow val+          then V.singleton (tshow ys <> " has fewer items than minItems " <> tshow val)           else mempty       _ -> mempty) @@ -203,7 +212,7 @@     case x of       Object o ->         if H.size o > val-          then V.singleton $ tshow o <> " has more members than maxProperties " <> tshow val+          then V.singleton (tshow o <> " has more members than maxProperties " <> tshow val)           else mempty       _ -> mempty) @@ -215,7 +224,7 @@     case x of       Object o ->         if H.size o < val-          then V.singleton $ tshow o <> " has fewer members than minProperties " <> tshow val+          then V.singleton (tshow o <> " has fewer members than minProperties " <> tshow val)           else mempty       _ -> mempty) @@ -229,8 +238,8 @@     case x of       Object o ->         if H.size (H.difference a o) > 0-          then V.singleton $ "the keys of " <> tshow o <>-            " don't contain all the required elements " <> tshow vs+          then V.singleton ("the keys of: " <> tshow o <>+                            " don't contain all the required elements: " <> tshow vs)           else mempty       _ -> mempty)   where@@ -244,7 +253,7 @@ -- In order of what's tried: properties, patternProperties, additionalProperties properties :: ValidatorGen properties spec g s v = do-  let mProps = propertiesMatches spec g s v+  let mProps = propertiesMatches v   let mPatProp = do                   aV <- H.lookup "patternProperties" (_rsObject s)                   patternPropertiesMatches spec g s aV@@ -260,6 +269,17 @@             (e2s, _) = runMaybeVal' mPatProp (Object y)         in e1s <> e2s <> runMaybeVal mAdd remaining'       _ -> mempty)+  where+    propertiesMatches :: Value -> Maybe (Value -> (Vector ValErr, Value))+    propertiesMatches (Object val) = do+      os <- traverse toObj val+      let oss = compile spec g . RawSchema (_rsURI s) <$> os+      Just (\x ->+        case x of+          Object y -> ( join . vectorOfElems $ either id mempty <$> H.intersectionWith validate oss y+                      , Object $ H.difference y oss)+          z        -> (mempty, z))+    propertiesMatches _ = Nothing  patternProperties :: ValidatorGen patternProperties spec g s v = do@@ -292,7 +312,7 @@   let sub = compile spec g (RawSchema (_rsURI s) val)   in Just (\x ->     case x of-      Object y -> vectorOfElems y >>= validate sub+      Object y -> vectorOfElems y >>= either id mempty . validate sub       _        -> mempty) runAdditionalProperties _ _ _ _ = Nothing @@ -304,25 +324,24 @@  -- 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.+-- > 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. dependencies :: ValidatorGen dependencies spec g s (Object val) = do   let vs = hmToVector val-  let schemaDeps = vs >>= toSchemaDep spec g-  let propDeps = vs >>= toPropDep+      schemaDeps = vs >>= toSchemaDep spec g+      propDeps = vs >>= toPropDep   when (V.length schemaDeps + V.length propDeps /= V.length vs) Nothing   Just (\x ->     case x of-      Object y -> join $ (valSD <$> schemaDeps <*> pure y)-                         <> (valPD <$> propDeps <*> pure y)+      Object y -> join $ (valSD <$> schemaDeps <*> pure y) <> (valPD <$> propDeps <*> pure y)       _        -> mempty)   where     toSchemaDep :: Spec -> Graph -> (Text, Value) -> Vector (Text, Schema)@@ -346,7 +365,7 @@     valSD (t, sub) d =       case H.lookup t d of         Nothing -> mempty-        Just _  -> validate sub (Object d)+        Just _  -> either id (const mempty) $ validate sub (Object d)      valPD :: (Text, Vector Text) -> HashMap Text Value -> Vector ValErr     valPD (t, ts) d =@@ -354,9 +373,8 @@         Nothing -> mempty         Just _  ->           case traverse ($ d) (H.lookup <$> ts) of-            Nothing -> V.singleton-              ("Val error against property dependency with the key "-               <> t <> " and the value " <> tshow ts <> " for: " <> tshow d)+            Nothing -> V.singleton ("Val error against property dependency with key: " <> t+                                    <> " and value " <> tshow ts <> " for: " <> tshow d)             Just _  -> mempty  dependencies _ _ _ _ = Nothing@@ -365,13 +383,23 @@ -- * Any Validators -------------------------------------------------- +-- | 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.+--  >+--  > Elements in the array MAY be of any type, including null.+--+-- NOTE: We actually respect this, and don't build the validator+-- if any of the elements aren't unique. enum :: ValidatorGen enum _ _ _ (Array vs) = do-  unless (V.length vs > 0 && allUnique vs) Nothing+  when (V.null vs || not (allUnique vs)) Nothing   Just (\x ->     if V.elem x vs       then mempty-      else V.singleton $ tshow x <> " is not an element of enum " <> tshow vs)+      else V.singleton (tshow x <> " is not an element of enum " <> tshow vs)) enum _ _ _ _ = Nothing  typeVal :: ValidatorGen@@ -386,7 +414,7 @@ allOf spec g s (Array vs) = do   os <- traverse toObj vs   let ss = compile spec g . RawSchema (_rsURI s) <$> os-  Just (\x -> join $ validate <$> ss <*> pure x)+  Just (\x -> join . vLefts $ validate <$> ss <*> pure x) allOf _ _ _ _ = Nothing  anyOf :: ValidatorGen@@ -394,9 +422,9 @@   os <- traverse toObj vs   let ss = compile spec g . RawSchema (_rsURI s) <$> os   Just (\x ->-    if V.elem V.empty (validate <$> ss <*> pure x)-      then mempty-      else V.singleton ("Val error against anyOf " <> tshow vs <> " for: " <> tshow x))+    case listToMaybe . rights $ validate <$> V.toList ss <*> pure x of+      Nothing -> V.singleton ("Val error against anyOf " <> tshow vs <> " for: " <> tshow x)+      Just _  -> mempty ) anyOf _ _ _ _ = Nothing  oneOf :: ValidatorGen@@ -404,7 +432,7 @@   os <- traverse toObj vs   let ss = compile spec g . RawSchema (_rsURI s) <$> os   Just (\x ->-    if count V.empty (validate <$> ss <*> pure x) == 1+    if V.length (vRights $ validate <$> ss <*> pure x) == 1       then mempty       else V.singleton ("Val error against oneOf " <> tshow vs <> " for: " <> tshow x)) oneOf _ _ _ _ = Nothing@@ -413,9 +441,10 @@ notValidator spec g s (Object val) = do   let sub = compile spec g (RawSchema (_rsURI s) val)   Just (\x ->-    if V.null $ validate sub x-      then V.singleton ("Val error against not validator " <> tshow val <> " for: " <> tshow x)-      else mempty)+    case validate sub x of+      Left _  -> mempty+      Right _ -> V.singleton ("Val error against not validator " <> tshow val+                              <> " for: " <> tshow x)) notValidator _ _ _ _ = Nothing  -- http://tools.ietf.org/html/draft-pbryan-zyp-json-ref-03@@ -430,9 +459,10 @@   p <- eitherToMaybe $ jsonPointer urlDecoded   case resolvePointer p (Object $ _rsObject r) of     Right (Object o) ->-      Just $ validate $ compile spec g $ RawSchema (_rsURI r) o+      let compiled = compile spec g $ RawSchema (_rsURI r) o+      in Just $ either id (const mempty) . validate compiled     _                -> Nothing ref _ _ _ _ = Nothing  noVal :: ValidatorGen-noVal _ _ _ _ = Just (const V.empty)+noVal _ _ _ _ = Just (const mempty)

@@ -15,7 +15,6 @@ import           Data.Text                      (Text) import qualified Data.Text                      as T import           Data.Vector                    (Vector)-import qualified Data.Vector                    as V import           System.FilePath                ((</>)) import           Test.Framework                 (Test) import           Test.Framework.Providers.HUnit (testCase)@@ -71,30 +70,32 @@ toTest :: SchemaTest -> Test toTest st =   testCase (T.unpack $ _stDescription st) $ do-    assertEqual "schema validity errors" V.empty $ isValidSchema (_stSchema st)+    void . assertRight . isValidSchema $ _stSchema st     forM_ (_stCases st) $ \sc -> do       g <- assertRight =<< fetchRefs draft4 (_stSchema st) H.empty-      let es = validate (compile draft4 g $ _stSchema st) (_scData sc)+      let res = validate (compile draft4 g $ _stSchema st) (_scData sc)       if _scValid sc-        then assertValid   sc es-        else assertInvalid sc es+        then assertValid   sc res+        else assertInvalid sc res -assertValid :: SchemaTestCase -> Vector ValErr -> Assertion-assertValid sc es =-  unless (V.length es == 0) $ assertFailure $ unlines+assertValid :: SchemaTestCase -> Either (Vector ValErr) Value -> Assertion+assertValid sc (Left es) =+  assertFailure $ unlines     [ "    Failed to validate data"     , "    Description: " <> T.unpack (_scDescription sc)     , "    Data: "        <> show (_scData sc)     , "    Errors: "      <> show es     ]+assertValid _ _ = return () -assertInvalid :: SchemaTestCase -> Vector ValErr -> Assertion-assertInvalid sc es =-  unless (V.length es > 0) $ assertFailure $ unlines+assertInvalid :: SchemaTestCase -> Either (Vector ValErr) Value -> Assertion+assertInvalid sc (Right _) =+  assertFailure $ unlines     [ "    Failed to invalidate data"     , "    Description: " <> T.unpack (_scDescription sc)     , "    Data: "        <> show (_scData sc)     ]+assertInvalid _ _ = return ()  assertRight :: (Show a) => Either a b -> IO b assertRight a =