module Data.JsonSchema.Fetch where
import Import
import Prelude hiding (concat, sequence)
import Control.Arrow (left)
import Control.Exception (catch)
import Control.Monad (foldM)
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 qualified Network.HTTP.Client as NC
import Data.Validator.Reference (resolveReference,
updateResolutionScope)
data FetchInfo schema = FetchInfo
{ _fiEmbedded :: schema -> ([schema], [schema])
, _fiId :: schema -> Maybe Text
, _fiRef :: schema -> Maybe Text
}
data ReferencedSchemas schema = ReferencedSchemas
{ _rsStarting :: !schema
, _rsSchemaMap :: !(URISchemaMap schema)
} deriving (Eq, Show)
type URISchemaMap schema = HashMap Text schema
data SchemaWithURI schema = SchemaWithURI
{ _swSchema :: !schema
, _swURI :: !(Maybe Text)
} deriving (Eq, Show)
getReference :: ReferencedSchemas schema -> Maybe Text -> Maybe schema
getReference referenced Nothing = Just (_rsStarting referenced)
getReference referenced (Just t) = H.lookup t (_rsSchemaMap referenced)
data HTTPFailure
= HTTPParseFailure Text
| HTTPRequestFailure NC.HttpException
deriving Show
referencesViaHTTP'
:: forall schema. FromJSON schema
=> FetchInfo schema
-> SchemaWithURI schema
-> IO (Either HTTPFailure (URISchemaMap schema))
referencesViaHTTP' info sw = do
manager <- NC.newManager NC.defaultManagerSettings
let f = referencesMethodAgnostic (get manager) info sw
catch (left HTTPParseFailure <$> f) handler
where
get :: NC.Manager -> Text -> IO LBS.ByteString
get man url = do
request <- NC.parseUrlThrow (T.unpack url)
NC.responseBody <$> NC.httpLbs request man
handler
:: NC.HttpException
-> IO (Either HTTPFailure (URISchemaMap schema))
handler = pure . Left . HTTPRequestFailure
data FilesystemFailure
= FSParseFailure Text
| FSReadFailure IOError
deriving (Show, Eq)
referencesViaFilesystem'
:: forall schema. FromJSON schema
=> FetchInfo schema
-> SchemaWithURI schema
-> IO (Either FilesystemFailure (URISchemaMap schema))
referencesViaFilesystem' info sw = catch (left FSParseFailure <$> f) handler
where
f :: IO (Either Text (URISchemaMap schema))
f = referencesMethodAgnostic readFile' info sw
readFile' :: Text -> IO LBS.ByteString
readFile' = fmap LBS.fromStrict . BS.readFile . T.unpack
handler
:: IOError
-> IO (Either FilesystemFailure (URISchemaMap schema))
handler = pure . Left . FSReadFailure
referencesMethodAgnostic
:: forall schema. FromJSON schema
=> (Text -> IO LBS.ByteString)
-> FetchInfo schema
-> SchemaWithURI schema
-> IO (Either Text (URISchemaMap schema))
referencesMethodAgnostic fetchRef info =
getRecursiveReferences fetchRef info mempty
getRecursiveReferences
:: forall schema. FromJSON schema
=> (Text -> IO LBS.ByteString)
-> FetchInfo schema
-> URISchemaMap schema
-> SchemaWithURI schema
-> IO (Either Text (URISchemaMap schema))
getRecursiveReferences fetchRef info referenced sw =
foldM f (Right referenced) (includeSubschemas info 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 -> getRecursiveReferences
fetchRef info (H.insert uri schm g)
(SchemaWithURI schm (Just uri))
where
newRef :: Maybe Text
newRef
| Just (Just uri,_) <- resolveReference mUri <$> _fiRef info schema
= case H.lookup uri g of
Nothing -> Just uri
Just _ -> Nothing
| otherwise = Nothing
includeSubschemas
:: forall schema.
FetchInfo schema
-> SchemaWithURI schema
-> [SchemaWithURI schema]
includeSubschemas info (SchemaWithURI schema mUri) =
SchemaWithURI schema mUri
: (includeSubschemas info =<< subSchemas)
where
subSchemas :: [SchemaWithURI schema]
subSchemas =
(\a -> SchemaWithURI a (updateResolutionScope mUri (_fiId info schema)))
<$> uncurry (<>) (_fiEmbedded info schema)