{-# LANGUAGE OverloadedStrings #-}
module Main where
import Data.Aeson
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as H
import Data.Monoid
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Vector as V
import qualified Data.JsonSchema as JS
-- Data.JsonSchema isn't designed to be imported qualified,
-- but we're doing it here to make it obvious what's coming
-- from the lib.
schemaData :: JS.RawSchema
schemaData = JS.RawSchema
{ JS._rsURI = ""
, JS._rsObject = schemaJSON
}
where
schemaJSON :: HashMap Text Value
schemaJSON = H.singleton "uniqueItems" (Bool True)
badData :: Value
badData = Array $ V.fromList ["foo", "foo"]
main :: IO ()
main = do
let currentSchemaCache = H.empty
newSchemaCache <- (<> currentSchemaCache) <$> fetchGraph schemaData
schema <- compileSchema newSchemaCache schemaData
checkResults (JS.validate schema badData)
where
-- Not necessary in this case, but it serves as an example.
--
-- Note that Graphs are used to handle internal as well as external references.
-- So even if a schema doesn't reference outside documents, you still need
-- to generate a real Graph (and not just use mempty) if it refences itself.
fetchGraph :: JS.RawSchema -> IO JS.Graph
fetchGraph rs = do
eitherGraph <- JS.fetchReferencedSchemas JS.draft4 rs H.empty
case eitherGraph of
Left e -> error $ "Failed to fetch graph with error: " <> T.unpack e
Right graph -> return graph
compileSchema :: JS.Graph -> JS.RawSchema -> IO (JS.Schema JS.Draft4Failure)
compileSchema graph rs =
case JS.compileDraft4 graph rs of
Left failure -> error $ "Not a valid schema: " <> show failure
Right schema -> return schema
checkResults :: [JS.ValidationFailure JS.Draft4Failure] -> IO ()
checkResults [] = error "OHNO we validated bad data!"
checkResults [JS.ValidationFailure JS.UniqueItems (JS.FailureInfo x y)] =
putStrLn . unlines $
[ ""
, "Success. We got a UniqueItems error as expected."
, "Here's the relevant part of the bad JSON document:"
, ""
, " " <> show y
, ""
, "And here's the content of the validator that caught it:"
, ""
, " " <> show x
]
checkResults x = error $ "OHNO we got a different failure than we expected: " <> show x