hjsonschema 0.3.0.0 → 0.4.0.0

raw patch · 12 files changed

+321/−175 lines, 12 filesdep +file-embeddep +hjsonpointerdep +http-typesPVP ok

version bump matches the API change (PVP)

Dependencies added: file-embed, hjsonpointer, http-types

API changes (from Hackage documentation)

Files

• README.md +6/−6
• draft4.json +150/−0
• hjsonschema.cabal +20/−15
• src/Data/JsonSchema.hs +27/−9
• src/Data/JsonSchema/Core.hs +2/−2
• src/Data/JsonSchema/JsonReference.hs +0/−94
• src/Data/JsonSchema/Reference.hs +65/−0
• src/Data/JsonSchema/Utils.hs +0/−2
• src/Data/JsonSchema/Validators.hs +10/−11
• tests/Lib.hs +35/−30
• tests/Local.hs +3/−3
• tests/Remote.hs +3/−3

@@ -1,12 +1,10 @@ # Intro -An implementation of [JSON Schema](http://json-schema.org/) v4 in haskell.+An implementation of [JSON Schema](http://json-schema.org/) Draft 4 in haskell.  # Status -Still in development. Its handling of the `id` keyword passes tests, but is probably incorrect.--Also lacks documentation and example code.+Still in development. Lacks documentation and solid code to fetch remote schemas.  # Install Tests @@ -23,10 +21,12 @@  # Notes -This uses the [regexpr](https://hackage.haskell.org/package/regexpr-0.5.4) regular expression library fo the "pattern" validator. I have no idea if this is compatible with the ECMA 262 regex dialect, which the [spec](http://json-schema.org/latest/json-schema-validation.html#anchor33) requires.++ This uses the [regexpr](https://hackage.haskell.org/package/regexpr-0.5.4) regular expression library fo the "pattern" validator. I have no idea if this is compatible with the ECMA 262 regex dialect, which the [spec](http://json-schema.org/latest/json-schema-validation.html#anchor33) requires. ++ `draft4.json` is from commit # cc8ec81ce0abe2385ebd6c2a6f2d6deb646f874a [here](https://github.com/json-schema/json-schema).+ # Credits  Thanks to [Julian Berman](https://github.com/Julian) for the fantastic test suite. -Also thanks to Tim Baumann for his [aeson-schema](https://hackage.haskell.org/package/aeson-schema) library. Hjsonschema is based on Aeson-Schema, and some code is directly from there.+Also thanks to Tim Baumann for his [aeson-schema](https://hackage.haskell.org/package/aeson-schema) library. Hjsonschema's test code and its implementation of Graph both come from Aeson-Schema.

@@ -0,0 +1,150 @@+{+    "id": "http://json-schema.org/draft-04/schema#",+    "$schema": "http://json-schema.org/draft-04/schema#",+    "description": "Core schema meta-schema",+    "definitions": {+        "schemaArray": {+            "type": "array",+            "minItems": 1,+            "items": { "$ref": "#" }+        },+        "positiveInteger": {+            "type": "integer",+            "minimum": 0+        },+        "positiveIntegerDefault0": {+            "allOf": [ { "$ref": "#/definitions/positiveInteger" }, { "default": 0 } ]+        },+        "simpleTypes": {+            "enum": [ "array", "boolean", "integer", "null", "number", "object", "string" ]+        },+        "stringArray": {+            "type": "array",+            "items": { "type": "string" },+            "minItems": 1,+            "uniqueItems": true+        }+    },+    "type": "object",+    "properties": {+        "id": {+            "type": "string",+            "format": "uri"+        },+        "$schema": {+            "type": "string",+            "format": "uri"+        },+        "title": {+            "type": "string"+        },+        "description": {+            "type": "string"+        },+        "default": {},+        "multipleOf": {+            "type": "number",+            "minimum": 0,+            "exclusiveMinimum": true+        },+        "maximum": {+            "type": "number"+        },+        "exclusiveMaximum": {+            "type": "boolean",+            "default": false+        },+        "minimum": {+            "type": "number"+        },+        "exclusiveMinimum": {+            "type": "boolean",+            "default": false+        },+        "maxLength": { "$ref": "#/definitions/positiveInteger" },+        "minLength": { "$ref": "#/definitions/positiveIntegerDefault0" },+        "pattern": {+            "type": "string",+            "format": "regex"+        },+        "additionalItems": {+            "anyOf": [+                { "type": "boolean" },+                { "$ref": "#" }+            ],+            "default": {}+        },+        "items": {+            "anyOf": [+                { "$ref": "#" },+                { "$ref": "#/definitions/schemaArray" }+            ],+            "default": {}+        },+        "maxItems": { "$ref": "#/definitions/positiveInteger" },+        "minItems": { "$ref": "#/definitions/positiveIntegerDefault0" },+        "uniqueItems": {+            "type": "boolean",+            "default": false+        },+        "maxProperties": { "$ref": "#/definitions/positiveInteger" },+        "minProperties": { "$ref": "#/definitions/positiveIntegerDefault0" },+        "required": { "$ref": "#/definitions/stringArray" },+        "additionalProperties": {+            "anyOf": [+                { "type": "boolean" },+                { "$ref": "#" }+            ],+            "default": {}+        },+        "definitions": {+            "type": "object",+            "additionalProperties": { "$ref": "#" },+            "default": {}+        },+        "properties": {+            "type": "object",+            "additionalProperties": { "$ref": "#" },+            "default": {}+        },+        "patternProperties": {+            "type": "object",+            "additionalProperties": { "$ref": "#" },+            "default": {}+        },+        "dependencies": {+            "type": "object",+            "additionalProperties": {+                "anyOf": [+                    { "$ref": "#" },+                    { "$ref": "#/definitions/stringArray" }+                ]+            }+        },+        "enum": {+            "type": "array",+            "minItems": 1,+            "uniqueItems": true+        },+        "type": {+            "anyOf": [+                { "$ref": "#/definitions/simpleTypes" },+                {+                    "type": "array",+                    "items": { "$ref": "#/definitions/simpleTypes" },+                    "minItems": 1,+                    "uniqueItems": true+                }+            ]+        },+        "allOf": { "$ref": "#/definitions/schemaArray" },+        "anyOf": { "$ref": "#/definitions/schemaArray" },+        "oneOf": { "$ref": "#/definitions/schemaArray" },+        "not": { "$ref": "#" }+    },+    "dependencies": {+        "exclusiveMaximum": [ "maximum" ],+        "exclusiveMinimum": [ "minimum" ]+    },+    "default": {}+}

@@ -1,6 +1,6 @@ name:                   hjsonschema-version:                0.3.0.0-synopsis:               Haskell implementation of JSON Schema v4.+version:                0.4.0.0+synopsis:               Haskell implementation of JSON Schema Draft 4. homepage:               https://github.com/seagreen/hjsonschema license:                MIT license-file:           MIT-LICENSE.txt@@ -9,31 +9,36 @@ category:               Data build-type:             Simple cabal-version:          >=1.10-extra-source-files:     README.md+extra-source-files:     draft4.json                         JSON-Schema-Test-Suite/tests/draft4/*.json+                        README.md                         tests/Lib.hs  library   hs-source-dirs:       src   exposed-modules:      Data.JsonSchema-                      , Data.JsonSchema.JsonReference+                      , Data.JsonSchema.Reference                       , Data.JsonSchema.Utils                       , Data.JsonSchema.Validators   other-modules:        Data.JsonSchema.Core   default-language:     Haskell2010   default-extensions:   OverloadedStrings+  other-extensions:     TemplateHaskell   ghc-options:          -Wall-  build-depends:        aeson                >= 0.8  && < 0.9-                      , base                 >= 4.7  && < 4.8-                      , bytestring           >= 0.10 && < 0.11-                      , hashable             >= 1.2  && < 1.3-                      , lens                 >= 4.7  && < 4.8-                      , regexpr              >= 0.5  && < 0.6-                      , scientific           >= 0.3  && < 0.4-                      , unordered-containers >= 0.2  && < 0.3-                      , text                 >= 1.2  && < 1.3-                      , vector               >= 0.10 && < 0.11-                      , wreq                 >= 0.3  && < 0.4+  build-depends:        aeson                >= 0.8   && < 0.9+                      , base                 >= 4.7   && < 4.8+                      , bytestring           >= 0.10  && < 0.11+                      , file-embed           >= 0.0.8 && < 0.0.9+                      , hashable             >= 1.2   && < 1.3+                      , hjsonpointer         >= 0.1   && < 0.2+                      , http-types           >= 0.8   && < 0.9+                      , lens                 >= 4.7   && < 4.8+                      , regexpr              >= 0.5   && < 0.6+                      , scientific           >= 0.3   && < 0.4+                      , unordered-containers >= 0.2   && < 0.3+                      , text                 >= 1.2   && < 1.3+                      , vector               >= 0.10  && < 0.11+                      , wreq                 >= 0.3   && < 0.4  test-suite local   type:                 exitcode-stdio-1.0

@@ -1,21 +1,26 @@+{-# LANGUAGE TemplateHaskell #-}+ module Data.JsonSchema   ( module Data.JsonSchema   , module Data.JsonSchema.Core   ) where  import           Control.Applicative+import           Data.Aeson+import           Data.ByteString.Lazy       (fromStrict)+import           Data.FileEmbed import           Data.Foldable-import qualified Data.HashMap.Strict           as H+import qualified Data.HashMap.Strict        as H import           Data.JsonSchema.Core-import           Data.JsonSchema.JsonReference+import           Data.JsonSchema.Reference import           Data.JsonSchema.Utils import           Data.JsonSchema.Validators import           Data.Maybe-import           Data.Text                     (Text)-import qualified Data.Text                     as T-import           Data.Vector                   (Vector)-import qualified Data.Vector                   as V-import           Prelude                       hiding (foldr)+import           Data.Text                  (Text)+import qualified Data.Text                  as T+import           Data.Vector                (Vector)+import qualified Data.Vector                as V+import           Prelude                    hiding (foldr)  draft4 :: Spec draft4 = Spec $ H.fromList@@ -56,14 +61,14 @@     -- TODO: optimize     includeSubschemas :: RawSchema -> Vector RawSchema     includeSubschemas r =-      let newId = updateId (_rsURI r) (_rsObject r)+      let newId = newResolutionScope (_rsURI r) (_rsObject r)           xs = H.intersectionWith (\(_,f) x -> f newId x) (_unSpec spec) (_rsObject r)           ys = V.concat . H.elems $ xs       in V.cons r . V.concat . V.toList $ includeSubschemas <$> ys      fetch :: Either Text Graph -> RawSchema -> IO (Either Text Graph)     fetch (Right g) r =-      case H.lookup "$ref" (_rsObject r) >>= toTxt >>= refAndP of+      case H.lookup "$ref" (_rsObject r) >>= toTxt >>= refAndPointer of         Nothing     -> return (Right g)         Just (s, _) ->           let t = (_rsURI r `combineIdAndRef` s)@@ -75,3 +80,16 @@                 Left e    -> return (Left e)                 Right obj -> fetchRefs spec (RawSchema t obj) g     fetch leftGraph _ = return leftGraph++-- | Check if a schema is valid or not. Just a helper function+-- built out of the JSON Schema document which describes valid+-- draft 4 schemas and the normal 'compile' and 'validate' functions.+isValidSchema :: RawSchema -> Vector ValErr+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)

@@ -3,7 +3,7 @@ import           Data.Aeson import           Data.HashMap.Strict           (HashMap) import qualified Data.HashMap.Strict           as H-import           Data.JsonSchema.JsonReference+import           Data.JsonSchema.Reference import           Data.Maybe import           Data.Text                     (Text) import           Data.Vector                   (Vector)@@ -34,7 +34,7 @@   V.fromList . catMaybes . H.elems $ H.intersectionWith f (_unSpec spec) o   where     f :: (ValidatorGen, a) -> Value -> Maybe Validator-    f (vGen,_) = vGen spec g $ RawSchema (updateId t o) o+    f (vGen,_) = vGen spec g $ RawSchema (newResolutionScope t o) o  validate :: Schema -> Value -> Vector ValErr validate s x = s >>= ($ x)

@@ -1,94 +0,0 @@--- | There should be a JSON Reference library for haskell.--module Data.JsonSchema.JsonReference where--import           Control.Exception-import           Control.Lens-import           Control.Monad-import           Data.Aeson-import           Data.ByteString.Lazy (ByteString)-import           Data.HashMap.Strict  (HashMap)-import qualified Data.HashMap.Strict  as H-import           Data.Monoid-import           Data.Text            (Text)-import qualified Data.Text            as T-import qualified Data.Vector          as V-import           Network.Wreq-import           Prelude              hiding (foldr)-import           Text.Read            (readMaybe)--combineIdAndRef :: Text -> Text -> Text-combineIdAndRef a b-  | "://" `T.isInfixOf` b              = b-  | T.length a < 1 || T.length b < 1   = a <> b-  | T.last a == '#' && T.head b == '#' = a <> T.tail b-  | otherwise                          = a <> b--combineIds :: Text -> Text -> Text-combineIds a b-  | b == "#" || b == ""                = a-  | "://" `T.isInfixOf` b              = b-  | T.length a < 1 || T.length b < 1   = a <> b-  | T.last a == '#' && T.head b == '#' = a <> T.tail b-  | otherwise                          = a <> b--updateId :: Text -> HashMap Text Value -> Text-updateId t o =-  case H.lookup "id" o of-    Just (String idVal) -> t `combineIds` idVal-    _                   -> t--refAndP :: Text -> Maybe (Text, Text)-refAndP val = getParts $ T.splitOn "#" val-  where-    getParts :: [Text] -> Maybe (Text, Text)-    getParts []    = Just ("","")-    getParts [x]   = Just (x,"")-    getParts [x,y] = Just (x,y)-    getParts _     = Nothing--fetchRef :: Text -> IO (Either Text (HashMap Text Value))-fetchRef t = do-  eResp <- safeGet t-  case eResp of-    Left err -> return (Left err)-    Right b  ->-      case eitherDecode b of-        Right (Object z) -> return (Right z)-        Right v          -> return . Left $-          "fetchRef returned the following instead of an object" <> T.pack (show v)-        Left e           -> return . Left . T.pack $ e--safeGet :: Text -> IO (Either Text ByteString)-safeGet url =-  catch-    (return . Right . (^. responseBody) =<< get (T.unpack url))-    handler-  where-    handler :: SomeException -> IO (Either Text ByteString)-    handler e = return . Left . T.pack . show $ e---- | There should be a JSON Pointer library.------ Spec: http://tools.ietf.org/html/draft-ietf-appsawg-json-pointer-07-jsonPointer :: Text -> Value -> Maybe Value-jsonPointer pntr = resolve (T.splitOn "/" pntr)-  where-    resolve :: [Text] -> Value -> Maybe Value-    resolve (referenceToken:ts) a =-      let t = unescape referenceToken-      in case T.length t of-        0 -> resolve ts a-        _ ->-          case a of-            (Object b) -> H.lookup t b >>= resolve ts-            (Array c)  -> do-              n <- readMaybe (T.unpack t)-              when (n < 0 || n + 1 > V.length c) Nothing-              resolve ts (c V.! n)-            _ -> Nothing-    resolve _ a = Just a--    -- TODO: do more things need to be escaped?-    unescape :: Text -> Text-    unescape t = T.replace "%25" "%" $ T.replace "~0" "~" $ T.replace "~1" "/" t

@@ -0,0 +1,65 @@+module Data.JsonSchema.Reference where++import           Control.Exception+import           Control.Lens+import           Control.Monad+import           Data.Aeson+import           Data.ByteString.Lazy (ByteString)+import           Data.HashMap.Strict  (HashMap)+import qualified Data.HashMap.Strict  as H+import           Data.Monoid+import           Data.Text            (Text)+import qualified Data.Text            as T+import           Network.Wreq+import           Prelude              hiding (foldr)++combineIdAndRef :: Text -> Text -> Text+combineIdAndRef a b+  | "://" `T.isInfixOf` b              = b+  | T.length a < 1 || T.length b < 1   = a <> b+  | T.last a == '#' && T.head b == '#' = a <> T.tail b+  | otherwise                          = a <> b++combineIds :: Text -> Text -> Text+combineIds a b+  | b == "#" || b == ""                = a+  | "://" `T.isInfixOf` b              = b+  | T.length a < 1 || T.length b < 1   = a <> b+  | T.last a == '#' && T.head b == '#' = a <> T.tail b+  | otherwise                          = a <> b++newResolutionScope :: Text -> HashMap Text Value -> Text+newResolutionScope t o =+  case H.lookup "id" o of+    Just (String idKeyword) -> t `combineIds` idKeyword+    _                       -> t++refAndPointer :: Text -> Maybe (Text, Text)+refAndPointer val = getParts $ T.splitOn "#" val+  where+    getParts :: [Text] -> Maybe (Text, Text)+    getParts []    = Just ("","")+    getParts [x]   = Just (x,"")+    getParts [x,y] = Just (x,y)+    getParts _     = Nothing++fetchRef :: Text -> IO (Either Text (HashMap Text Value))+fetchRef t = do+  eResp <- safeGet t+  case eResp of+    Left err -> return (Left err)+    Right b  ->+      case eitherDecode b of+        Right (Object z) -> return (Right z)+        Right v          -> return . Left $+          "fetchRef returned the following instead of an object" <> T.pack (show v)+        Left e           -> return . Left . T.pack $ e++safeGet :: Text -> IO (Either Text ByteString)+safeGet url =+  catch+    (return . Right . (^. responseBody) =<< get (T.unpack url))+    handler+  where+    handler :: SomeException -> IO (Either Text ByteString)+    handler e = return . Left . T.pack . show $ e

@@ -1,5 +1,3 @@-{-# LANGUAGE OverloadedLists #-}- module Data.JsonSchema.Utils where  import           Data.Aeson

@@ -39,16 +39,19 @@ import           Data.Hashable import           Data.HashMap.Strict           (HashMap) import qualified Data.HashMap.Strict           as H+import           Data.JsonPointer import           Data.JsonSchema.Core-import           Data.JsonSchema.JsonReference+import           Data.JsonSchema.Reference import           Data.JsonSchema.Utils import           Data.Maybe import           Data.Monoid import           Data.Text                     (Text) import qualified Data.Text                     as T+import           Data.Text.Encoding import           Data.Traversable import           Data.Vector                   (Vector) import qualified Data.Vector                   as V+import           Network.HTTP.Types.URI import           Text.RegexPR  --------------------------------------------------@@ -513,17 +516,13 @@ -- ignored. ref :: ValidatorGen ref spec g s (String val) = do-  (reference, pointer) <- refAndP (_rsURI s `combineIdAndRef` val)+  (reference, pointer) <- refAndPointer (_rsURI s `combineIdAndRef` val)   r <- RawSchema reference <$> H.lookup reference g-  sc <- pointerToSchema pointer r-  Just $ validate (compile spec g sc)-  where-    pointerToSchema :: Text -> RawSchema -> Maybe RawSchema-    pointerToSchema pntr rawS = do-      mVal <- jsonPointer pntr (Object . _rsObject $ rawS)-      case mVal of-        (Object o) -> Just $ RawSchema (_rsURI rawS) o-        _           -> Nothing+  let p = decodeUtf8 . urlDecode True . encodeUtf8 $ pointer+  case jsonPointer p >>= resolvePointer (Object $ _rsObject r) of+    Right (Object o) ->+      Just $ validate $ compile spec g $ RawSchema (_rsURI r) o+    _                -> Nothing ref _ _ _ _ = Nothing  noVal :: ValidatorGen

@@ -14,12 +14,18 @@ import           Data.Monoid 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-import           Test.Framework.Providers.HUnit-import qualified Test.HUnit                     as HU+import           Test.Framework                 (Test)+import           Test.Framework.Providers.HUnit (testCase)+import           Test.HUnit                     hiding (Test) +isLocal :: String -> Bool+isLocal file = (file /= "definitions.json")+            && (file /= "ref.json")+            && (file /= "refRemote.json")+ data SchemaTest = SchemaTest   { _stDescription :: Text   , _stSchema      :: RawSchema@@ -34,7 +40,7 @@  instance FromJSON RawSchema where   parseJSON = withObject "Schema" $ \o ->-    return $ RawSchema "" o+    return RawSchema { _rsURI = "", _rsObject = o }  instance FromJSON SchemaTest where   parseJSON = withObject "SchemaTest" $ \o -> SchemaTest@@ -42,11 +48,6 @@     <*> o .: "schema"     <*> o .: "tests" -- I wish this were "cases" -isLocal :: String -> Bool-isLocal file = (file /= "definitions.json")-            && (file /= "ref.json")-            && (file /= "refRemote.json")- readSchemaTests :: String -> [String] -> IO [SchemaTest] readSchemaTests dir jsonFiles = concatMapM fileToCases jsonFiles   where@@ -68,33 +69,37 @@     concatMapM f xs = liftM concat (mapM f xs)  toTest :: SchemaTest -> Test-toTest st = testGroup groupName (mkCase <$> _stCases st)-  where-    groupName :: String-    groupName = T.unpack $ _stDescription st+toTest st =+  testCase (T.unpack $ _stDescription st) $ do+    assertEqual "schema validity errors" V.empty (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)+      if _scValid sc+        then assertValid   sc es+        else assertInvalid sc es -    mkCase :: SchemaTestCase -> Test-    mkCase sc = testCase caseName assertion-      where-        caseName = T.unpack $ _scDescription sc-        assertion = if _scValid sc-          then assertValid   (_stSchema st) (_scData sc)-          else assertInvalid (_stSchema st) (_scData sc)+assertValid :: SchemaTestCase -> Vector ValErr -> Assertion+assertValid sc es =+  unless (V.length es == 0) $ assertFailure $ unlines+    [ "    Failed to validate data"+    , "    Description: " <> T.unpack (_scDescription sc)+    , "    Data: "        <> show (_scData sc)+    , "    Errors: "      <> show es+    ] -assertValid, assertInvalid :: RawSchema -> Value -> HU.Assertion-assertValid r v = do-  g <- assertRight =<< fetchRefs draft4 r H.empty-  let es = validate (compile draft4 g r) v-  unless (V.length es == 0) $ HU.assertFailure (show es)-assertInvalid r v = do-  g <- assertRight =<< fetchRefs draft4 r H.empty-  let es = validate (compile draft4 g r) v-  when (V.length es == 0) $ HU.assertFailure "expected a validation error"+assertInvalid :: SchemaTestCase -> Vector ValErr -> Assertion+assertInvalid sc es =+  unless (V.length es > 0) $ assertFailure $ unlines+    [ "    Failed to invalidate data"+    , "    Description: " <> T.unpack (_scDescription sc)+    , "    Data: "        <> show (_scData sc)+    ]  assertRight :: (Show a) => Either a b -> IO b assertRight a =   case a of-    Left e  -> HU.assertFailure (show e) >> fail "assertRight failed"+    Left e  -> assertFailure (show e) >> fail "assertRight failed"     Right b -> return b  $(deriveFromJSON defaultOptions { fieldLabelModifier = map toLower . drop 3 } ''SchemaTestCase)

@@ -8,9 +8,9 @@  main :: IO () main = do-  files <- filter isLocal . filter (".json" `isSuffixOf`)-             <$> getDirectoryContents dir-  ts <- readSchemaTests dir files+  filenames <- filter isLocal . filter (".json" `isSuffixOf`)+                 <$> getDirectoryContents dir+  ts <- readSchemaTests dir filenames   defaultMain (toTest <$> ts)    where

@@ -8,9 +8,9 @@  main :: IO () main = do-  files <- filter (not . isLocal) . filter (".json" `isSuffixOf`)-             <$> getDirectoryContents dir-  ts <- readSchemaTests dir files+  filenames <- filter (not . isLocal) . filter (".json" `isSuffixOf`)+                 <$> getDirectoryContents dir+  ts <- readSchemaTests dir filenames   defaultMain (toTest <$> ts)    where