@@ -2,22 +2,34 @@
22
33module Data.JsonSchema.Fetch where
44
5−import Control.Exception (SomeException(..), catch)
5+import Control.Arrow (left)
6+import Control.Exception (catch)
67import qualified Data.ByteString.Lazy as LBS
8+import qualified Data.ByteString as BS
79import qualified Data.HashMap.Strict as H
810import qualified Data.Text as T
911import Network.HTTP.Client
1012
11−import Data.Validator.Reference (isRemoteReference,
12− newResolutionScope,
13− resolveReference)
13+import Data.Validator.Reference (resolveReference,
14+ updateResolutionScope)
1415import Import
1516
1617-- For GHCs before 7.10:
1718import Prelude hiding (concat, sequence)
1819
19−data SchemaContext schema = SchemaContext
20− { _scURI :: !(Maybe Text)
20+--------------------------------------------------
21+-- * Types
22+--------------------------------------------------
23+
24+data Spec schema = Spec
25+ { _ssEmbedded :: schema -> [schema]
26+ , _ssGetId :: schema -> Maybe Text
27+ , _ssGetRef :: schema -> Maybe Text
28+ }
29+
30+data SchemaWithURI schema = SchemaWithURI
31+ { _swSchema :: !schema
32+ , _swURI :: !(Maybe Text)
2133 -- ^ Must not include a URI fragment, e.g. use
2234 -- "http://example.com/foo" not "http://example.com/foo#bar".
2335 --
@@ -26,108 +38,136 @@ data SchemaContext schema = SchemaContext
2638 -- when resolving references contained in the schema.
2739
2840 -- TODO: Make the no URI fragment requirement unnecessary.
29−
30− , _scSchema :: !schema
3141 } deriving (Eq, Show)
3242
3343-- | Keys are URIs (without URI fragments).
3444type URISchemaMap schema = HashMap Text schema
3545
36−data SchemaCache schema = SchemaCache
37− { _startingSchema :: !schema
46+data ReferencedSchemas schema = ReferencedSchemas
47+ { _rsStarting :: !schema
3848 -- ^ Used to resolve relative references.
39− , _cachedSchemas :: !(URISchemaMap schema)
49+ , _rsSchemaMap :: !(URISchemaMap schema)
4050 } deriving (Eq, Show)
4151
52+--------------------------------------------------
53+-- * Fetch via HTTP
54+--------------------------------------------------
55+
56+data HTTPFailure
57+ = HTTPParseFailure Text
58+ | RequestFailure HttpException
59+ deriving Show
60+
4261-- | Take a schema. Retrieve every document either it or its subschemas
43−-- include via the "$ref" keyword. Load a 'SchemaCache' out with them.
44−fetchReferencedSchemas
62+-- include via the "$ref" keyword.
63+referencesViaHTTP'
4564 :: forall schema. FromJSON schema
46− => (schema -> [schema])
47− -> (schema -> Maybe Text)
48− -> (schema -> Maybe Text)
49− -> URISchemaMap schema
50− -> SchemaContext schema
51− -> IO (Either Text (SchemaCache schema))
52−fetchReferencedSchemas embedded getId getRef cache sc = do
65+ => Spec schema
66+ -> SchemaWithURI schema
67+ -> IO (Either HTTPFailure (ReferencedSchemas schema))
68+referencesViaHTTP' spec sw = do
5369 manager <- newManager defaultManagerSettings
54− catch (Right <$> f manager) handler
70+ let f = referencesMethodAgnostic (get manager) spec sw
71+ catch (left HTTPParseFailure <$> f) handler
5572 where
56− f manager = fetchReferencedSchemas' embedded getId getRef
57− (simpleGET manager) cache sc
73+ get :: Manager -> Text -> IO LBS.ByteString
74+ get man url = do
75+ request <- parseUrl (T.unpack url)
76+ responseBody <$> httpLbs request man
5877
59− handler :: SomeException -> IO (Either Text (SchemaCache schema))
60− handler e = pure . Left . T.pack . show $ e
78+ handler
79+ :: HttpException
80+ -> IO (Either HTTPFailure (ReferencedSchemas schema))
81+ handler = pure . Left . RequestFailure
6182
62−-- | Based on 'Network.Http.Conduit.simpleHttp' from http-conduit.
63−simpleGET :: Manager -> Text -> IO LBS.ByteString
64−simpleGET man url = do
65− req <- parseUrl (T.unpack url)
66− responseBody <$> httpLbs req { requestHeaders = ("Connection", "close")
67− : requestHeaders req
68− } man
83+--------------------------------------------------
84+-- * Fetch via Filesystem
85+--------------------------------------------------
86+
87+data FilesystemFailure
88+ = FSParseFailure Text
89+ | ReadFailure IOError
90+ deriving Show
91+
92+referencesViaFilesystem'
93+ :: forall schema. FromJSON schema
94+ => Spec schema
95+ -> SchemaWithURI schema
96+ -> IO (Either FilesystemFailure (ReferencedSchemas schema))
97+referencesViaFilesystem' spec sw = catch (left FSParseFailure <$> f) handler
98+ where
99+ f :: IO (Either Text (ReferencedSchemas schema))
100+ f = referencesMethodAgnostic readFile' spec sw
101+
102+ readFile' :: Text -> IO LBS.ByteString
103+ readFile' = fmap LBS.fromStrict . (BS.readFile . T.unpack)
104+
105+ handler
106+ :: IOError
107+ -> IO (Either FilesystemFailure (ReferencedSchemas schema))
108+ handler = pure . Left . ReadFailure
109+
110+--------------------------------------------------
111+-- * Method Agnostic Fetching Tools
112+--------------------------------------------------
69113
70114-- | A version of 'fetchReferencedSchema's where the function to fetch
71115-- schemas is provided by the user. This allows restrictions to be added,
72116-- e.g. rejecting non-local URIs.
73−fetchReferencedSchemas'
117+referencesMethodAgnostic
118+ :: forall schema. FromJSON schema
119+ => (Text -> IO LBS.ByteString)
120+ -> Spec schema
121+ -> SchemaWithURI schema
122+ -> IO (Either Text (ReferencedSchemas schema))
123+referencesMethodAgnostic fetchRef spec sw =
124+ (fmap.fmap) (ReferencedSchemas (_swSchema sw))
125+ (foldFunction fetchRef spec mempty sw)
126+
127+foldFunction
74128 :: forall schema. FromJSON schema
75− => (schema -> [schema])
76− -> (schema -> Maybe Text)
77− -> (schema -> Maybe Text)
78− -> (Text -> IO LBS.ByteString)
129+ => (Text -> IO LBS.ByteString)
130+ -> Spec schema
79131 -> URISchemaMap schema
80− -> SchemaContext schema
81− -> IO (SchemaCache schema)
82−fetchReferencedSchemas' embedded getId getRef fetchRef cache sc = do
83− let startingCache = case _scURI sc of
84− Nothing -> cache
85− Just uri -> H.insert uri (_scSchema sc) cache
86− SchemaCache (_scSchema sc) <$> foldlM fetchRecursively
87− startingCache
88− (includeSubschemas embedded getId sc)
132+ -> SchemaWithURI schema
133+ -> IO (Either Text (URISchemaMap schema))
134+foldFunction fetchRef spec@(Spec _ _ getRef) referenced sw =
135+ foldlM f (Right referenced) (includeSubschemas spec sw)
89136 where
90− fetchRecursively
91− :: URISchemaMap schema
92− -> SchemaContext schema
93− -> IO (URISchemaMap schema)
94− fetchRecursively g (SchemaContext mUri schema) = do
95− -- Resolving the new scope is necessary here because of situations
96− -- like this:
97− --
98− -- {
99− -- "id": "http://localhost:1234/",
100− -- "items": {
101− -- "id": "folder/",
102− -- "items": {"$ref": "folderInteger.json"}
103− -- }
104− -- }
105− let scope = newResolutionScope mUri (getId schema)
106− case resolveReference scope <$> getRef schema of
107− Just (Just uri,_) ->
108− if not (isRemoteReference uri) || H.member uri g
109− then pure g
110− else do
111− bts <- fetchRef uri
112− case eitherDecode bts of
113− Left e -> ioError (userError e)
114− Right schm -> _cachedSchemas <$>
115− fetchReferencedSchemas' embedded getId getRef fetchRef
116− g (SchemaContext (Just uri) schm)
117− _ -> pure g
137+ f :: Either Text (URISchemaMap schema)
138+ -> SchemaWithURI schema
139+ -> IO (Either Text (URISchemaMap schema))
140+ f (Left e) _ = pure (Left e)
141+ f (Right g) (SchemaWithURI schema mUri) =
142+ case newRef of
143+ Nothing -> pure (Right g)
144+ Just uri -> do
145+ bts <- fetchRef uri
146+ case eitherDecode bts of
147+ Left e -> pure . Left . T.pack $ e
148+ Right schm -> foldFunction fetchRef spec (H.insert uri schm g)
149+ (SchemaWithURI schm (Just uri))
150+ where
151+ newRef :: Maybe Text
152+ newRef
153+ | Just (Just uri,_) <- resolveReference mUri <$> getRef schema
154+ = case H.lookup uri g of
155+ Nothing -> Just uri
156+ Just _ -> Nothing
157+ | otherwise = Nothing
118158
119159-- | Return the schema passed in as an argument, as well as every
120160-- subschema contained within it.
121161includeSubschemas
122162 :: forall schema.
123− (schema -> [schema])
124− -> (schema -> Maybe Text)
125− -> SchemaContext schema
126− -> [SchemaContext schema]
127−includeSubschemas embedded getId (SchemaContext mUri schema) =
128− SchemaContext mUri schema
129− : (includeSubschemas embedded getId =<< subSchemas)
163+ Spec schema
164+ -> SchemaWithURI schema
165+ -> [SchemaWithURI schema]
166+includeSubschemas spec@(Spec embedded getId _) (SchemaWithURI schema mUri) =
167+ SchemaWithURI schema mUri
168+ : (includeSubschemas spec =<< subSchemas)
130169 where
131− subSchemas :: [SchemaContext schema]
132− subSchemas = SchemaContext (newResolutionScope mUri (getId schema))
133− <$> embedded schema
170+ subSchemas :: [SchemaWithURI schema]
171+ subSchemas =
172+ (\a -> SchemaWithURI a (updateResolutionScope mUri (getId schema)))
173+ <$> embedded schema