@@ -8,14 +8,11 @@ module Data.JsonSchema
88 , module Data.JsonSchema.Draft4
99 ) where
1010
11−
1211import Control.Monad.Except (MonadError, MonadIO, join, throwError)
1312import qualified Data.ByteString.Lazy as LBS
1413import Data.Foldable
1514import qualified Data.HashMap.Strict as H
1615import Data.String
17−import qualified Data.Text as T
18−import qualified Data.Vector as V
1916
2017import Data.JsonSchema.Core
2118import Data.JsonSchema.Draft4
@@ -24,57 +21,66 @@ import Data.JsonSchema.Reference
2421import Import
2522
2623-- For GHCs before 7.10:
27−import Prelude hiding (sequence)
24+import Prelude hiding (concat, sequence)
2825
2926-- | Take a schema. Retrieve every document either it or its
30−-- subschemas include via the "$ref" keyword. Load a 'Graph' out
27+-- subschemas include via the "$ref" keyword. Load a 'SchemaGraph' out
3128-- with them.
32−--
33−-- TODO: This function's URL processing is hacky and needs improvement.
34−fetchReferencedSchemas :: Spec err -> RawSchema -> Graph -> IO (Either Text Graph)
29+fetchReferencedSchemas :: Spec err -> SchemaCache -> RawSchema -> IO (Either Text SchemaGraph)
3530fetchReferencedSchemas = fetchReferencedSchemas' HE.defaultFetch
3631
3732-- | A version of fetchReferencedSchemas where the function to make requests
3833-- is provided by the user. This allows restrictions to be added, e.g. rejecting
39−-- non-local URLs.
34+-- non-local URIs.
4035fetchReferencedSchemas'
4136 -- The `Functor m` declaration is for GHCs before 7.10.
4237 :: forall m e t err. (MonadIO m, Functor m, MonadError t e, Traversable e, IsString t)
4338 => (Text -> m (e LBS.ByteString))
4439 -> Spec err
40+ -> SchemaCache
4541 -> RawSchema
46− -> Graph
47− -> m (e Graph)
48−fetchReferencedSchemas' fetchRef spec rawSchema graph =
49− let startingGraph = H.insert (_rsURI rawSchema) (_rsObject rawSchema) graph
50− in foldlM (modFetch fetch) (return startingGraph) (includeSubschemas rawSchema)
42+ -> m (e SchemaGraph)
43+fetchReferencedSchemas' fetchRef spec cache rawSchema = do
44+ let startingCache = case _rsURI rawSchema of
45+ Nothing -> cache
46+ Just uri -> H.insert uri (_rsData rawSchema) cache
47+ fmap (SchemaGraph rawSchema) <$> foldlM fetch (return startingCache) (includeSubschemas rawSchema)
5148
5249 where
53− includeSubschemas :: RawSchema -> Vector RawSchema
50+ -- TODO: use a fold here
51+ includeSubschemas :: RawSchema -> [RawSchema]
5452 includeSubschemas r =
55− let newId = newResolutionScope (_rsURI r) (_rsObject r)
56− xs = H.intersectionWith (\(ValSpec f _) x -> f newId x) (_unSpec spec) (_rsObject r)
57− ys = V.concat . H.elems $ xs -- TODO: optimize
58− in V.cons r . V.concat . V.toList $ includeSubschemas <$> ys
59−
60− modFetch :: (Graph -> RawSchema -> m (e Graph)) -> e Graph -> RawSchema -> m (e Graph)
61− modFetch f eg rs = join <$> sequence (flip f rs <$> eg)
53+ let scope = _rsURI r `newResolutionScope` _rsData r
54+ xs = H.intersectionWith (\(ValSpec f _) x -> f scope x) (_unSpec spec) (_rsData r)
55+ in r : (concat . concat . H.elems $ fmap includeSubschemas <$> xs)
6256
63− fetch :: Graph -> RawSchema -> m (e Graph)
64− fetch g r =
65− case H.lookup "$ref" (_rsObject r) >>= HE.toTxt >>= refAndPointer of
66− Nothing -> return (return g)
67− Just (s, _) ->
68− let url = (_rsURI r `combineIdAndRef` s)
69− in if T.length url <= 0 || H.member url g || not ("://" `T.isInfixOf` url)
70− then return (return g)
71− else modDec (decodeResponse url) =<< fetchRef url
57+ fetch :: e SchemaCache -> RawSchema -> m (e SchemaCache)
58+ fetch eg r = join <$> sequence (run <$> eg)
7259 where
73− decodeResponse :: Text -> LBS.ByteString -> m (e Graph)
74− decodeResponse url bts =
60+ run :: SchemaCache -> m (e SchemaCache)
61+ run g = do
62+ -- Resolving the new scope is necessary here because of situations like this:
63+ --
64+ -- {
65+ -- "id": "http://localhost:1234/",
66+ -- "items": {
67+ -- "id": "folder/",
68+ -- "items": {"$ref": "folderInteger.json"}
69+ -- }
70+ -- }
71+ let scope = newResolutionScope (_rsURI r) (_rsData r)
72+ case resolveReference scope <$> (H.lookup "$ref" (_rsData r) >>= HE.toTxt) of
73+ Just (Just uri,_) ->
74+ if not (isRemoteReference uri) || H.member uri g
75+ then return (return g)
76+ else fetchRef uri >>= decodeResponse g uri
77+ _ -> return (return g)
78+
79+ decodeResponse :: SchemaCache -> Text -> e LBS.ByteString -> m (e SchemaCache)
80+ decodeResponse g uri eBts = join <$> sequence (runDecode g uri <$> eBts)
81+
82+ runDecode :: SchemaCache -> Text -> LBS.ByteString -> m (e SchemaCache)
83+ runDecode g uri bts =
7584 case eitherDecode bts of
7685 Left e -> return $ throwError (fromString e)
77− Right obj -> fetchReferencedSchemas' fetchRef spec (RawSchema url obj) g
78−
79− modDec :: (LBS.ByteString -> m (e Graph)) -> e LBS.ByteString -> m (e Graph)
80− modDec f eBts = join <$> sequence (f <$> eBts)
86+ Right obj -> fmap _cachedSchemas <$> fetchReferencedSchemas' fetchRef spec g (RawSchema (Just uri) obj)