module JSONSchema.Draft4.Schema where import Import hiding (mapMaybe) import qualified Data.HashMap.Strict as HM import Data.List.NonEmpty (NonEmpty) import Data.Maybe (fromJust, isJust) import Data.Scientific import qualified Data.Set as Set import qualified Data.Text as T import qualified JSONSchema.Validator.Draft4 as D4 import JSONSchema.Validator.Utils data Schema = Schema { _schemaVersion :: Maybe Text , _schemaId :: Maybe Text , _schemaRef :: Maybe Text , _schemaDefinitions :: Maybe (HashMap Text Schema) -- ^ A standardized location for embedding schemas -- to be referenced from elsewhere in the document. , _schemaOther :: HashMap Text Value -- ^ Since the JSON document this schema was built from could -- contain schemas anywhere (not just in "definitions" or any -- of the other official keys) we save any leftover key/value -- pairs not covered by them here. -- -- TODO: This field is the source of most of the complication in this -- module and needs to be removed. It should be doable, though it will -- involve some modification to the fetching code. , _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 (D4.Items Schema) -- Note that '_schemaAdditionalItems' is left out of 'runValidate' -- because its functionality is handled by '_schemaItems'. It always -- validates data unless 'Items' is present. , _schemaAdditionalItems :: Maybe (D4.AdditionalItems Schema) , _schemaMaxProperties :: Maybe Int , _schemaMinProperties :: Maybe Int , _schemaRequired :: Maybe (Set Text) , _schemaDependencies :: Maybe (HashMap Text (D4.Dependency Schema)) , _schemaProperties :: Maybe (HashMap Text Schema) , _schemaPatternProperties :: Maybe (HashMap Text Schema) , _schemaAdditionalProperties :: Maybe (D4.AdditionalProperties Schema) , _schemaEnum :: Maybe (NonEmpty Value) , _schemaType :: Maybe D4.TypeValidator , _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 -- | The way we resolve JSON Pointers to embedded schemas is by -- serializing the containing schema to a value and then resolving the -- pointer against it. This means that FromJSON and ToJSON must be -- isomorphic. -- -- This influences the design choices in the library. E.g. right now -- there are two false values for "exclusiveMaximum" -- Nothing and -- Just False. We could have condensed them down by using () instead -- of Bool for "exclusiveMaximum". This would have made writing schemas -- in haskell easier, but we could no longer round trip through/from -- JSON without losing information. toJSON s = Object $ HM.union (mapMaybe ($ s) internalSchemaHashMap) (toJSON <$> _schemaOther s) where -- 'mapMaybe' is provided by unordered-containers after -- unordered-container-2.6.0.0, but until that is a little older -- (and has time to get into Stackage etc.) we use our own -- implementation. mapMaybe :: (v1 -> Maybe v2) -> HashMap k v1 -> HashMap k v2 mapMaybe f = fmap fromJust . HM.filter isJust . fmap f -- | Internal. Separate from ToJSON because it's also used -- by FromJSON to determine what keys aren't official schema -- keys and therefor should be included in _schemaOther. 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 -- NOTE: The next two fields are empty to generate cleaner -- schemas, but note that this means we don't test the -- invertability of these fields. d <- pure Nothing -- _schemaDefinitions e <- pure mempty -- _otherPairs 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 <- maybeGen (Set.map T.pack <$> arbitrary) v <- maybeRecurse n arbitraryHashMap w <- maybeRecurse n arbitraryHashMap x <- maybeRecurse n arbitraryHashMap y <- maybeRecurse n arbitrary z <- maybeRecurse n ( fmap _unArbitraryValue . _unNonEmpty' <$> 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 }