module Data.JsonSchema.Draft4.Schema where
import Import
import Prelude
import qualified Data.HashMap.Strict as HM
import Data.List.NonEmpty (NonEmpty)
import Data.Maybe (fromJust, isJust)
import Data.Scientific
import qualified Data.Validator.Draft4.Any as AN
import qualified Data.Validator.Draft4.Array as AR
import qualified Data.Validator.Draft4.Object as OB
import Data.Validator.Utils
data Schema = Schema
{ _schemaVersion :: Maybe Text
, _schemaId :: Maybe Text
, _schemaRef :: Maybe Text
, _schemaDefinitions :: Maybe (HashMap Text Schema)
, _schemaOther :: HashMap Text Value
, _schemaMultipleOf :: Maybe Scientific
, _schemaMaximum :: Maybe Scientific
, _schemaExclusiveMaximum :: Maybe Bool
, _schemaMinimum :: Maybe Scientific
, _schemaExclusiveMinimum :: Maybe Bool
, _schemaMaxLength :: Maybe Int
, _schemaMinLength :: Maybe Int
, _schemaPattern :: Maybe Text
, _schemaMaxItems :: Maybe Int
, _schemaMinItems :: Maybe Int
, _schemaUniqueItems :: Maybe Bool
, _schemaItems :: Maybe (AR.Items Schema)
, _schemaAdditionalItems :: Maybe (AR.AdditionalItems Schema)
, _schemaMaxProperties :: Maybe Int
, _schemaMinProperties :: Maybe Int
, _schemaRequired :: Maybe OB.Required
, _schemaDependencies :: Maybe (HashMap Text (OB.Dependency Schema))
, _schemaProperties :: Maybe (HashMap Text Schema)
, _schemaPatternProperties :: Maybe (HashMap Text Schema)
, _schemaAdditionalProperties :: Maybe (OB.AdditionalProperties Schema)
, _schemaEnum :: Maybe AN.EnumVal
, _schemaType :: Maybe AN.TypeVal
, _schemaAllOf :: Maybe (NonEmpty Schema)
, _schemaAnyOf :: Maybe (NonEmpty Schema)
, _schemaOneOf :: Maybe (NonEmpty Schema)
, _schemaNot :: Maybe Schema
} deriving (Eq, Show)
emptySchema :: Schema
emptySchema = Schema
{ _schemaVersion = Nothing
, _schemaId = Nothing
, _schemaRef = Nothing
, _schemaDefinitions = Nothing
, _schemaOther = mempty
, _schemaMultipleOf = Nothing
, _schemaMaximum = Nothing
, _schemaExclusiveMaximum = Nothing
, _schemaMinimum = Nothing
, _schemaExclusiveMinimum = Nothing
, _schemaMaxLength = Nothing
, _schemaMinLength = Nothing
, _schemaPattern = Nothing
, _schemaMaxItems = Nothing
, _schemaMinItems = Nothing
, _schemaUniqueItems = Nothing
, _schemaItems = Nothing
, _schemaAdditionalItems = Nothing
, _schemaMaxProperties = Nothing
, _schemaMinProperties = Nothing
, _schemaRequired = Nothing
, _schemaDependencies = Nothing
, _schemaProperties = Nothing
, _schemaPatternProperties = Nothing
, _schemaAdditionalProperties = Nothing
, _schemaEnum = Nothing
, _schemaType = Nothing
, _schemaAllOf = Nothing
, _schemaAnyOf = Nothing
, _schemaOneOf = Nothing
, _schemaNot = Nothing
}
instance FromJSON Schema where
parseJSON = withObject "Schema" $ \o -> do
a <- o .:! "$schema"
b <- o .:! "id"
c <- o .:! "$ref"
d <- o .:! "definitions"
e <- parseJSON (Object (HM.difference o internalSchemaHashMap))
f <- o .:! "multipleOf"
g <- o .:! "maximum"
h <- o .:! "exclusiveMaximum"
i <- o .:! "minimum"
j <- o .:! "exclusiveMinimum"
k <- o .:! "maxLength"
l <- o .:! "minLength"
m <- o .:! "pattern"
n <- o .:! "maxItems"
o' <- o .:! "minItems"
p <- o .:! "uniqueItems"
q <- o .:! "items"
r <- o .:! "additionalItems"
s <- o .:! "maxProperties"
t <- o .:! "minProperties"
u <- o .:! "required"
v <- o .:! "dependencies"
w <- o .:! "properties"
x <- o .:! "patternProperties"
y <- o .:! "additionalProperties"
z <- o .:! "enum"
a2 <- o .:! "type"
b2 <- fmap _unNonEmpty' <$> o .:! "allOf"
c2 <- fmap _unNonEmpty' <$> o .:! "anyOf"
d2 <- fmap _unNonEmpty' <$> o .:! "oneOf"
e2 <- o .:! "not"
pure Schema
{ _schemaVersion = a
, _schemaId = b
, _schemaRef = c
, _schemaDefinitions = d
, _schemaOther = e
, _schemaMultipleOf = f
, _schemaMaximum = g
, _schemaExclusiveMaximum = h
, _schemaMinimum = i
, _schemaExclusiveMinimum = j
, _schemaMaxLength = k
, _schemaMinLength = l
, _schemaPattern = m
, _schemaMaxItems = n
, _schemaMinItems = o'
, _schemaUniqueItems = p
, _schemaItems = q
, _schemaAdditionalItems = r
, _schemaMaxProperties = s
, _schemaMinProperties = t
, _schemaRequired = u
, _schemaDependencies = v
, _schemaProperties = w
, _schemaPatternProperties = x
, _schemaAdditionalProperties = y
, _schemaEnum = z
, _schemaType = a2
, _schemaAllOf = b2
, _schemaAnyOf = c2
, _schemaOneOf = d2
, _schemaNot = e2
}
instance ToJSON Schema where
toJSON s = Object $ HM.union (mapMaybe ($ s) internalSchemaHashMap)
(toJSON <$> _schemaOther s)
where
mapMaybe :: (v1 -> Maybe v2) -> HashMap k v1 -> HashMap k v2
mapMaybe f = fmap fromJust . HM.filter isJust . fmap f
internalSchemaHashMap :: HashMap Text (Schema -> Maybe Value)
internalSchemaHashMap = HM.fromList
[ ("$schema" , f _schemaVersion)
, ("id" , f _schemaId)
, ("$ref" , f _schemaRef)
, ("definitions" , f _schemaDefinitions)
, ("multipleOf" , f _schemaMultipleOf)
, ("maximum" , f _schemaMaximum)
, ("exclusiveMaximum" , f _schemaExclusiveMaximum)
, ("minimum" , f _schemaMinimum)
, ("exclusiveMinimum" , f _schemaExclusiveMinimum)
, ("maxLength" , f _schemaMaxLength)
, ("minLength" , f _schemaMinLength)
, ("pattern" , f _schemaPattern)
, ("maxItems" , f _schemaMaxItems)
, ("minItems" , f _schemaMinItems)
, ("uniqueItems" , f _schemaUniqueItems)
, ("items" , f _schemaItems)
, ("additionalItems" , f _schemaAdditionalItems)
, ("maxProperties" , f _schemaMaxProperties)
, ("minProperties" , f _schemaMinProperties)
, ("required" , f _schemaRequired)
, ("dependencies" , f _schemaDependencies)
, ("properties" , f _schemaProperties)
, ("patternProperties" , f _schemaPatternProperties)
, ("additionalProperties", f _schemaAdditionalProperties)
, ("enum" , f _schemaEnum)
, ("type" , f _schemaType)
, ("allOf" , f (fmap NonEmpty' . _schemaAllOf))
, ("anyOf" , f (fmap NonEmpty' . _schemaAnyOf))
, ("oneOf" , f (fmap NonEmpty' . _schemaOneOf))
, ("not" , f _schemaNot)
]
where
f :: ToJSON a => (Schema -> Maybe a) -> Schema -> Maybe Value
f = (fmap.fmap) toJSON
instance Arbitrary Schema where
arbitrary = sized f
where
maybeGen :: Gen a -> Gen (Maybe a)
maybeGen a = oneof [pure Nothing, Just <$> a]
maybeRecurse :: Int -> Gen a -> Gen (Maybe a)
maybeRecurse n a
| n < 1 = pure Nothing
| otherwise = maybeGen $ resize (n `div` 10) a
f :: Int -> Gen Schema
f n = do
a <- maybeGen arbitraryText
b <- maybeGen arbitraryText
c <- maybeGen arbitraryText
d <- pure Nothing
e <- pure mempty
f' <- maybeGen arbitraryPositiveScientific
g <- maybeGen arbitraryScientific
h <- arbitrary
i <- maybeGen arbitraryScientific
j <- arbitrary
k <- maybeGen (getPositive <$> arbitrary)
l <- maybeGen (getPositive <$> arbitrary)
m <- maybeGen arbitraryText
n' <- maybeGen (getPositive <$> arbitrary)
o <- maybeGen (getPositive <$> arbitrary)
p <- arbitrary
q <- maybeRecurse n arbitrary
r <- maybeRecurse n arbitrary
s <- maybeGen (getPositive <$> arbitrary)
t <- maybeGen (getPositive <$> arbitrary)
u <- arbitrary
v <- maybeRecurse n arbitraryHashMap
w <- maybeRecurse n arbitraryHashMap
x <- maybeRecurse n arbitraryHashMap
y <- maybeRecurse n arbitrary
z <- arbitrary
a2 <- arbitrary
b2 <- maybeRecurse n (_unNonEmpty' <$> arbitrary)
c2 <- maybeRecurse n (_unNonEmpty' <$> arbitrary)
d2 <- maybeRecurse n (_unNonEmpty' <$> arbitrary)
e2 <- maybeRecurse n arbitrary
pure Schema
{ _schemaVersion = a
, _schemaId = b
, _schemaRef = c
, _schemaDefinitions = d
, _schemaOther = e
, _schemaMultipleOf = f'
, _schemaMaximum = g
, _schemaExclusiveMaximum = h
, _schemaMinimum = i
, _schemaExclusiveMinimum = j
, _schemaMaxLength = k
, _schemaMinLength = l
, _schemaPattern = m
, _schemaMaxItems = n'
, _schemaMinItems = o
, _schemaUniqueItems = p
, _schemaItems = q
, _schemaAdditionalItems = r
, _schemaMaxProperties = s
, _schemaMinProperties = t
, _schemaRequired = u
, _schemaDependencies = v
, _schemaProperties = w
, _schemaPatternProperties = x
, _schemaAdditionalProperties = y
, _schemaEnum = z
, _schemaType = a2
, _schemaAllOf = b2
, _schemaAnyOf = c2
, _schemaOneOf = d2
, _schemaNot = e2
}