7e63fa8 · typeable/hjsonschema

git.iko.soy/typeable/hjsonschema

Complete error messages; make small improvements.

commit7e63fa8c6a27f2d62c2ecb6619b89eb87fed349b authorIan Grant Jeffries <ian@housejeffries.com> dateSun 15 Feb 2015, 00:21 (12 years ago) parent23ef711

6 files changed+48−34

compare with master

unifiedsplit

README.md+2−2 hjsonschema.cabal+3−1 src/Data/JsonSchema.hs+12−10 src/Data/JsonSchema/JsonReference.hs+7−5 src/Data/JsonSchema/Validators.hs+15−14 tests/Lib.hs+9−2

README.md+2−2

@@ -4,9 +4,9 @@ An implementation of [JSON Schema](http://json-schema.org/) v4 in haskell.

55# Status

7−Still in development. Lacks documentation, example code, and real error messages.

7+Still in development. Its handling of the `id` keyword passes tests, but is probably incorrect.

9−Also while the official tests pass, its handling of the `id` keyword is incomplete.

9+Also lacks documentation and example code.

1010

1111# Install Tests

1212

hjsonschema.cabal+3−1

@@ -1,5 +1,5 @@

11name: hjsonschema

2−version: 0.2.0.0

2+version: 0.3.0.0

33synopsis: Haskell implementation of JSON Schema v4.

44homepage: https://github.com/seagreen/hjsonschema

55license: MIT

@@ -42,6 +42,7 @@ test-suite local

4242 default-language: Haskell2010

4343 ghc-options: -Wall

4444 default-extensions: OverloadedStrings

45+ other-extensions: TemplateHaskell

4546 build-depends: aeson

4647 , base

4748 , bytestring

@@ -62,6 +63,7 @@ test-suite remote

6263 default-language: Haskell2010

6364 ghc-options: -Wall

6465 default-extensions: OverloadedStrings

66+ other-extensions: TemplateHaskell

6567 build-depends: aeson

6668 , base

6769 , bytestring

src/Data/JsonSchema.hs+12−10

@@ -11,6 +11,7 @@ import Data.JsonSchema.JsonReference

1111import Data.JsonSchema.Utils

1212import Data.JsonSchema.Validators

1313import Data.Maybe

14+import Data.Text (Text)

1415import qualified Data.Text as T

1516import Data.Vector (Vector)

1617import qualified Data.Vector as V

@@ -46,30 +47,31 @@ draft4 = Spec $ H.fromList

4647 , ("definitions" , (noVal , objMembersEmbed))

4748 ]

4849

49−fetchRefs :: Spec -> RawSchema -> Graph -> IO Graph

50+fetchRefs :: Spec -> RawSchema -> Graph -> IO (Either Text Graph)

5051fetchRefs spec a graph =

5152 let startingGraph = H.insert (_rsURI a) (_rsObject a) graph

52− in foldlM fetch startingGraph (includeEmbedded a)

53+ in foldlM fetch (Right startingGraph) (includeSubschemas a)

5354

5455 where

5556 -- TODO: optimize

56− includeEmbedded :: RawSchema -> Vector RawSchema

57− includeEmbedded r =

57+ includeSubschemas :: RawSchema -> Vector RawSchema

58+ includeSubschemas r =

5859 let newId = updateId (_rsURI r) (_rsObject r)

5960 xs = H.intersectionWith (\(_,f) x -> f newId x) (_unSpec spec) (_rsObject r)

6061 ys = V.concat . H.elems $ xs

61− in V.cons r . V.concat . V.toList $ includeEmbedded <$> ys

62+ in V.cons r . V.concat . V.toList $ includeSubschemas <$> ys

6263

63− fetch :: Graph -> RawSchema -> IO Graph

64− fetch g r =

64+ fetch :: Either Text Graph -> RawSchema -> IO (Either Text Graph)

65+ fetch (Right g) r =

6566 case H.lookup "$ref" (_rsObject r) >>= toTxt >>= refAndP of

66− Nothing -> return g

67+ Nothing -> return (Right g)

6768 Just (s, _) ->

6869 let t = (_rsURI r `combineIdAndRef` s)

6970 in if T.length t <= 0 || H.member t g || not ("://" `T.isInfixOf` t)

70− then return g

71+ then return (Right g)

7172 else do

7273 eResp <- fetchRef t

7374 case eResp of

75+ Left e -> return (Left e)

7476 Right obj -> fetchRefs spec (RawSchema t obj) g

75− _ -> return g

77+ fetch leftGraph _ = return leftGraph

src/Data/JsonSchema/JsonReference.hs+7−5

@@ -51,11 +51,13 @@ fetchRef :: Text -> IO (Either Text (HashMap Text Value))

5151fetchRef t = do

5252 eResp <- safeGet t

5353 case eResp of

54− Left _ -> return (Left "TODO")

55− Right b ->

56− case decode b of

57− Just (Object z) -> return (Right z)

58− _ -> return (Left "TODO")

54+ Left err -> return (Left err)

55+ Right b ->

56+ case eitherDecode b of

57+ Right (Object z) -> return (Right z)

58+ Right v -> return . Left $

59+ "fetchRef returned the following instead of an object" <> T.pack (show v)

60+ Left e -> return . Left . T.pack $ e

5961

6062safeGet :: Text -> IO (Either Text ByteString)

6163safeGet url =

src/Data/JsonSchema/Validators.hs+15−14

@@ -1,5 +1,3 @@

1−{-# LANGUAGE OverloadedLists #-}

2−

31-- | This is generally meant to be an internal module.

42-- It's only exposed in case you want to make your own

53-- 'Spec'. If you just want to use JSON Schema Draft 4

@@ -66,7 +64,7 @@ objEmbed _ _ = V.empty

6664

6765-- TODO: optimize

6866arrayEmbed :: Text -> Value -> Vector RawSchema

69−arrayEmbed t (Array vs) = V.concat . V.toList $ (\o -> objEmbed t o) <$> vs

67+arrayEmbed t (Array vs) = V.concat . V.toList $ objEmbed t <$> vs

7068arrayEmbed _ _ = V.empty

7169

7270objOrArrayEmbed :: Text -> Value -> Vector RawSchema

@@ -75,7 +73,7 @@ objOrArrayEmbed t v@(Array _) = arrayEmbed t v

7573objOrArrayEmbed _ _ = V.empty

7674

7775objMembersEmbed :: Text -> Value -> Vector RawSchema

78−objMembersEmbed t (Object o) = V.concat $ (\x -> objEmbed t x) <$> H.elems o

76+objMembersEmbed t (Object o) = V.concat $ objEmbed t <$> H.elems o

7977objMembersEmbed _ _ = V.empty

8078

8179--------------------------------------------------

@@ -190,7 +188,7 @@ additionalItems' _ _ _ (Bool val) =

190188 Just (\x ->

191189 case x of

192190 (Array ys) -> if not val && V.length ys > 0

193− then V.singleton "TODO"

191+ then V.singleton ("Val error against additionalItems false for: " <> tshow x)

194192 else mempty

195193 _ -> mempty)

196194additionalItems' spec g s (Object val) =

@@ -230,7 +228,8 @@ uniqueItems _ _ _ (Bool val) = do

230228 case x of

231229 (Array ys) -> if allUnique ys

232230 then mempty

233− else V.singleton "TODO"

231+ else V.singleton

232+ ("Val error against uniqueItems " <> tshow val <> " for: " <> tshow x)

234233 _ -> mempty)

235234uniqueItems _ _ _ _ = Nothing

236235

@@ -374,9 +373,9 @@ additionalProperties' :: ValidatorGen

374373additionalProperties' _ _ _ (Bool val) =

375374 Just (\x ->

376375 case x of

377− (Object y) -> if val || H.size y == 0

378− then mempty

379− else V.singleton "TODO"

376+ (Object y) -> if not val && H.size y > 0

377+ then V.singleton ("Val error against additionalProperties false for: " <> tshow x)

378+ else mempty

380379 _ -> mempty)

381380additionalProperties' spec g s (Object val) =

382381 let sub = compile spec g (RawSchema (_rsURI s) val)

@@ -444,7 +443,9 @@ dependencies spec g s (Object val) = do

444443 Nothing -> mempty

445444 Just _ ->

446445 case traverse ($ d) (H.lookup <$> ts) of

447− Nothing -> V.singleton "TODO at least one failed"

446+ Nothing -> V.singleton

447+ ("Val error against property dependency with the key "

448+ <> t <> " and the value " <> tshow ts <> " for: " <> tshow d)

448449 Just _ -> mempty

449450

450451dependencies _ _ _ _ = Nothing

@@ -484,7 +485,7 @@ anyOf spec g s (Array vs) = do

484485 Just (\x ->

485486 if V.elem V.empty (validate <$> ss <*> pure x)

486487 then mempty

487− else V.singleton "TODO")

488+ else V.singleton ("Val error against anyOf " <> tshow vs <> " for: " <> tshow x))

488489anyOf _ _ _ _ = Nothing

489490

490491oneOf :: ValidatorGen

@@ -494,7 +495,7 @@ oneOf spec g s (Array vs) = do

494495 Just (\x ->

495496 if count V.empty (validate <$> ss <*> pure x) == 1

496497 then mempty

497− else V.singleton "TODO")

498+ else V.singleton ("Val error against oneOf " <> tshow vs <> " for: " <> tshow x))

498499oneOf _ _ _ _ = Nothing

499500

500501notValidator :: ValidatorGen

@@ -502,7 +503,7 @@ notValidator spec g s (Object val) = do

502503 let sub = compile spec g (RawSchema (_rsURI s) val)

503504 Just (\x ->

504505 if V.null $ validate sub x

505− then V.singleton "TODO"

506+ then V.singleton ("Val error against not validator " <> tshow val <> " for: " <> tshow x)

506507 else mempty)

507508notValidator _ _ _ _ = Nothing

508509

@@ -526,4 +527,4 @@ ref spec g s (String val) = do

526527ref _ _ _ _ = Nothing

527528

528529noVal :: ValidatorGen

529−noVal = (\_ _ _ _ -> Just (const V.empty))

530+noVal _ _ _ _ = Just (const V.empty)

tests/Lib.hs+9−2

@@ -1,4 +1,5 @@

11{-# LANGUAGE TemplateHaskell #-}

2+{-# OPTIONS_GHC -fno-warn-orphans #-}

34module Lib where

@@ -82,12 +83,18 @@ toTest st = testGroup groupName (mkCase <$> _stCases st)

8283

8384assertValid, assertInvalid :: RawSchema -> Value -> HU.Assertion

8485assertValid r v = do

85− g <- fetchRefs draft4 r H.empty

86+ g <- assertRight =<< fetchRefs draft4 r H.empty

8687 let es = validate (compile draft4 g r) v

8788 unless (V.length es == 0) $ HU.assertFailure (show es)

8889assertInvalid r v = do

89− g <- fetchRefs draft4 r H.empty

90+ g <- assertRight =<< fetchRefs draft4 r H.empty

9091 let es = validate (compile draft4 g r) v

9192 when (V.length es == 0) $ HU.assertFailure "expected a validation error"

9293

94+assertRight :: (Show a) => Either a b -> IO b

95+assertRight a =

96+ case a of

97+ Left e -> HU.assertFailure (show e) >> fail "assertRight failed"

98+ Right b -> return b

99+

93100$(deriveFromJSON defaultOptions { fieldLabelModifier = map toLower . drop 3 } ''SchemaTestCase)