hjsonschema 0.5.1.1 → 0.5.1.2

raw patch · 9 files changed

+164/−60 lines, 9 filesdep ~aesondep ~basedep ~unordered-containersnew-component:exe:mainPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: aeson, base, unordered-containers, vector

API changes (from Hackage documentation)

Files

• Main.hs +27/−0
• README.md +39/−1
• hjsonschema.cabal +13/−1
• src/Data/JsonSchema.hs +33/−17
• src/Data/JsonSchema/Core.hs +32/−17
• src/Data/JsonSchema/Helpers.hs +8/−14
• src/Data/JsonSchema/Reference.hs +3/−0
• src/Data/JsonSchema/Validators.hs +8/−9
• tests/Lib.hs +1/−1

@@ -0,0 +1,27 @@+{-# LANGUAGE OverloadedStrings #-}++module Main where++import Data.Aeson+import qualified Data.HashMap.Strict as H+import qualified Data.JsonSchema as JS+import qualified Data.Vector as V++main :: IO ()+main =+  case V.length (JS.isValidSchema rawSchema) of+    0 -> do+      eitherGraph <- JS.fetchRefs JS.draft4 rawSchema H.empty+      case eitherGraph of+        Left e  -> print e+        Right g -> print $ JS.validate (JS.compile JS.draft4 g $ rawSchema) invalidData+    _ -> putStrLn "The schema you tried to use doesn't follow the draft 4 layout."++rawSchema :: JS.RawSchema+rawSchema = JS.RawSchema+  { JS._rsURI = ""+  , JS._rsObject = H.singleton "uniqueItems" (Bool True) -- Schema JSON goes here.+  }++invalidData :: Value+invalidData = Array (V.fromList ["foo", "foo"])

@@ -4,7 +4,45 @@  # Status -Still in development. Lacks documentation and solid code to fetch remote schemas.+Still in development. Lacks solid code to fetch remote schemas.++# Example++```+{-# LANGUAGE OverloadedStrings #-}++module Main where++import Data.Aeson+import qualified Data.HashMap.Strict as H+import qualified Data.JsonSchema as JS+import qualified Data.Vector as V++main :: IO ()+main =+  case V.length (JS.isValidSchema rawSchema) of+    0 -> do+      eitherGraph <- JS.fetchRefs JS.draft4 rawSchema H.empty+      case eitherGraph of+        Left e  -> print e+        Right g -> print $ JS.validate (JS.compile JS.draft4 g $ rawSchema) invalidData+    _ -> putStrLn "The schema you tried to use doesn't follow the draft 4 layout."++rawSchema :: JS.RawSchema+rawSchema = JS.RawSchema+  { JS._rsURI = ""+  , JS._rsObject = H.singleton "uniqueItems" (Bool True) -- Schema JSON goes here.+  }++invalidData :: Value+invalidData = Array (V.fromList ["foo", "foo"])+```++Output:+```+fromList ["Val error against uniqueItems True for: Array (fromList [String \"foo\",String \"foo\"])"]+```+  # Install Tests 

@@ -1,5 +1,5 @@ name:                   hjsonschema-version:                0.5.1.1+version:                0.5.1.2 synopsis:               JSON Schema Draft 4 library homepage:               https://github.com/seagreen/hjsonschema license:                MIT@@ -81,6 +81,18 @@                       , HUnit                >= 1.2 && < 1.3                       , test-framework       >= 0.8 && < 0.9                       , test-framework-hunit >= 0.3 && < 0.4++executable main+  main-is:            Main.hs+  default-language:   Haskell2010+  ghc-options:        -Wall+  other-extensions:   OverloadedStrings++  build-depends:      aeson+                    , base+                    , hjsonschema+                    , vector+                    , unordered-containers  source-repository head   type:               git

@@ -1,8 +1,8 @@ {-# LANGUAGE TemplateHaskell #-}  module Data.JsonSchema-  ( module Data.JsonSchema-  , module Data.JsonSchema.Core+  ( module Data.JsonSchema.Core+  , module Data.JsonSchema   ) where  import           Control.Applicative@@ -22,6 +22,10 @@ import qualified Data.Vector                as V import           Prelude                    hiding (foldr) +--------------------------------------------------+-- * Draft 4 Specific+--------------------------------------------------+ draft4 :: Spec draft4 = Spec $ H.fromList   [ ("$ref"                , (ref                 , noEm))@@ -52,18 +56,43 @@   , ("definitions"         , (noVal               , objMembersEmbed))   ] +-- | Check if a 'RawSchema' is valid Draft 4 schema.+--+-- This is just a convenience function built by preloading 'validate'+-- with the spec schema that describes valid Draft 4 schemas.+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)++--------------------------------------------------+-- * Graph Builder+--------------------------------------------------+-- $ TODO: It would be nice to have a few other functions for building+-- out 'Graph's depending on the situation. For instance, there could be+-- a function that only fetched "$ref"s which use the "file://" scheme.++-- | Take a schema. Retrieve every document either it or its+-- subschemas include via the "$ref" keyword. Load a 'Graph' out+-- with them.+--+-- TODO: This function's URL processing is hacky and needs improvement. fetchRefs :: Spec -> RawSchema -> Graph -> IO (Either Text Graph) fetchRefs spec a graph =   let startingGraph = H.insert (_rsURI a) (_rsObject a) graph   in foldlM fetch (Right startingGraph) (includeSubschemas a)    where-    -- TODO: optimize     includeSubschemas :: RawSchema -> Vector RawSchema     includeSubschemas 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+          ys = V.concat . H.elems $ xs -- TODO: optimize       in V.cons r . V.concat . V.toList $ includeSubschemas <$> ys      fetch :: Either Text Graph -> RawSchema -> IO (Either Text Graph)@@ -80,16 +109,3 @@                 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)

@@ -1,16 +1,34 @@ module Data.JsonSchema.Core where  import           Data.Aeson-import           Data.HashMap.Strict           (HashMap)-import qualified Data.HashMap.Strict           as H+import           Data.HashMap.Strict       (HashMap)+import qualified Data.HashMap.Strict       as H import           Data.JsonSchema.Reference import           Data.Maybe-import           Data.Text                     (Text)-import           Data.Vector                   (Vector)-import qualified Data.Vector                   as V+import           Data.Text                 (Text)+import           Data.Vector               (Vector)+import qualified Data.Vector               as V +--------------------------------------------------+-- * Primary API+--------------------------------------------------++compile :: Spec -> Graph -> RawSchema -> Schema+compile spec g (RawSchema t o) =+  V.fromList . 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)++--------------------------------------------------+-- * Types+--------------------------------------------------+ newtype Spec = Spec-  { _unSpec :: HashMap Text (ValidatorGen, Text -> Value -> Vector RawSchema)+  { _unSpec :: HashMap Text (ValidatorGen, EmbeddedSchemas)   }  -- | Set of potentially mutually recursive schemas.@@ -20,21 +38,18 @@  type Validator = Value -> Vector ValErr +type Schema = Vector Validator+ type ValidatorGen = Spec -> Graph -> RawSchema -> Value -> Maybe Validator -type Schema = Vector Validator+-- | Return a schema's immediate subschemas.+--+-- This is used by 'Data.JsonSchema.fetchRefs' to find all the+-- subschemas in a document. This allows it to process only+-- "$ref"s and "id"s that are actual schema keywords.+type EmbeddedSchemas = Text -> Value -> Vector RawSchema  data RawSchema = RawSchema   { _rsURI    :: Text   , _rsObject :: HashMap Text Value   }--compile :: Spec -> Graph -> RawSchema -> Schema-compile spec g (RawSchema t o) =-  V.fromList . 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)

@@ -1,9 +1,3 @@--- | Embedded schema layouts and functions for use in Validators.hs.------ 'Data.JsonSchema.fetchRefs' uses embedded schema layouts to--- correctly find subschemas so it can check for "$ref" and "id"--- keywords.- module Data.JsonSchema.Helpers where  import           Control.Applicative@@ -24,32 +18,32 @@ import           Text.RegexPR  ----------------------------------------------------- Embedded Schema Layouts+-- * Embedded Schema Layouts -------------------------------------------------- -noEm :: Text -> Value -> Vector RawSchema+noEm :: EmbeddedSchemas noEm _ _ = V.empty -objEmbed :: Text -> Value -> Vector RawSchema+objEmbed :: EmbeddedSchemas objEmbed t (Object o) = V.singleton $ RawSchema t o objEmbed _ _ = V.empty  -- TODO: optimize-arrayEmbed :: Text -> Value -> Vector RawSchema+arrayEmbed :: EmbeddedSchemas arrayEmbed t (Array vs) = V.concat . V.toList $ objEmbed t <$> vs arrayEmbed _ _ = V.empty -objOrArrayEmbed :: Text -> Value -> Vector RawSchema+objOrArrayEmbed :: EmbeddedSchemas objOrArrayEmbed t v@(Object _) = objEmbed t v objOrArrayEmbed t v@(Array _) = arrayEmbed t v objOrArrayEmbed _ _ = V.empty -objMembersEmbed :: Text -> Value -> Vector RawSchema+objMembersEmbed :: EmbeddedSchemas objMembersEmbed t (Object o) = V.concat $ objEmbed t <$> H.elems o objMembersEmbed _ _ = V.empty  ----------------------------------------------------- Validator Helpers+-- * Validator Helpers --------------------------------------------------  propertiesMatches@@ -127,7 +121,7 @@     mkErr y ts = V.singleton $ tshow y <> " is not one of the types " <> tshow ts  ----------------------------------------------------- Utils+-- * Utils --------------------------------------------------  vectorOfElems :: HashMap k a -> Vector a

@@ -1,3 +1,6 @@+-- | TODO: The code handling resolution scope updates+-- is hacky and needs improvement.+ module Data.JsonSchema.Reference where  import           Control.Arrow

@@ -1,7 +1,6 @@--- | This is generally meant to be an internal module.--- It's only exposed in case you want to make your own--- 'Data.JsonSchema.Core.Spec'. If you just want to use--- JSON Schema Draft 4 use the preassembled+-- | This is generally meant to be an internal module. It's only+-- exposed in case you want to make your own 'Spec'. If you just+-- want to use JSON Schema Draft 4 use the preassembled -- 'Data.JsonSchema.draft4' instead.  module Data.JsonSchema.Validators where@@ -29,7 +28,7 @@ import           Text.RegexPR  ----------------------------------------------------- Number Validators+-- * Number Validators --------------------------------------------------  multipleOf :: ValidatorGen@@ -73,7 +72,7 @@ minimumVal _ _ _ _ = Nothing  ----------------------------------------------------- String Validators+-- * String Validators --------------------------------------------------  maxLength :: ValidatorGen@@ -112,7 +111,7 @@ pattern _ _ _ _ = Nothing  ----------------------------------------------------- Array Validators+-- * Array Validators --------------------------------------------------  -- | Also covers additionalItems.@@ -193,7 +192,7 @@ uniqueItems _ _ _ _ = Nothing  ----------------------------------------------------- Object Validators+-- * Object Validators --------------------------------------------------  maxProperties :: ValidatorGen@@ -363,7 +362,7 @@ dependencies _ _ _ _ = Nothing  ----------------------------------------------------- Any Validators+-- * Any Validators --------------------------------------------------  enum :: ValidatorGen

@@ -71,7 +71,7 @@ toTest :: SchemaTest -> Test toTest st =   testCase (T.unpack $ _stDescription st) $ do-    assertEqual "schema validity errors" V.empty (isValidSchema . _stSchema $ st)+    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)