module Data.JsonSchema.Fetch where
import Control.Arrow (left)
import Control.Exception (catch)
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString as BS
import qualified Data.HashMap.Strict as H
import qualified Data.Text as T
import Network.HTTP.Client
import Data.Validator.Reference (resolveReference,
updateResolutionScope)
import Import
import Prelude hiding (concat, sequence)
data Spec schema = Spec
{ _ssEmbedded :: schema -> [schema]
, _ssGetId :: schema -> Maybe Text
, _ssGetRef :: schema -> Maybe Text
}
data SchemaWithURI schema = SchemaWithURI
{ _swSchema :: !schema
, _swURI :: !(Maybe Text)
} deriving (Eq, Show)
type URISchemaMap schema = HashMap Text schema
data ReferencedSchemas schema = ReferencedSchemas
{ _rsStarting :: !schema
, _rsSchemaMap :: !(URISchemaMap schema)
} deriving (Eq, Show)
data HTTPFailure
= HTTPParseFailure Text
| HTTPRequestFailure HttpException
deriving Show
referencesViaHTTP'
:: forall schema. FromJSON schema
=> Spec schema
-> SchemaWithURI schema
-> IO (Either HTTPFailure (ReferencedSchemas schema))
referencesViaHTTP' spec sw = do
manager <- newManager defaultManagerSettings
let f = referencesMethodAgnostic (get manager) spec sw
catch (left HTTPParseFailure <$> f) handler
where
get :: Manager -> Text -> IO LBS.ByteString
get man url = do
request <- parseUrl (T.unpack url)
responseBody <$> httpLbs request man
handler
:: HttpException
-> IO (Either HTTPFailure (ReferencedSchemas schema))
handler = pure . Left . HTTPRequestFailure
data FilesystemFailure
= FSParseFailure Text
| FSReadFailure IOError
deriving Show
referencesViaFilesystem'
:: forall schema. FromJSON schema
=> Spec schema
-> SchemaWithURI schema
-> IO (Either FilesystemFailure (ReferencedSchemas schema))
referencesViaFilesystem' spec sw = catch (left FSParseFailure <$> f) handler
where
f :: IO (Either Text (ReferencedSchemas schema))
f = referencesMethodAgnostic readFile' spec sw
readFile' :: Text -> IO LBS.ByteString
readFile' = fmap LBS.fromStrict . BS.readFile . T.unpack
handler
:: IOError
-> IO (Either FilesystemFailure (ReferencedSchemas schema))
handler = pure . Left . FSReadFailure
referencesMethodAgnostic
:: forall schema. FromJSON schema
=> (Text -> IO LBS.ByteString)
-> Spec schema
-> SchemaWithURI schema
-> IO (Either Text (ReferencedSchemas schema))
referencesMethodAgnostic fetchRef spec sw =
(fmap.fmap) (ReferencedSchemas (_swSchema sw))
(foldFunction fetchRef spec mempty sw)
foldFunction
:: forall schema. FromJSON schema
=> (Text -> IO LBS.ByteString)
-> Spec schema
-> URISchemaMap schema
-> SchemaWithURI schema
-> IO (Either Text (URISchemaMap schema))
foldFunction fetchRef spec@(Spec _ _ getRef) referenced sw =
foldlM f (Right referenced) (includeSubschemas spec sw)
where
f :: Either Text (URISchemaMap schema)
-> SchemaWithURI schema
-> IO (Either Text (URISchemaMap schema))
f (Left e) _ = pure (Left e)
f (Right g) (SchemaWithURI schema mUri) =
case newRef of
Nothing -> pure (Right g)
Just uri -> do
bts <- fetchRef uri
case eitherDecode bts of
Left e -> pure . Left . T.pack $ e
Right schm -> foldFunction fetchRef spec (H.insert uri schm g)
(SchemaWithURI schm (Just uri))
where
newRef :: Maybe Text
newRef
| Just (Just uri,_) <- resolveReference mUri <$> getRef schema
= case H.lookup uri g of
Nothing -> Just uri
Just _ -> Nothing
| otherwise = Nothing
includeSubschemas
:: forall schema.
Spec schema
-> SchemaWithURI schema
-> [SchemaWithURI schema]
includeSubschemas spec@(Spec embedded getId _) (SchemaWithURI schema mUri) =
SchemaWithURI schema mUri
: (includeSubschemas spec =<< subSchemas)
where
subSchemas :: [SchemaWithURI schema]
subSchemas =
(\a -> SchemaWithURI a (updateResolutionScope mUri (getId schema)))
<$> embedded schema