@@ -1,8 +1,8 @@
11{-# LANGUAGE TemplateHaskell #-}
22
33module Data.JsonSchema
4− ( module Data.JsonSchema
5− , module Data.JsonSchema.Core
4+ ( module Data.JsonSchema.Core
5+ , module Data.JsonSchema
66 ) where
77
88import Control.Applicative
@@ -22,6 +22,10 @@ import Data.Vector (Vector)
2222import qualified Data.Vector as V
2323import Prelude hiding (foldr)
2424
25+--------------------------------------------------
26+-- * Draft 4 Specific
27+--------------------------------------------------
28+
2529draft4 :: Spec
2630draft4 = Spec $ H.fromList
2731 [ ("$ref" , (ref , noEm))
@@ -52,18 +56,43 @@ draft4 = Spec $ H.fromList
5256 , ("definitions" , (noVal , objMembersEmbed))
5357 ]
5458
59+-- | Check if a 'RawSchema' is valid Draft 4 schema.
60+--
61+-- This is just a convenience function built by preloading 'validate'
62+-- with the spec schema that describes valid Draft 4 schemas.
63+isValidSchema :: RawSchema -> Vector ValErr
64+isValidSchema r =
65+ case decode . fromStrict $ $(embedFile "draft4.json") of
66+ Nothing -> V.singleton "Schema decode failed (this should never happen)"
67+ Just s -> do
68+ let draft4Schema = RawSchema { _rsURI = "", _rsObject = s }
69+ validate
70+ (compile draft4 H.empty draft4Schema)
71+ (Object . _rsObject $ r)
72+
73+--------------------------------------------------
74+-- * Graph Builder
75+--------------------------------------------------
76+-- $ TODO: It would be nice to have a few other functions for building
77+-- out 'Graph's depending on the situation. For instance, there could be
78+-- a function that only fetched "$ref"s which use the "file://" scheme.
79+
80+-- | Take a schema. Retrieve every document either it or its
81+-- subschemas include via the "$ref" keyword. Load a 'Graph' out
82+-- with them.
83+--
84+-- TODO: This function's URL processing is hacky and needs improvement.
5585fetchRefs :: Spec -> RawSchema -> Graph -> IO (Either Text Graph)
5686fetchRefs spec a graph =
5787 let startingGraph = H.insert (_rsURI a) (_rsObject a) graph
5888 in foldlM fetch (Right startingGraph) (includeSubschemas a)
5989
6090 where
61− -- TODO: optimize
6291 includeSubschemas :: RawSchema -> Vector RawSchema
6392 includeSubschemas r =
6493 let newId = newResolutionScope (_rsURI r) (_rsObject r)
6594 xs = H.intersectionWith (\(_,f) x -> f newId x) (_unSpec spec) (_rsObject r)
66− ys = V.concat . H.elems $ xs
95+ ys = V.concat . H.elems $ xs -- TODO: optimize
6796 in V.cons r . V.concat . V.toList $ includeSubschemas <$> ys
6897
6998 fetch :: Either Text Graph -> RawSchema -> IO (Either Text Graph)
@@ -80,16 +109,3 @@ fetchRefs spec a graph =
80109 Left e -> return (Left e)
81110 Right obj -> fetchRefs spec (RawSchema t obj) g
82111 fetch leftGraph _ = return leftGraph
83−
84−-- | Check if a schema is valid or not. Just a helper function
85−-- built out of the JSON Schema document which describes valid
86−-- draft 4 schemas and the normal 'compile' and 'validate' functions.
87−isValidSchema :: RawSchema -> Vector ValErr
88−isValidSchema r =
89− case decode . fromStrict $ $(embedFile "draft4.json") of
90− Nothing -> V.singleton "Schema decode failed (this should never happen)"
91− Just s -> do
92− let draft4Schema = RawSchema { _rsURI = "", _rsObject = s }
93− validate
94− (compile draft4 H.empty draft4Schema)
95− (Object . _rsObject $ r)