hjsonschema 0.2.0.0 → 0.3.0.0

raw patch · 6 files changed

+48/−34 lines, 6 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• 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

@@ -4,9 +4,9 @@  # Status -Still in development. Lacks documentation, example code, and real error messages.+Still in development. Its handling of the `id` keyword passes tests, but is probably incorrect. -Also while the official tests pass, its handling of the `id` keyword is incomplete.+Also lacks documentation and example code.  # Install Tests 

@@ -1,5 +1,5 @@ name:                   hjsonschema-version:                0.2.0.0+version:                0.3.0.0 synopsis:               Haskell implementation of JSON Schema v4. homepage:               https://github.com/seagreen/hjsonschema license:                MIT@@ -42,6 +42,7 @@   default-language:     Haskell2010   ghc-options:          -Wall   default-extensions:   OverloadedStrings+  other-extensions:     TemplateHaskell   build-depends:        aeson                       , base                       , bytestring@@ -62,6 +63,7 @@   default-language:     Haskell2010   ghc-options:          -Wall   default-extensions:   OverloadedStrings+  other-extensions:     TemplateHaskell   build-depends:        aeson                       , base                       , bytestring

@@ -11,6 +11,7 @@ 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@@ -46,30 +47,31 @@   , ("definitions"         , (noVal               , objMembersEmbed))   ] -fetchRefs :: Spec -> RawSchema -> Graph -> IO Graph+fetchRefs :: Spec -> RawSchema -> Graph -> IO (Either Text Graph) fetchRefs spec a graph =   let startingGraph = H.insert (_rsURI a) (_rsObject a) graph-  in foldlM fetch startingGraph (includeEmbedded a)+  in foldlM fetch (Right startingGraph) (includeSubschemas a)    where     -- TODO: optimize-    includeEmbedded :: RawSchema -> Vector RawSchema-    includeEmbedded r =+    includeSubschemas :: RawSchema -> Vector RawSchema+    includeSubschemas r =       let newId = updateId (_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 $ includeEmbedded <$> ys+      in V.cons r . V.concat . V.toList $ includeSubschemas <$> ys -    fetch :: Graph -> RawSchema -> IO Graph-    fetch g r =+    fetch :: Either Text Graph -> RawSchema -> IO (Either Text Graph)+    fetch (Right g) r =       case H.lookup "$ref" (_rsObject r) >>= toTxt >>= refAndP of-        Nothing     -> return g+        Nothing     -> return (Right g)         Just (s, _) ->           let t = (_rsURI r `combineIdAndRef` s)           in if T.length t <= 0 || H.member t g || not ("://" `T.isInfixOf` t)-            then return g+            then return (Right g)             else do               eResp <- fetchRef t               case eResp of+                Left e    -> return (Left e)                 Right obj -> fetchRefs spec (RawSchema t obj) g-                _         -> return g+    fetch leftGraph _ = return leftGraph

@@ -51,11 +51,13 @@ fetchRef t = do   eResp <- safeGet t   case eResp of-    Left _  -> return (Left "TODO")-    Right b ->-      case decode b of-        Just (Object z) -> return (Right z)-        _               -> return (Left "TODO")+    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 =

@@ -1,5 +1,3 @@-{-# LANGUAGE OverloadedLists #-}- -- | 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@@ -66,7 +64,7 @@  -- TODO: optimize arrayEmbed :: Text -> Value -> Vector RawSchema-arrayEmbed t (Array vs) = V.concat . V.toList $ (\o -> objEmbed t o) <$> vs+arrayEmbed t (Array vs) = V.concat . V.toList $ objEmbed t <$> vs arrayEmbed _ _ = V.empty  objOrArrayEmbed :: Text -> Value -> Vector RawSchema@@ -75,7 +73,7 @@ objOrArrayEmbed _ _ = V.empty  objMembersEmbed :: Text -> Value -> Vector RawSchema-objMembersEmbed t (Object o) = V.concat $ (\x -> objEmbed t x) <$> H.elems o+objMembersEmbed t (Object o) = V.concat $ objEmbed t <$> H.elems o objMembersEmbed _ _ = V.empty  --------------------------------------------------@@ -190,7 +188,7 @@   Just (\x ->     case x of       (Array ys) -> if not val && V.length ys > 0-        then V.singleton "TODO"+        then V.singleton ("Val error against additionalItems false for: " <> tshow x)         else mempty       _ -> mempty) additionalItems' spec g s (Object val) =@@ -230,7 +228,8 @@     case x of       (Array ys) -> if allUnique ys         then mempty-        else V.singleton "TODO"+        else V.singleton+          ("Val error against uniqueItems " <> tshow val <> " for: " <> tshow x)       _ -> mempty) uniqueItems _ _ _ _ = Nothing @@ -374,9 +373,9 @@ additionalProperties' _ _ _ (Bool val) =   Just (\x ->     case x of-      (Object y) -> if val || H.size y == 0-        then mempty-        else V.singleton "TODO"+      (Object y) -> if not val && H.size y > 0+        then V.singleton ("Val error against additionalProperties false for: " <> tshow x)+        else mempty       _ -> mempty) additionalProperties' spec g s (Object val) =   let sub = compile spec g (RawSchema (_rsURI s) val)@@ -444,7 +443,9 @@         Nothing -> mempty         Just _  ->           case traverse ($ d) (H.lookup <$> ts) of-            Nothing -> V.singleton "TODO at least one failed"+            Nothing -> V.singleton+              ("Val error against property dependency with the key "+               <> t <> " and the value " <> tshow ts <> " for: " <> tshow d)             Just _  -> mempty  dependencies _ _ _ _ = Nothing@@ -484,7 +485,7 @@   Just (\x ->     if V.elem V.empty (validate <$> ss <*> pure x)       then mempty-      else V.singleton "TODO")+      else V.singleton ("Val error against anyOf " <> tshow vs <> " for: " <> tshow x)) anyOf _ _ _ _ = Nothing  oneOf :: ValidatorGen@@ -494,7 +495,7 @@   Just (\x ->     if count V.empty (validate <$> ss <*> pure x) == 1       then mempty-      else V.singleton "TODO")+      else V.singleton ("Val error against oneOf " <> tshow vs <> " for: " <> tshow x)) oneOf _ _ _ _ = Nothing  notValidator :: ValidatorGen@@ -502,7 +503,7 @@   let sub = compile spec g (RawSchema (_rsURI s) val)   Just (\x ->     if V.null $ validate sub x-      then V.singleton "TODO"+      then V.singleton ("Val error against not validator " <> tshow val <> " for: " <> tshow x)       else mempty) notValidator _ _ _ _ = Nothing @@ -526,4 +527,4 @@ ref _ _ _ _ = Nothing  noVal :: ValidatorGen-noVal = (\_ _ _ _ -> Just (const V.empty))+noVal _ _ _ _ = Just (const V.empty)

@@ -1,4 +1,5 @@ {-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}  module Lib where @@ -82,12 +83,18 @@  assertValid, assertInvalid :: RawSchema -> Value -> HU.Assertion assertValid r v = do-  g <- fetchRefs draft4 r H.empty+  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 <- fetchRefs draft4 r H.empty+  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"++assertRight :: (Show a) => Either a b -> IO b+assertRight a =+  case a of+    Left e  -> HU.assertFailure (show e) >> fail "assertRight failed"+    Right b -> return b  $(deriveFromJSON defaultOptions { fieldLabelModifier = map toLower . drop 3 } ''SchemaTestCase)