diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,3 @@ +# 1.0.0 + +- Initial release diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,101 @@ +# Medea + +## What is this? + +Medea is a schema language for JSON document structure. It is similar to [JSON +Schema][json-schema], but is designed to be simpler and more self-contained. + +This repo contains both a specification (in ``SPEC.md``) and a reference +implementation (in Haskell). We also have a [PureScript implementation available][medea-ps]. + +Medea is named after [Jason's wife][medea]. Additionally, the name reflects the +tensions between Jason and Medea as told in the legends, as told by the +[implementer of ``medea-ps``][ben]: + +> "I'm not sure if the name is because it loves JSON, or murdered all of JSON's kids +> and flew away in a chariot pulled by dragons." + +## Why Medea? + +Since JSON Schema exists, and has gone through a range of revisions, why does +Medea exist? There are several reasons for this, which we summarize below. + +### The JSON Schema standard is complex + +The current version of the JSON Schema standard (the 2019-09 draft at the time +of writing) is _highly_ complex. It, along with its adjacent standards, covers +considerably more than simply validating JSON documents. It also includes: + +* A MIME type for schema files +* Meta-schema information, including URI-based stuff +* Lexical and dynamic scope of keywords +* Sub-schemata and rules they follow +* Output formatting +* How to identify schemata via media type parameters + +Note that this is _before_ we get to anything to do with validating JSON! It is +perhaps unsurprising that no Haskell package exists which complies with the +current standard. Thus, we would have to develop something 'from scratch' in any +case. + +For our purposes, none of this was needed - we simply wanted to have a way to +describe the valid structure of a JSON document in textual form, and have a way +to use it as a cross-language tool for validating the structure of JSON. Medea +focuses on this, and _only_ this. + +### JSON Schema requires arbitrary URI resolution + +Due to the design of JSON Schema, schemata themselves have (meta) schemata. +These are indicated by use of URIs. Additionally, schemata can include other +schemata, in several different ways, _also_ indicating this by URIs. These URIs +can aim at basically arbitrary locations; in fact, multiple examples in the +standard(s) specify online locations where such information can be found. + +This essentially means that a compliant validator must be able to follow +_arbitrary_ URIs, or give users the ability to direct the validator. This isn't +even needed for _validation itself_ - we might need to do this just to know what +the schema is! Furthermore, as canonical examples require us to fetch +information from online (or have a means of users directing us there), any +validator we create would need to support fetching data from the Internet. + +While this can be useful, it puts considerable complexity on the part of both +the validator and the user. The use case that prompted the creation of Medea +didn't (and still doesn't) warrant this degree of complexity. This is not merely +a question of implementation time or dependency weight - it is also an issue of +correctness and usability. The design of Medea deliberately limits this - all +schemata are single, self-contained files. How these files are obtained, and +aimed at, is left to the user; if they need to fetch these from a remote +location or not should not be Medea's concern (and isn't). + +## Getting started + +For an easy starting point, check out ``TUTORIAL.md``, which describes basic usage +of Medea, with examples. For a more detailed description of Medea's capabilities +and schema language, ``SPEC.md`` has you covered. + +We also provide a collection of Medea schema files, designed for conformance +testing, in the ``conformance`` directory. + +## What does Medea work on? + +We support every major GHC version from 8.6 onwards, for its most current minor +version. At the moment, this means: + +* 8.6.5 +* 8.8.3 +* 8.10.1 + +We support both Stack and Cabal (v2) builds. We aim to be cross-platform where +possible - if the dependencies work on the platform, Medea should too. + +## License + +Medea's specification, as well as the Haskell (and PureScript) reference +implementations, are under the MIT license. Please see ``LICENSE.md`` for more +information. + +[json-schema]: https://en.wikipedia.org/wiki/JSON#JSON_Schema +[medea-ps]: https://github.com/juspay/medea-ps +[json-schema-validators]: https://json-schema.org/implementations.html#validators +[medea]: https://en.wikipedia.org/wiki/Medea +[ben]: https://github.com/Benjmhart diff --git a/SPEC.md b/SPEC.md new file mode 100644 --- /dev/null +++ b/SPEC.md @@ -0,0 +1,514 @@ +# Specification + +## Introduction + +This specification describes Medea, which is intended as a schema language for +describing and validating the structure of JSON documents. In particular, this +specification describes the following: + +* The human-readable representation of a Medea description of a JSON document + (that is, the _syntax_); +* The validation behaviour that is required from any given Medea construct (that + is, the _semantics_); and +* Any requirements or limitations, as precisely as possible. + +## Conventions + +The keywords MUST, MUST NOT, REQUIRED, SHALL, SHALL NOT, SHOULD, SHOULD NOT, +RECOMMENDED, MAY and OPTIONAL are to be interpreted as described in [RFC +2119][rfc2119]. + +_Compile time_ refers to the step when the human-readable representation of a +Medea description is being converted to a machine-usable form. _Validation time_ +refers to the step when, given a JSON document to validate and a machine-usable +form of a Medea description, validation of said document against said +description is requested. + +To _indicate a unique error condition_ means that the Medea validator MUST: + +* Demonstrate that it failed; and +* Have said demonstration be programmatically distinguishable from any + demonstration of another unique error condition. + +A Medea validator SHOULD use language-native means to indicate unique error +conditions (such as a language-specific error or exception), as opposed to use +of string error messages or output to the standard error stream. Unique error +conditions can be indicated both at compile time and validation time; if not +specified, they SHOULD be indicated at compile time. + +A _JSON value_ is taken to be defined: that is, ``undefined`` is not considered +to be a valid JSON value. A Medea validator MUST NOT indicate that an +``undefined`` value is valid against _any_ schema. + +A _newline_ is a platform-specific, non-empty sequence of bytes indicating the +end of a line. + +## Identifiers + +A Medea _identifier_ is a non-empty sequence of UTF-8 scalar values (as defined by +[definition D76 (pdf)][d76] of the Unicode 5.2 standard), not exceeding 32 bytes +in length, containing no symbols from categories [Zs, Zl, Zp or Cc][categories]. If +limited to text using the ASCII code points only, this means a limit of 32 +symbols. A Medea validator MUST indicate a unique error condition if given an +identifier that contains more than this number of symbols. + +### Reserved identifiers + +Any identifier starting with the symbol DOLLAR SIGN (hex code 0x24) is _reserved_. +Users MUST NOT define identifiers starting with DOLLAR SIGN, as they are used by +Medea validators internally. A Medea validator MAY fail if given a user-defined +identifier starting with DOLLAR SIGN; if it does so, it MUST indicate a +unique error condition. + +Unless stated otherwise, a Medea identifier is _non-reserved_. + +## Strings + +A Medea _string_ is a non-empty sequence of UTF-8 scalar values (as defined by +[definition D76 (pdf)][d76] of the Unicode 5.2 standard), containing no symbols +from categories [Zs, Zl, Zp or Cc][categories]. Furthermore, the first and last +symbol of a Medea string must both be QUOTATION MARK Unicode character (hex code +0x22). A Medea validator MUST indicate a unique error condition if given a +sequence of UTF-8 scalar values which has a QUOTATION MARK at the first and last +symbol, but contains symbols from any of Zs, Zl, Zp or Cc. + +## Natural numbers + +A Medea _natural number_ is a non-empty sequence of UTF-8 scalar values (as +defined by [definition D76 (pdf)][d76] of the Unicode 5.2 standard), containing +only symbols from DIGIT ZERO to DIGIT NINE inclusive (hex codes 0x30 to 0x39), +and not starting with DIGIT ZERO (hex code 0x30). A Medea validator SHOULD +indicate a unique error condition if it finds a sequence of DIGIT ZERO to DIGIT +NINE starting with DIGIT ZERO. + +The _value_ of a Medea natural number is the natural number which it textually +represents. + +## Primitive type + +A Medea _primitive type_ corresponds to a set of basic types, as provided by +JSON. These are defined as follows: + +* ``null``: The null value. +* ``boolean``: A non-null boolean (``true`` or ``false``). +* ``object``: A non-null JSON object. +* ``array``: A non-null JSON array. +* ``number``: A non-null JSON number. +* ``string``: A non-null JSON string. + +A Medea validator MUST provide validation of JSON values of these types, and +MUST provide the following _primitive type identifiers_: + +* ``$null`` +* ``$boolean`` +* ``$object`` +* ``$array`` +* ``$number`` +* ``$string`` + +## Schema graph file format + +A Medea _schema graph file_ is a human-readable representation of a Medea +specification. A Medea schema graph file MUST be encoded as UTF-8. A Medea validator MUST +indicate a unique error condition if asked to parse a schema graph file which is +not encoded as valid UTF-8. + +A Medea schema graph file SHOULD have the extension ``.medea``. + +A Medea file is made up of one or more _schemata_. A _schema_ (singular of +'schemata') MUST consist of the following, in this order: + +1. The reserved identifier ``$schema``; +2. A single space symbol; +3. A Medea identifier (called the _name_ or _naming identifier_); +4. A newline; and +5. Zero or more _specifications_ (defined fully in the subsequent section). + +A Medea validator MUST indicate a unique error condition if a schema is defined +with a name that has already been used as the naming identifier of an existing +schema in the same file. Additionally, a Medea validator MUST indicate a unique +error condition if the order, or formation rules, described above (or +subsequent in the case of type specifications or additional specifications) +are violated: each possible violation is distinct from any other. + +Additionally, a Medea graph file MUST contain a schema named ``$start``. A Medea +validator MUST indicate a unique error condition if no such schema is defined. + +Schemata MUST be separated by a single extra newline. Thus, a schema graph file +containing schemata ``foo`` and ``$start`` is formed like this: + +``` +$schema foo + +$schema $start +``` + +### Specifications + +Any schema can include any of the following specifications at most once, in any +order. Some specifications are conditional on others (noted in their +descriptions). A Medea validator MUST indicate a unique error condition if a +specification is provided for a schema where its conditions are not met. + +Each of the subsequent entries has the following format: + +* **Description:** An overview of the purpose and intended semantics of this + specification. +* **Preconditions:** Any requirements of the schema that MUST be met for this + type specifier to be valid. A Medea validator MUST indicate a unique error + condition when these are not met. +* **Syntax:** Describes the rules of form for this specification type. A Medea + validator MUST indicate a unique error condition if any of these are violated. +* **Semantics:** Describes how this specification affects the validation + behaviour of its schema. +* **Postconditions:** Any requirements or restrictions on the use of this type + specifier of a non-syntactic nature. A Medea validator MUST indicate a unique + error condition if any of these are violated. +* **Default:** Describes the validation behaviour of a schema missing this + specification. + +Certain combinations of specifications can produce contradictory requirements: +for example, a schema may have a type specification which requires a JSON object +with a property "foo" with a JSON string value, but then have an object property +specification saying that property "foo" should have a value which is a JSON array. +A Medea validator MUST indicate a unique error condition at compile time in such +situations. + +#### List specification + +**Description:** A _list specification_ describes the specifics of a JSON array +meant to serve as a list; that is, a homogenously-typed collection of varying +length. + +**Preconditions:** If the schema has a type specification, said type +specification must contain the type specifier line ``$array``. Additionally, the +schema must not contain a tuple specification. + +**Syntax:** A list specification MUST consist of one, or both, of the following, in any order: + +1. A _length specification_; and +2. An _element schema specification_. + +A length specification MUST consist of one, or both, of the following, in any order: + +1. A _minimum length specification_; and +2. A _maximum length specification_. + +An element schema specification MUST consist of the following, in this order: + +1. Four space symbols; +2. The reserved identifier ``$element-type``; +3. A space symbol; +4. _Either_ a Medea identifier, or one of ``$null``, ``$boolean``, ``$object``, + ``$array``, ``$number``, ``$string``; and +5. A newline. + +A minimum length specification MUST consist of the following, in this order: + +1. Four space symbols; +2. The reserved identifier ``$min-length``; +3. A single space symbol; +4. A Medea natural number; and +5. A newline. + +A maximum length specification MUST consist of the following, in this order: + +1. Four space symbols; +2. The reserved identifier ``$max-length``; +3. A single space symbol; +4. A Medea natural number; and +5. A newline. + +**Semantics:** A JSON value is considered valid by this specifier if it is a +JSON array. Additionally: + +* If an element schema specification is provided, every element of the array + must be valid, as defined by the following validation rules: + * ``$null``: The value is ``null``. + * ``$boolean``: The value is a JSON boolean. + * ``$object``: The value is a JSON object. + * ``$array``: The value is a JSON array. + * ``$number``: The value is a JSON number. + * ``$string``: The value is a JSON string. + * Any other identifier: The value is valid according to the schema named by + this identifier. +* If a minimum length specification is provided, the array must have at least as + many elements as the value of the Medea natural number in said specification. +* If a maximum length specification is provided, the array must _not_ have more + elements than the value of the Medea natural number in said specification. + +**Postconditions:** A Medea validatory MUST indicate a unique error condition if +the identifier in an element schema specification does not correspond to any +schema defined in the current schema file. + +If both a minimum length specification and a maximum length +specification are provided, a Medea validator MUST indicate a unique error +condition if the value of the Medea natural number in the minimum length +specification is greater than the value of the Medea natural number in the +maximum length specification. + +**Default:** An array may have any length (no minimum or maximum), and its +elements may be any JSON value. + +#### Object property specification + +**Description:** An _object property specification_ describes permitted +properties for an object, what schemata they must validate against, whether the +property is optional or required, and whether additional properties are allowed. + +**Preconditions:** If the schema has a type specification, said type +specification must contain the type specifier line ``$object``. + +**Syntax:** An object property specification MUST consist of the following, in +this order: + +1. Four space symbols; +2. The reserved identifier ``$properties``; +3. A newline; +4. Zero or more _object property specifier sections_; and +5. An optional _additional property declaration_. + +Each object property specifier section MUST consist of the following, in this +order: + +1. A _property name line_; and +2. An optional _property schema line_. +3. An optional _optional property declaration_. + +A property name line MUST consist of the following, in this order: + +1. Eight space symbols; +2. The reserved identifier ``$property-name``; +3. A single space symbol; +4. A Medea string; and +5. A newline. + +A property schema line MUST consist of the following, in this order: + +1. Eight space symbols; +2. The reserved identifier ``$property-schema``; +3. A single space symbol; +4. _Either_ a Medea identifier, or one of ``$null``, ``$boolean``, ``$object``, + ``$array``, ``$number``, ``$string``; and +5. A newline. + +An optional property declaration MUST consist of the following, in this order: + +1. Eight space symbols; +2. The reserved identifier ``$optional-property``; and +3. A newline. + +An additional property declaration MUST consist of the following, in this order: + +1. Eight space symbols; +2. The reserved identifier ``$additional-properties-allowed``; +3. A newline; +4. An optional _additional property schema line_. + +An additional property schema line MUST consist of the following, in this order: + +1. Eight space symbols; +2. The reserved identifier ``$additional-property-schema``; +3. A single space symbol; +4. _Either_ a Medea identifer, or one of ``$null``, ``$boolean``, ``$object``, + ``$array``, ``$number``, ``$string``; and +5. A newline. + +**Semantics:** A JSON value is considered valid by this specifier if it a JSON +object, and for each of its object property specifier sections, the following +all hold: + +* The object has a property whose name is the same as the Medea string given a + the property name line; +* If a corresponding property schema line is provided, the value of said + property is valid by the schema named by the identifier given in the property + schema line. +* If a corresponding optional property declaration is _not_ provided, said + property is defined (that is, is not ``undefined``). + +Furthermore, if the additional property declaration is _absent_, no property is defined +for the object _other_ than those given by some object property specifier +section. If the additional property declaration is present, any value of any +property _other_ than those given by some object property specifier section must +be valid by the schema named in the identifier given in its additional property +schema line (if present). + +A property value is always valid by no property schema line or no additional +property schema line. Otherwise, these validation rules apply, based on the +naming identifier: + +* ``$null``: The property value is `null`. +* ``$boolean``: The property value is a JSON boolean. +* ``$object``: The property value is a JSON object. +* ``$array``: The property value is a JSON array. +* ``$number``: The property value is a JSON number. +* ``$string``: The property value is a JSON string. +* Any other identifier: The property value is valid according to the schema + named by this identifier. + +**Postconditions:** A Medea validator MUST indicate a unique error condition if +an identifier in a property schema line or an additional property schema line +does not correspond to any schema defined in the current schema file. + +If multiple object property specifier sections have a property name line naming +the same schema, a Medea validator MUST indicate a unique error condition. + +**Default:** If an object property specification is not present at all, a JSON +object is considered valid regardless of its properties and their values. + +If an object property specification is present, but provides no additional +information (that is, no object property specifier sections and no additional +property permission), a JSON object is only considered valid if it is empty +(that is, it defines no properties at all). + +If an object property specifier contains a property name line, but no property +schema line, then, provided that the named property is defined, any value for +said property is considered valid. + +#### String value specification + +**Description:** A _string value specification_ describes which values a JSON string +is allowed to have. + +**Preconditions:** If the schema has a type specification, said type +specification must contain the type specifier line ``$string``. + +**Syntax:** A string value specification MUST consist of the following, in this +order: + +1. Four space symbols; +2. The reserved identifier ``$string-values``; +3. A newline; +4. One or more _string value lines_; and + +Each string value line MUST consist of the following, in this order: + +1. Eight space symbols; +2. A Medea string; and +3. A newline. + +**Semantics:** A JSON value is considered valid by this specifier if it is a +JSON string. Additionally, the value must be equal to _any_ of the Medea strings +in a string value line. + +**Postconditions:** A Medea validator MAY indicate a unique error condition at +compile time if two or more string value lines for the same string value +specifier are the same. + +**Default:** The JSON string may have any value. + +#### Tuple specification + +**Description:** A _tuple specification_ describes the specifics of a JSON array +meant to serve as a tuple; that is, a heterogenously-typed collection of fixed +length. + +**Preconditions:** If the schema has a type specification, said type +specification must contain the type specifier line ``$array``. Additionally, the +schema must not contain a list specification. + +**Syntax:** A tuple specification MUST consist of the following, in this order: + +1. Four space symbols; +2. The reserved identifier ``$tuple``; +3. A newline; and +4. Zero or more _positional schema specifications_. + +A positional schema specification MUST consist of the following, in this order: + +1. Eight space symbols; +2. _Either_ a Medea identifier, or one of ``$null``, ``$boolean``, ``$object``, + ``$array``, ``$number``, ``$string``; and +3. A newline. + +**Semantics:** A JSON value is considered valid by this specifier if it is a +JSON array. Additionally, let _p(1)_, _p(2)_, ..., _p(N)_ be each of the +positional specifications, in the order declared, where _N_ is the total number +of positional schema specifications. For each _i_ in 1, 2, ... _N_, element _i - +1_ of the array must be valid according to the following rules, based on the +Medea identifier used in _p(i)_: + +* ``$null``: The value is ``null``. +* ``$boolean``: The value is a JSON boolean. +* ``$object``: The value is a JSON object. +* ``$array``: The value is a JSON array. +* ``$number``: The value is a JSON number. +* ``$string``: The value is a JSON string. +* Any other identifier: The value is valid according to the schema named by this + identifier. + +Lastly, the array must have a length of _exactly_ _N_. + +**Postconditions:** A Medea validator MUST indicate a unique error condition if +an identifier in a positional schema specification does not correspond to any +schema defined in the curent schema file. + +**Default:** An array may have any length, and its elements may be any JSON +value. + +#### Type specification + +**Description:** A _type specification_ describes basic rules of form for JSON +values. + +**Preconditions:** None + +**Syntax:** A type specification MUST consist of the following, in this order: + +1. Four space symbols; +2. The reserved identifier ``$type``; +3. A newline; and +4. One or more _type specifier lines_. + +Each type specifier line MUST consist of the following, in this order: + +1. Eight space symbols; +2. _Either_ a Medea identifier, or one of ``$null``, ``$boolean``, ``$object``, + ``$array``, ``$number``, ``$string``; and +3. A newline. + +**Semantics:** A JSON value is considered valid by this specifier if it is valid +by _any_ of the identifiers provided for all of its type specifiers. For each +individual identifier, the following validation rules apply: + +* ``$null``: The JSON value is ``null`. +* ``$boolean``: The JSON value is a JSON boolean. +* ``$object``: The JSON value is a JSON object. +* ``$array``: The JSON value is a JSON array. +* ``$number``: The JSON value is a JSON number. +* ``$string``: The JSON value is a JSON string. +* Any other identifier: The JSON value is valid according to the schema named by + this identifier. + +**Postconditions:** Let _S, T_ be schemata in a single Medea schema graph i +file. We say that _S types as T_ if: + +* _S_ has a type specifier; and +* The type specifier of _S_ contains a type specifier line with the naming + identifier of _T_. + +For any schema _S_, the _typing neighbourhood of S_ (denoted _T(S)_) is the +transitive closure of the 'types as' relation for _S_. We say that schema _S_ is +_circularly-typed_ if _S_ is a member of _T(S)_. + +The type specifiers of a Medea schema graph file MUST NOT induce the circular +typing of any schema within it. A Medea validator MUST indicate a unique error +condition if a Medea graph file contains any schema _S_ such that _S_ is +circularly-typed. + +A Medea validator MUST indicate a unique error condition if an identifier in a +type specifier line does not correspond to any schema defined in the current +schema file. + +**Default:** Any JSON value is considered valid by this specifier. + +### Isolated schemata + +We say that a schema _S_ in a Medea schema graph file is _isolated_ when it is +not referred to by any specification in its Medea schema graph file. A Medea +validator SHOULD indicate a unique error condition if it detects any isolated +schemata. + +[d76]: http://www.unicode.org/versions/Unicode5.2.0/ch03.pdf#page=35 +[rfc2119]: https://tools.ietf.org/html/rfc2119 +[categories]: http://www.unicode.org/reports/tr44/tr44-14.html#GC_Values_Table diff --git a/TUTORIAL.md b/TUTORIAL.md new file mode 100644 --- /dev/null +++ b/TUTORIAL.md @@ -0,0 +1,310 @@ +# Medea Tutorial + +Medea is a simple schema language for specifying JSON, optimized for easily +describing Haskell and Purescript types. + +The system is ideal for describing: +- Javascript primitives (null, boolean, string, number, object, array) +- Sum types (multiple types permitted for the same property) +- Enums (one of a list of valid values for strings) +- Homogenously-typed arrays of variable length (with optional bounds) +- Tuples (heterogenously typed, fixed size collections) +- Maps (objects with 0 or more defined properties, and fixed types for + additional properties) + +In this tutorial, we'll explore the following topics: + +1. How to create a schema +2. Defining re-usable type schemas +3. Defining sum types +4. Null, boolean, and number types +5. String types +6. Array types +7. Object types +8. Library usage for validation + +## 1. How to specify a schema + +``` +$schema $start + $type + $object + $properties + $property-name "foo" + $property-schema $number + $additional-properties-allowed + $additional-property-schema $null +``` + +This is a simple JSON specification in Medea that: + +1. Defines the root type as ``object``; +2. Defines that we must have a property with name ``foo`` and type ``number``; +3. That additional properties beyond that are allowed; and +4. That any additional properties must be typed as ``null``. + +A JSON example that would be valid against the above schema is: + +```JSON +{ + "foo": 1, + "bar": null +} +``` + +However, the following would not be valid: + +```JSON +{ + "bar": null +} +``` + +The key concepts of Medea's syntax are: + +* Language keywords, including primitive types, begin with ``$``; +* Strict, four-space indentation is enforced; +* Trailing spaces are not allowed; +* String literals are wrapped in double-quotes; and +* Medea schemata are described in a Medea schema graph file, which has the + ``.medea`` extension. + +## 2. Defining re-usable type schemas + +The ``$schema`` keyword begins the definition of a single schema. There must be +a schema named ``$start``, which describes the validity conditions for the first +value in the JSON to be validated. A Medea schema graph file can contain +multiple schemata, separated by a single empty line: + +``` +$schema $start + $type + foo + +$schema foo + $type + $string +``` + +Schemata can refer to each other, as long as they are all within the same file. +We use a schema's name for this purpose. The above schemata together validate +any JSON consisting of a single string value; for example, this would be valid: + + +```JSON +"example value" +``` + +We can see that the schema name ``foo`` can be used in place of any type +argument. + +**NOTE:** Schemata can't declare themselves their own type. + +## 3. Defining sum types + +The ``$type`` keyword accepts a list of one or more primitive types, or defined +schemata: + +``` +$schema $start + $type + $array + $object +``` + +Here, our ``$start`` schema's allowed type is either a JSON array or a JSON +object. + +Listing a type in a schema allows us to also specify additional requirements of +values we validate, provided they have the corresponding type. For example, we +could modify the above schema to state that JSON objects which validate against +it must have certain properties of certain types, or JSON arrays must have a +minimum length. + +## 4. Primitive types + +Medea provides three primitive types which have no additional specification +options. These are ``$null``, ``$boolean`` and ``$number``, corresponding to the +JSON null value, any JSON boolean and any JSON number. These can be used +whenever a type is required. + +There are also three additional primitive types which have additional +specification options: ``$string``, ``$array`` and ``$object``, corresponding to +JSON strings, JSON arrays and JSON objects. In particular, ``$array`` gives us +two mutually-exclusive sets of additional options, depending on whether we want +the array to be treated as a _list_ (that is, a homogenously-typed collection of +varying length) or as a _tuple_ (that is, a heterogenously-typed collection of +fixed length). + +## 5. String types + +String types permit an optional specification defining a list of valid values +that the string may take: + +``` +$schema $start + $type + $string + $string-values + "foo" + "bar" + "baz" +``` + +The above schema validates a JSON string which is one of exactly ``"foo"``, +``"bar"`` or ``"baz"``. + +If you use the ``$string-values`` keyword, you must specify at least one value. +Only string literals are permitted. + +## 6. Array types + +Array types have two sets of mutually-exclusive additional options. One set, +called _list_ specifications, is designed to describe a JSON array which may +have a range of lengths, but all of whose elements are structurally similar. The +other set, called _tuple_ specifications, is designed to describe a JSON array +which has fixed length, but whose elements are structurally different (perhaps +dramatically). + +For an example of list specifications, the following schema validates only JSON +arrays with at least 3 elements, all of which must be strings: + +``` +$schema $start + $type + $array + $min-length 3 + $element-type $string +``` + +The ``$min-length`` and ``$max-length`` keywords are optional, and accept +positive integers. The ``$element-type`` keyword accepts one of either a +primitive type, or a defined schema. If you want an array whose elements may be +of multiple types (that is, effectively a list of sums), use a defined schema +with multiple types: + +``` +$schema $start + $type + $array + $element-type foo + +$schema foo + $type + $boolean + $number +``` + +Each of the keyword lines described for list specifications are optional, and +can be placed in any order. + +For an example of tuple specifications, the following schema validates JSON +arrays of length _exactly_ 3, such that the first element is a JSON string, the +second is a JSON boolean, and the third is the JSON ``null``: + +``` +$schema $start + $type + $array + $tuple + $string + $boolean + $null +``` + +The following JSON array would be valid against the above schema: + +```JSON +[ "hello", false, null ] +``` + +The ``$tuple`` keyword accepts any number of primitive types or defined +schemata. That list represents the number of elements an array must have, and +their types (or what they must validate against), in order. If given an empty +list, the only valid value is the empty array; specifically, given the following +schema: + +``` +$schema $start + $type + $array + $tuple +``` + +The _only_ JSON value valid against it is: + +```JSON +[] +``` + +7. Object Types + +The ``$object`` specification allows various ``$properties`` specifications. +Each such specification has the following options: + +1. ``$property-name`` describes the property name as a string. +2. ``$property-schema`` defines the primitive type or defined schema that the + named property's value must be valid by. +3. ``$optional-property`` describes whether the property is optional; if this is + present, objects missing this property will still be considered valid. + +These must be specified in sequential lines, in the above order. Additionally, +once all properties are specified, two additional keywords are available: + +1. ``$additional-properties-allowed``, which states that the previously-described + list of properties is not exhaustive; and +2. ``$additional-property-schema``, which describes what schema any additional + properties (beyond those described as above) must be valid against. + +The following is an exhaustive example of all these options: + +``` +$schema $start + $type + $object + $properties + $property-name "foo" + $property-schema foo + $property-name "bar" + $optional-property + $additional-properties-allowed + $additional-property-schema $number + +$schema foo + $type + $boolean + $null +``` + +This schema graph file validates JSON objects, which contain at _least_ the +property named ``foo``. It is allowed to contain additional properties; if a +property ``bar`` is defined, it is allowed to have any value, but any other +property must be a JSON number. The property named "foo" must have a value which +is either a JSON boolean or the JSON ``null``. + +## 8. Library usage for validation + +To validate a JSON value using Medea from Haskell: + +```Haskell +import Control.Monad.Trans.Except (runExcept, runExceptT) +import Data.Aeson (Value) +import Data.Medea.Loader (loadSchemaFromFile) +import Data.Medea (validate) + +main :: IO () +main = do + -- Compile a Medea schema graph from its file representation + result <- runExceptT . loadSchemaFromFile $ "./my-schema.medea" + case result of + Left e -> print e + Right scm -> do + -- Validate against the schema graph we just compiled + validation <- runExcept $ validate scm (myJson :: Value) + case validation of + Left e -> print e + Right _ -> putStrLn "JSON is valid against schema" +``` + +The result of a successful validation is an annotated JSON tree; we don't use it +here, but it can be useful as an intermediate processing input. diff --git a/medea.cabal b/medea.cabal new file mode 100644 --- /dev/null +++ b/medea.cabal @@ -0,0 +1,134 @@ +cabal-version: 2.2 +name: medea +version: 1.0.0 +synopsis: A schema language for JSON. +description: + A reference implementation of a schema language, together with a conformance + suite and a specification. + +homepage: https://github.com/juspay/medea +bug-reports: https://github.com/juspay/medea/issues +license: MIT +author: + Koz Ross, + Shaurya Gupta + +maintainer: koz.ross@retro-freedom.nz +copyright: Juspay Technologies Pvt Ltd (C) 2020 +category: Data +build-type: Simple +tested-with: GHC ==8.6.5 || ==8.8.3 || ==8.10.1 +extra-source-files: + CHANGELOG.md + README.md + SPEC.md + TUTORIAL.md + +source-repository head + type: git + location: https://github.com/juspay/medea.git + +common lang-common + default-language: Haskell2010 + ghc-options: + -Wall -Wcompat -Wincomplete-record-updates + -Wincomplete-uni-patterns -Wredundant-constraints + +common test-common + ghc-options: -O2 -threaded -with-rtsopts=-N + +library + import: lang-common + exposed-modules: Data.Medea + other-modules: + Data.Medea.Analysis + Data.Medea.JSONType + Data.Medea.Loader + Data.Medea.Parser.Primitive + Data.Medea.Parser.Spec.Array + Data.Medea.Parser.Spec.Object + Data.Medea.Parser.Spec.Property + Data.Medea.Parser.Spec.Schema + Data.Medea.Parser.Spec.Schemata + Data.Medea.Parser.Spec.String + Data.Medea.Parser.Spec.Type + Data.Medea.Parser.Types + Data.Medea.Schema + Data.Medea.ValidJSON + + build-depends: + , aeson ^>=1.4.6.0 + , algebraic-graphs ^>=0.5 + , base >=4.11.1 && <5 + , bytestring ^>=0.10.8.2 + , containers ^>=0.6.0.1 + , deepseq ^>=1.4.4.0 + , free ^>=5.1.3 + , hashable >=1.2.7.0 && <1.4.0.0 + , megaparsec ^>=8.0.0 + , microlens-ghc ^>=0.4.12 + , mtl ^>=2.2.2 + , nonempty-containers ^>=0.3.3.0 + , parser-combinators ^>=1.1.0 + , scientific ^>=0.3.6.2 + , text ^>=1.2.3.1 + , unordered-containers ^>=0.2.10.0 + , vector ^>=0.12.0.3 + , vector-instances ^>=3.4 + + hs-source-dirs: src + +test-suite conformance-parser + import: lang-common, test-common + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: TestM + build-depends: + , base + , directory ^>=1.3.3.0 + , filepath ^>=1.4.2.1 + , hspec ^>=2.7.1 + , medea + , mtl + + hs-source-dirs: test/parser test + +test-suite conformance-schema-builder + import: lang-common, test-common + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: TestM + build-depends: + , base + , directory ^>=1.3.3.0 + , filepath ^>=1.4.2.1 + , hspec ^>=2.7.1 + , medea + , mtl + + hs-source-dirs: test/schema-builder test + +test-suite quickcheck-validator + import: lang-common, test-common + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: + Data.Aeson.Arbitrary + TestM + + build-depends: + , aeson + , base + , directory ^>=1.3.3.0 + , filepath ^>=1.4.2.1 + , hspec ^>=2.7.1 + , hspec-core ^>=2.7.1 + , medea + , mtl + , QuickCheck ^>=2.13.2 + , quickcheck-instances ^>=0.3.22 + , text + , unordered-containers ^>=0.2.10.0 + , vector + + hs-source-dirs: test/validator-quickcheck test diff --git a/src/Data/Medea.hs b/src/Data/Medea.hs new file mode 100644 --- /dev/null +++ b/src/Data/Medea.hs @@ -0,0 +1,391 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TupleSections #-} + +-- | +-- Module: Data.Medea +-- Description: A JSON schema language validator. +-- Copyright: (C) Juspay Technologies Pvt Ltd, 2020 +-- License: MIT +-- Maintainer: koz.ross@retro-freedom.nz +-- Stability: Experimental +-- Portability: GHC only +-- +-- This module contains the reference Haskell implementation of a Medea +-- validator, providing both schema graph file loading and validation, with some +-- convenience functions. +-- +-- A minimal example of use follows. This example first attempts to load a Medea +-- schema graph file from @\/path\/to\/schema.medea@, and, if successful, attempts +-- to validate the JSON file at @\/path\/to\/my.json@ against the schemata so +-- loaded. +-- +-- > import Data.Medea (loadSchemaFromFile, validateFromFile) +-- > import Control.Monad.Except (runExceptT) +-- > +-- > main :: IO () +-- > main = do +-- > -- try to load the schema graph file +-- > loaded <- runExceptT . loadSchemaFromFile $ "/path/to/schema.medea" +-- > case loaded of +-- > Left err -> print err -- or some other handling +-- > Right scm -> do +-- > -- try to validate +-- > validated <- runExceptT . validateFromFile scm $ "/path/to/my.json" +-- > case validated of +-- > Left err -> print err -- or some other handling +-- > Right validJson -> print validJson -- or some other useful thing +-- +-- For more details about how to create Medea schema graph files, see +-- @TUTORIAL.md@ and @SPEC.md@. +module Data.Medea + ( -- * Schema loading + Schema, + LoaderError (..), + buildSchema, + loadSchemaFromFile, + loadSchemaFromHandle, + + -- * Schema validation + JSONType (..), + SchemaInformation (..), + ValidationError (..), + ValidatedJSON, + toValue, + validAgainst, + validate, + validateFromFile, + validateFromHandle, + ) +where + +import Control.Applicative ((<|>), Alternative) +import Control.Comonad.Cofree (Cofree (..)) +import Control.DeepSeq (NFData (..)) +import Control.Monad (MonadPlus, unless, when) +import Control.Monad.Except (MonadError (..)) +import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.Reader (MonadReader, asks, runReaderT) +import Control.Monad.State.Strict (MonadState (..), evalStateT, gets) +import Data.Aeson (Array, Object, Value (..), decode) +import qualified Data.ByteString.Lazy as BS +import Data.ByteString.Lazy (ByteString) +import Data.Coerce (coerce) +import Data.Data (Data) +import Data.Foldable (asum, traverse_) +import Data.Functor (($>)) +import qualified Data.HashMap.Strict as HM +import Data.Hashable (Hashable (..)) +import qualified Data.Map.Strict as M +import Data.Maybe (isNothing) +import Data.Medea.Analysis (ArrayType (..), CompiledSchema (..), TypeNode (..)) +import Data.Medea.JSONType (JSONType (..), typeOf) +import Data.Medea.Loader + ( LoaderError (..), + buildSchema, + loadSchemaFromFile, + loadSchemaFromHandle, + ) +import Data.Medea.Parser.Primitive (Identifier (..), ReservedIdentifier (..), identFromReserved) +import Data.Medea.Schema (Schema (..)) +import Data.Medea.ValidJSON (ValidJSONF (..)) +import qualified Data.Set as S +import Data.Set.NonEmpty + ( NESet, + dropWhileAntitone, + findMin, + member, + singleton, + ) +import Data.Text (Text) +import qualified Data.Vector as V +import GHC.Generics (Generic) +import System.IO (Handle, hSetBinaryMode) + +-- | An annotation, describing which schema a given chunk of JSON was deemed to +-- be valid against. +data SchemaInformation + = -- | No requirements were placed on this chunk. + AnySchema + | -- | Validated as JSON @null@. + NullSchema + | -- | Validated as JSON boolean. + BooleanSchema + | -- | Validated as JSON number. + NumberSchema + | -- | Validated as JSON string. + StringSchema + | -- | Validated as JSON array. + ArraySchema + | -- | Validated as JSON object. + ObjectSchema + | -- | Validated against the start schema. + StartSchema + | -- | Validated against the schema with the given name. + UserDefined {-# UNPACK #-} !Text + deriving stock (Eq, Data, Show, Generic) + deriving anyclass (Hashable, NFData) + +-- | JSON, annotated with what schemata it was deemed valid against. +newtype ValidatedJSON = ValidatedJSON (Cofree ValidJSONF SchemaInformation) + deriving stock (Data) + deriving newtype (Eq, Show) + +-- Can't coerce-erase the constructor fmap, sigh +instance NFData ValidatedJSON where + {-# INLINE rnf #-} + rnf (ValidatedJSON (x :< f)) = + rnf x `seq` (rnf . fmap ValidatedJSON $ f) + +-- Nor here +instance Hashable ValidatedJSON where + {-# INLINE hashWithSalt #-} + hashWithSalt salt (ValidatedJSON (x :< f)) = + salt `hashWithSalt` x `hashWithSalt` fmap ValidatedJSON f + +-- | Convert to an Aeson 'Value', throwing away all schema information. +toValue :: ValidatedJSON -> Value +toValue (ValidatedJSON (_ :< f)) = case f of + AnythingF v -> v + NullF -> Null + BooleanF b -> Bool b + NumberF n -> Number n + StringF s -> String s + ArrayF v -> Array . fmap (toValue . coerce) $ v + ObjectF hm -> Object . fmap (toValue . coerce) $ hm + +-- | What schema did this validate against? +validAgainst :: ValidatedJSON -> SchemaInformation +validAgainst (ValidatedJSON (label :< _)) = label -- TODO: This is a bit useless right now. + +-- | All possible validation errors. +data ValidationError + = EmptyError + | -- | We could not parse JSON out of what we were provided. + NotJSON + | -- | We got a type different to what we expected. + WrongType + !Value -- ^ The chunk of JSON. + !JSONType -- ^ What we expected the type to be. + | -- | We expected one of several possibilities, but got something that fits + -- none. + NotOneOfOptions !Value + | -- | We found a JSON object with a property that wasn't specified in its + -- schema, and additional properties are forbidden. + AdditionalPropFoundButBanned + {-# UNPACK #-} !Text -- ^ The property in question. + {-# UNPACK #-} !Text -- ^ The name of the specifying schema. + | -- | We found a JSON object which is missing a property its schema requires. + RequiredPropertyIsMissing + {-# UNPACK #-} !Text -- ^ The property in question. + {-# UNPACK #-} !Text -- ^ The name of the specifying schema. + | -- | We found a JSON array which falls outside of the minimum or maximum + -- length constraints its corresponding schema demands. + OutOfBoundsArrayLength + {-# UNPACK #-} !Text -- ^ The name of the specifying schema. + !Value -- ^ The JSON chunk corresponding to the invalid array. + | -- | This is a bug - please report it to us! + ImplementationError + {-# UNPACK #-} !Text -- some descriptive text + deriving stock (Eq, Show, Generic) + deriving anyclass (Hashable) + +instance Semigroup ValidationError where + EmptyError <> x = x + x <> _ = x + +instance Monoid ValidationError where + mempty = EmptyError + +-- | Attempt to construct validated JSON from a bytestring. +-- This will attempt to decode using Aeson before validating. +validate :: + (MonadPlus m, MonadError ValidationError m) => + Schema -> + ByteString -> + m ValidatedJSON +validate scm bs = case decode bs of + Nothing -> throwError NotJSON + Just v -> ValidatedJSON <$> go v + where + go v = runReaderT (evalStateT (checkTypes v) (initialSet, Nothing)) scm + initialSet = singleton . CustomNode . identFromReserved $ RStart + +-- | Helper for construction of validated JSON from a JSON file. +-- This will attempt to decode using Aeson before validating. +validateFromFile :: + (MonadPlus m, MonadError ValidationError m, MonadIO m) => + Schema -> + FilePath -> + m ValidatedJSON +validateFromFile scm fp = do + bs <- liftIO (BS.readFile fp) + validate scm bs + +-- | Helper for construction of validated JSON from a 'Handle'. +-- This will set the argument 'Handle' to binary mode, as this function won't +-- work otherwise. This function will close the 'Handle' once it finds EOF. +-- This will attempt to decode using Aeson before validating. +validateFromHandle :: + (MonadPlus m, MonadError ValidationError m, MonadIO m) => + Schema -> + Handle -> + m ValidatedJSON +validateFromHandle scm h = do + liftIO (hSetBinaryMode h True) + bs <- liftIO (BS.hGetContents h) + validate scm bs + +-- Helpers + +-- We have 3 different cases: +-- 1. If we are checking against AnyNode, we ALWAYS succeed. +-- 2. If we are checking against PrimitiveNode, we can match with EXACTLY ONE +-- kind of PrimitiveNode. +-- 3. If we are checking against CustomNode, we can match against ANY CustomNode. +-- Thus, we must try all of them. +checkTypes :: + (Alternative m, MonadReader Schema m, MonadState (NESet TypeNode, Maybe Identifier) m, MonadError ValidationError m) => + Value -> + m (Cofree ValidJSONF SchemaInformation) +checkTypes v = checkAny v <|> checkPrim v <|> checkCustoms v + +-- checkAny throws EmptyError if AnyNode is not found. This lets checkTypes +-- use the error thrown by checkPrim/checkCustoms if checkAny fails. +checkAny :: + (Alternative m, MonadState (NESet TypeNode, Maybe Identifier) m, MonadError ValidationError m) => + Value -> + m (Cofree ValidJSONF SchemaInformation) +checkAny v = do + minNode <- gets $ findMin . fst -- AnyNode is the smallest possible TypeNode. + case minNode of + AnyNode -> pure $ AnySchema :< AnythingF v + _ -> throwError EmptyError + +-- checkPrim searches the NESet for the PrimitiveNode corresponding to the Value, otherwise throws an error. +checkPrim :: + (Alternative m, MonadReader Schema m, MonadState (NESet TypeNode, Maybe Identifier) m, MonadError ValidationError m) => + Value -> + m (Cofree ValidJSONF SchemaInformation) +checkPrim v = do + (nodes, par) <- gets id + unless (member (PrimitiveNode . typeOf $ v) nodes) $ throwError . NotOneOfOptions $ v + case v of + Null -> pure $ NullSchema :< NullF + Bool b -> pure $ BooleanSchema :< BooleanF b + Number n -> pure $ NumberSchema :< NumberF n + String s -> case par of + -- if we are checking against a dependant string, we match against the supplied values + Nothing -> pure $ StringSchema :< StringF s + Just parIdent -> do + scm <- lookupSchema parIdent + let validVals = stringVals scm + if s `V.elem` validVals || null validVals + then pure $ StringSchema :< StringF s + else throwError $ NotOneOfOptions v + Array arr -> case par of + Nothing -> put (anySet, Nothing) >> (ArraySchema :<) . ArrayF <$> traverse checkTypes arr + Just parIdent -> checkArray arr parIdent + Object obj -> case par of + -- Fast Path (no object spec) + Nothing -> put (anySet, Nothing) >> (ObjectSchema :<) . ObjectF <$> traverse checkTypes obj + Just parIdent -> checkObject obj parIdent + +-- check if the array length is within the specification range. +checkArray :: + (Alternative m, MonadReader Schema m, MonadState (NESet TypeNode, Maybe Identifier) m, MonadError ValidationError m) => + Array -> + Identifier -> + m (Cofree ValidJSONF SchemaInformation) +checkArray arr parIdent = do + scm <- lookupSchema parIdent + let arrLen = fromIntegral $ V.length arr + when + ( maybe False (arrLen <) (minArrayLen scm) + || maybe False (arrLen >) (maxArrayLen scm) + ) + $ throwError . OutOfBoundsArrayLength (textify parIdent) . Array + $ arr + let valsAndTypes = pairValsWithTypes $ arrayTypes scm + checkedArray <- traverse (\(val, typeNode) -> put (singleton typeNode, Nothing) >> checkTypes val) valsAndTypes + pure $ ArraySchema :< ArrayF checkedArray + where + pairValsWithTypes Nothing = fmap (,AnyNode) arr + pairValsWithTypes (Just (ListType node)) = fmap (,node) arr + pairValsWithTypes (Just (TupleType nodes)) = V.zip arr nodes + +-- check if object properties satisfy the corresponding specification. +checkObject :: + (Alternative m, MonadReader Schema m, MonadState (NESet TypeNode, Maybe Identifier) m, MonadError ValidationError m) => + Object -> + Identifier -> + m (Cofree ValidJSONF SchemaInformation) +checkObject obj parIdent = do + valsAndTypes <- pairPropertySchemaAndVal obj parIdent + checkedObj <- traverse (\(val, typeNode) -> put (singleton typeNode, Nothing) >> checkTypes val) valsAndTypes + pure $ ObjectSchema :< ObjectF checkedObj + +pairPropertySchemaAndVal :: + (Alternative m, MonadReader Schema m, MonadError ValidationError m) => + HM.HashMap Text Value -> + Identifier -> + m (HM.HashMap Text (Value, TypeNode)) +pairPropertySchemaAndVal obj parIdent = do + scm <- lookupSchema parIdent + mappedObj <- traverse (pairProperty scm) $ HM.mapWithKey (,) obj + traverse_ isMatched . HM.mapWithKey (,) $ props scm + pure mappedObj + where + -- maps each property-value with the schema(typeNode) it should validate against + pairProperty scm (propName, v) = case HM.lookup propName $ props scm of + Just (typeNode, _) -> pure (v, typeNode) + Nothing + | additionalProps scm -> pure (v, additionalPropSchema scm) + | otherwise -> throwError . AdditionalPropFoundButBanned (textify parIdent) $ propName + -- throws ann error if a non-optional property was not found in the object + isMatched (propName, (_, optional)) = + when (isNothing (HM.lookup propName obj) && not optional) + $ throwError . RequiredPropertyIsMissing (textify parIdent) + $ propName + +-- checkCustoms removes all non custom nodes from the typeNode set and +-- checks the Value against each until one succeeds. +checkCustoms :: + (Alternative m, MonadReader Schema m, MonadState (NESet TypeNode, Maybe Identifier) m, MonadError ValidationError m) => + Value -> + m (Cofree ValidJSONF SchemaInformation) +checkCustoms v = do + -- Here we drop all non custom nodes. + customNodes <- gets $ dropWhileAntitone (not . isCustom) . fst + asum . fmap checkCustom . S.toList $ customNodes + where + -- Check value against successfors of a custom node. + checkCustom (CustomNode ident) = do + neighbourhood <- typesAs <$> lookupSchema ident + put (neighbourhood, Just ident) + ($> (UserDefined . textify $ ident)) <$> checkTypes v + checkCustom _ = throwError $ ImplementationError "Unreachable code: All these nodes MUST be custom." + +lookupSchema :: + (MonadReader Schema m, MonadError ValidationError m) => Identifier -> m CompiledSchema +lookupSchema ident = do + x <- asks $ M.lookup ident . compiledSchemata + case x of + Just scm -> pure scm + Nothing -> throwError . ImplementationError $ "Unreachable state: We should be able to find this schema" + +anySet :: NESet TypeNode +anySet = singleton AnyNode + +textify :: Identifier -> Text +textify (Identifier t) = t + +isCustom :: TypeNode -> Bool +isCustom (CustomNode _) = True +isCustom _ = False diff --git a/src/Data/Medea/Analysis.hs b/src/Data/Medea/Analysis.hs new file mode 100644 --- /dev/null +++ b/src/Data/Medea/Analysis.hs @@ -0,0 +1,302 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TupleSections #-} + +module Data.Medea.Analysis + ( AnalysisError (..), + ArrayType (..), + CompiledSchema (..), + TypeNode (..), + compileSchemata, + ) +where + +import Algebra.Graph.Acyclic.AdjacencyMap (toAcyclic) +import qualified Algebra.Graph.AdjacencyMap as Cyclic +import Control.Applicative ((<|>)) +import Control.Monad (foldM, when) +import Control.Monad.Except (MonadError (..)) +import Data.Coerce (coerce) +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HM +import qualified Data.List.NonEmpty as NEList +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as M +import Data.Maybe (isJust, isNothing, mapMaybe) +import Data.Medea.JSONType (JSONType (..)) +import Data.Medea.Parser.Primitive + ( Identifier, + MedeaString (..), + Natural, + PrimTypeIdentifier (..), + ReservedIdentifier (..), + identFromReserved, + isReserved, + isStartIdent, + tryPrimType, + typeOf, + ) +import Data.Medea.Parser.Spec.Array + ( elementType, + maxLength, + minLength, + tupleSpec, + ) +import Data.Medea.Parser.Spec.Object + ( additionalAllowed, + additionalSchema, + properties, + ) +import Data.Medea.Parser.Spec.Property (propName, propOptional, propSchema) +import qualified Data.Medea.Parser.Spec.Schema as Schema +import qualified Data.Medea.Parser.Spec.Schemata as Schemata +import qualified Data.Medea.Parser.Spec.String as String +import qualified Data.Medea.Parser.Spec.Type as Type +import qualified Data.Set as S +import Data.Set.NonEmpty (NESet) +import qualified Data.Set.NonEmpty as NESet +import Data.Text (Text) +import Data.Vector (Vector) +import qualified Data.Vector as V +import Prelude + +data AnalysisError + = DuplicateSchemaName !Identifier + | NoStartSchema + | DanglingTypeReference !Identifier !Identifier + | TypeRelationIsCyclic + | ReservedDefined !Identifier + | DefinedButNotUsed !Identifier + | MinMoreThanMax !Identifier + | DanglingTypeRefProp !Identifier !Identifier + | DanglingTypeRefList !Identifier !Identifier + | DanglingTypeRefTuple !Identifier !Identifier + | DuplicatePropName !Identifier !MedeaString + | PropertyWithoutObject !Identifier + | ListWithoutArray !Identifier + | TupleWithoutArray !Identifier + | StringValsWithoutString !Identifier + deriving stock (Eq, Show) + +data TypeNode + = AnyNode + | PrimitiveNode !JSONType + | CustomNode !Identifier + deriving stock (Eq, Ord, Show) + +data CompiledSchema = CompiledSchema + { schemaNode :: !TypeNode, + typesAs :: {-# UNPACK #-} !(NESet TypeNode), + minArrayLen :: !(Maybe Natural), + maxArrayLen :: !(Maybe Natural), + arrayTypes :: !(Maybe ArrayType), + props :: !(HashMap Text (TypeNode, Bool)), + additionalProps :: !Bool, + additionalPropSchema :: !TypeNode, + stringVals :: {-# UNPACK #-} !(Vector Text) + } + deriving stock (Eq, Show) + +data ArrayType + = ListType !TypeNode + | TupleType {-# UNPACK #-} !(Vector TypeNode) + deriving stock (Eq, Show) + +checkAcyclic :: + (MonadError AnalysisError m) => + Map Identifier CompiledSchema -> + m () +checkAcyclic m = + when (isNothing . toAcyclic . getTypesAsGraph $ m) $ + throwError TypeRelationIsCyclic + +compileSchemata :: + (MonadError AnalysisError m) => + Schemata.Specification -> + m (Map Identifier CompiledSchema) +compileSchemata (Schemata.Specification v) = do + m <- foldM go M.empty v + checkStartSchema m + checkDanglingReferences getTypeRefs DanglingTypeReference m + checkDanglingReferences getPropertyTypeRefs DanglingTypeRefProp m + checkDanglingReferences getListTypeRefs DanglingTypeRefList m + checkDanglingReferences getTupleTypeRefs DanglingTypeRefTuple m + checkUnusedSchemata m + checkAcyclic m + pure m + where + go acc spec = M.alterF (checkedInsert spec) (Schema.name spec) acc + checkedInsert spec = \case + Nothing -> Just <$> compileSchema spec + Just _ -> throwError . DuplicateSchemaName $ ident + where + ident = Schema.name spec + +compileSchema :: + (MonadError AnalysisError m) => + Schema.Specification -> + m CompiledSchema +compileSchema scm = do + when (isReserved schemaName && (not . isStartIdent) schemaName) + $ throwError . ReservedDefined + $ schemaName + let minListLen = minLength arraySpec + maxListLen = maxLength arraySpec + when (isJust minListLen && isJust maxListLen && minListLen > maxListLen) + $ throwError + $ MinMoreThanMax schemaName + propMap <- foldM go HM.empty (maybe V.empty properties objSpec) + let arrType = getArrayTypes (elementType arraySpec) (tupleSpec arraySpec) + tupleLen = getTupleTypeLen arrType + hasPropSpec = isJust objSpec + compiledScm = + CompiledSchema + { schemaNode = identToNode . Just $ schemaName, + typesAs = NESet.fromList . defaultToAny . V.toList . fmap (identToNode . Just) $ types, + minArrayLen = minListLen <|> tupleLen, + maxArrayLen = maxListLen <|> tupleLen, + arrayTypes = arrType, + props = propMap, + additionalProps = maybe True additionalAllowed objSpec, + additionalPropSchema = identToNode $ objSpec >>= additionalSchema, + stringVals = String.toReducedSpec stringValsSpec + } + when (shouldNotHavePropertySpec compiledScm hasPropSpec) + $ throwError . PropertyWithoutObject + $ schemaName + when (shouldNotHaveListSpec compiledScm) + $ throwError . ListWithoutArray + $ schemaName + when (shouldNotHaveTupleSpec compiledScm) + $ throwError . TupleWithoutArray + $ schemaName + when (shouldNotHaveStringSpec compiledScm) + $ throwError . StringValsWithoutString + $ schemaName + pure compiledScm + where + Schema.Specification schemaName (Type.Specification types) stringValsSpec arraySpec objSpec = + scm + go acc prop = HM.alterF (checkedInsert prop) (coerce $ propName prop) acc + checkedInsert prop = \case + Nothing -> pure . Just $ (identToNode (propSchema prop), propOptional prop) + Just _ -> throwError $ DuplicatePropName schemaName (propName prop) + defaultToAny :: [TypeNode] -> NEList.NonEmpty TypeNode + defaultToAny xs = case NEList.nonEmpty xs of + Nothing -> (NEList.:|) AnyNode [] + Just xs' -> xs' + +checkStartSchema :: + (MonadError AnalysisError m) => + Map Identifier CompiledSchema -> + m () +checkStartSchema m = case M.lookup (identFromReserved RStart) m of + Nothing -> throwError NoStartSchema + Just _ -> pure () + +-- We need a 'getRefs' argument here so that we can differentiate between +-- different kinds of Dangling references(type/property/list/tuple). +checkDanglingReferences :: + (MonadError AnalysisError m) => + (CompiledSchema -> [TypeNode]) -> + (Identifier -> Identifier -> AnalysisError) -> + Map Identifier CompiledSchema -> + m () +checkDanglingReferences getRefs err m = mapM_ go . M.toList $ m + where + go (schemaName, scm) = case getDanglingRefs scm of + danglingRef : _ -> throwError $ err danglingRef schemaName + [] -> pure () + getDanglingRefs = filter isUndefined . mapMaybe fromCustomNode . getRefs + isUndefined ident = isNothing . M.lookup ident $ m + fromCustomNode (CustomNode ident) = Just ident + fromCustomNode _ = Nothing + +checkUnusedSchemata :: + (MonadError AnalysisError m) => + Map Identifier CompiledSchema -> + m () +checkUnusedSchemata m = mapM_ checkUnused . M.keys $ m + where + checkUnused ident + | S.member (CustomNode ident) allReferences = pure () + | isStartIdent ident = pure () + | otherwise = throwError $ DefinedButNotUsed ident + allReferences = S.unions . fmap getReferences . M.elems $ m + getReferences scm = + S.fromList $ + getTypeRefs scm ++ getPropertyTypeRefs scm ++ getListTypeRefs scm ++ getTupleTypeRefs scm + +-- Helpers +identToNode :: Maybe Identifier -> TypeNode +identToNode ident = case ident of + Nothing -> AnyNode + Just t -> maybe (CustomNode t) (PrimitiveNode . typeOf) $ tryPrimType t + +getTypeRefs :: CompiledSchema -> [TypeNode] +getTypeRefs = NEList.toList . NESet.toList . typesAs + +getPropertyTypeRefs :: CompiledSchema -> [TypeNode] +getPropertyTypeRefs scm = (fmap fst . HM.elems . props $ scm) ++ [additionalPropSchema scm] + +getListTypeRefs :: CompiledSchema -> [TypeNode] +getListTypeRefs scm = case arrayTypes scm of + Just (ListType typeNode) -> [typeNode] + _ -> [] + +getTupleTypeRefs :: CompiledSchema -> [TypeNode] +getTupleTypeRefs scm = case arrayTypes scm of + Just (TupleType typeNodes) -> V.toList typeNodes + _ -> [] + +getArrayTypes :: Maybe Identifier -> Maybe [Identifier] -> Maybe ArrayType +getArrayTypes Nothing Nothing = Nothing +getArrayTypes (Just ident) _ = Just . ListType . identToNode . Just $ ident +getArrayTypes _ (Just idents) = + Just . TupleType . V.fromList $ identToNode . Just <$> idents + +getTupleTypeLen :: Maybe ArrayType -> Maybe Natural +getTupleTypeLen (Just (TupleType types)) = Just . fromIntegral . V.length $ types +getTupleTypeLen _ = Nothing + +getTypesAsGraph :: Map Identifier CompiledSchema -> Cyclic.AdjacencyMap TypeNode +getTypesAsGraph = Cyclic.edges . concatMap intoTypesAsEdges . M.elems + +intoTypesAsEdges :: CompiledSchema -> [(TypeNode, TypeNode)] +intoTypesAsEdges scm = fmap (schemaNode scm,) . NEList.toList . NESet.toList . typesAs $ scm + +arrayNode :: TypeNode +arrayNode = PrimitiveNode JSONArray + +objectNode :: TypeNode +objectNode = PrimitiveNode JSONObject + +stringNode :: TypeNode +stringNode = PrimitiveNode JSONString + +hasListSpec :: CompiledSchema -> Bool +hasListSpec scm = case arrayTypes scm of + Just (ListType _) -> True + Just (TupleType _) -> False + _ -> isJust $ minArrayLen scm <|> maxArrayLen scm + +hasTupleSpec :: CompiledSchema -> Bool +hasTupleSpec scm = case arrayTypes scm of + Just (TupleType _) -> True + _ -> False + +hasStringSpec :: CompiledSchema -> Bool +hasStringSpec = not . V.null . stringVals + +shouldNotHavePropertySpec :: CompiledSchema -> Bool -> Bool +shouldNotHavePropertySpec scm hasPropSpec = hasPropSpec && (not . NESet.member objectNode . typesAs $ scm) + +shouldNotHaveListSpec :: CompiledSchema -> Bool +shouldNotHaveListSpec scm = hasListSpec scm && (not . NESet.member arrayNode . typesAs $ scm) + +shouldNotHaveTupleSpec :: CompiledSchema -> Bool +shouldNotHaveTupleSpec scm = hasTupleSpec scm && (not . NESet.member arrayNode . typesAs $ scm) + +shouldNotHaveStringSpec :: CompiledSchema -> Bool +shouldNotHaveStringSpec scm = hasStringSpec scm && (not . NESet.member stringNode . typesAs $ scm) diff --git a/src/Data/Medea/JSONType.hs b/src/Data/Medea/JSONType.hs new file mode 100644 --- /dev/null +++ b/src/Data/Medea/JSONType.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE LambdaCase #-} + +module Data.Medea.JSONType + ( JSONType (..), + typeOf, + ) +where + +import Data.Aeson (Value (..)) +import Data.Hashable (Hashable) +import GHC.Generics (Generic) + +-- | The basic types of JSON value (as per +-- [ECMA-404](http://www.ecma-international.org/publications/files/ECMA-ST/ECMA-404.pdf)). +data JSONType + = JSONNull + | JSONBoolean + | JSONNumber + | JSONString + | JSONArray + | JSONObject + deriving stock (Eq, Ord, Show, Generic) + deriving anyclass (Hashable) + +-- | Helper for determining the type of an Aeson 'Value'. +typeOf :: Value -> JSONType +typeOf = \case + Object _ -> JSONObject + Array _ -> JSONArray + String _ -> JSONString + Number _ -> JSONNumber + Bool _ -> JSONBoolean + Null -> JSONNull diff --git a/src/Data/Medea/Loader.hs b/src/Data/Medea/Loader.hs new file mode 100644 --- /dev/null +++ b/src/Data/Medea/Loader.hs @@ -0,0 +1,180 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} + +module Data.Medea.Loader + ( LoaderError (..), + buildSchema, + loadSchemaFromFile, + loadSchemaFromHandle, + ) +where + +import Control.Monad.Except (MonadError (..), runExcept) +import Control.Monad.IO.Class (MonadIO (..)) +import Data.ByteString (ByteString, hGetContents, readFile) +import qualified Data.List.NonEmpty as NE +import Data.Medea.Analysis + ( AnalysisError (..), + compileSchemata, + ) +import Data.Medea.Parser.Primitive (toText, unwrap) +import qualified Data.Medea.Parser.Spec.Schemata as Schemata +import Data.Medea.Schema (Schema (..)) +import Data.Text (Text) +import Data.Text.Encoding (decodeUtf8') +import Data.Void (Void) +import System.IO (Handle) +import Text.Megaparsec (ParseError (..), bundleErrors, parse) +import Prelude hiding (readFile) + +-- | Possible errors from loading Medea schemata. +data LoaderError + = -- | The data provided wasn't UTF-8. + NotUtf8 + | -- | An identifier was longer than allowed. + IdentifierTooLong + | -- | A length specification had no minimum/maximum specification. + EmptyLengthSpec + | -- | Parsing failed. + ParserError + !(ParseError Text Void) -- ^ The error we got. + | -- | No schema labelled @$start@ was provided. + StartSchemaMissing + | -- | A schema was typed in terms of itself. + SelfTypingSchema + | -- | A schema was defined more than once. + MultipleSchemaDefinition + {-# UNPACK #-} !Text -- ^ The multiply-defined schema name. + | -- | We expected a schema, but couldn't find it. + MissingSchemaDefinition + {-# UNPACK #-} !Text -- ^ Name of the schema we were expecting. + {-# UNPACK #-} !Text -- ^ Name of the schema that referenced it. + | -- | A schema was named with a reserved identifier (other than @start@). + SchemaNameReserved + {-# UNPACK #-} !Text -- ^ The schema name. + | -- | An isolated schema was found. + IsolatedSchemata + {-# UNPACK #-} !Text -- ^ The schema name. + | -- | A property schema refers to a non-existent schema. + MissingPropSchemaDefinition + {-# UNPACK #-} !Text -- ^ Name of the non-existent schema being referenced. + {-# UNPACK #-} !Text -- ^ Name of the referencing schema. + | -- | A minimum length specification was more than its corresponding + -- maximum length specification. + MinimumLengthGreaterThanMaximum + {-# UNPACK #-} !Text -- ^ The name of the schema with the faulty specification. + | -- | A property was specified more than once. + MultiplePropSchemaDefinition + {-# UNPACK #-} !Text -- ^ Name of the parent schema. + {-# UNPACK #-} !Text -- ^ Name of the property that was defined more than once. + | -- | A list specification did not provide an element type. + MissingListSchemaDefinition + {-# UNPACK #-} !Text -- ^ Name of the missing list element type schema. + {-# UNPACK #-} !Text -- ^ Name of the parent schema. + | -- | A tuple specification does not provide a positional schema. + MissingTupleSchemaDefinition + {-# UNPACK #-} !Text -- ^ Name of the missing tuple positional schema. + {-# UNPACK #-} !Text -- ^ Name of the parent schema. + | -- | Schema had a property specification, but no @$object@ type. + PropertySpecWithoutObjectType + {-# UNPACK #-} !Text -- ^ Schema name. + | -- | Schema had a list specification, but no @$array@ type. + ListSpecWithoutArrayType + {-# UNPACK #-} !Text -- ^ Schema name. + | -- | Schema had a tuple specification, but no @$array@ type. + TupleSpecWithoutArrayType + {-# UNPACK #-} !Text -- ^ Schema name. + | -- | Schema had a string specification, but no @$string@ type. + StringSpecWithoutStringType + {-# UNPACK #-} !Text -- ^ Schema name. + deriving stock (Eq, Show) + +-- | Attempt to produce a schema from UTF-8 data in memory. +buildSchema :: + (MonadError LoaderError m) => + ByteString -> + m Schema +buildSchema bs = do + utf8 <- parseUtf8 bs + spec <- fromUtf8 ":memory:" utf8 + analyze spec + +-- | Parse and process a Medea schema graph file. +loadSchemaFromFile :: + (MonadIO m, MonadError LoaderError m) => + FilePath -> + m Schema +loadSchemaFromFile fp = do + contents <- liftIO . readFile $ fp + utf8 <- parseUtf8 contents + spec <- fromUtf8 fp utf8 + analyze spec + +-- | Load data corresponding to a Medea schema graph file from a 'Handle'. +loadSchemaFromHandle :: + (MonadIO m, MonadError LoaderError m) => + Handle -> + m Schema +loadSchemaFromHandle h = do + contents <- liftIO . hGetContents $ h + utf8 <- parseUtf8 contents + spec <- fromUtf8 (show h) utf8 + analyze spec + +-- Helper + +parseUtf8 :: + (MonadError LoaderError m) => + ByteString -> + m Text +parseUtf8 = either (const (throwError NotUtf8)) pure . decodeUtf8' + +fromUtf8 :: + (MonadError LoaderError m) => + String -> + Text -> + m Schemata.Specification +fromUtf8 sourceName utf8 = + case parse Schemata.parseSpecification sourceName utf8 of + Left err -> case NE.head . bundleErrors $ err of + TrivialError o u e -> + throwError . ParserError . TrivialError o u $ e + -- TODO: Handle all kinds of ParseError + FancyError {} -> throwError IdentifierTooLong + Right scm -> pure scm + +analyze :: + (MonadError LoaderError m) => + Schemata.Specification -> + m Schema +analyze scm = case runExcept $ compileSchemata scm of + Left (DuplicateSchemaName ident) -> + throwError $ MultipleSchemaDefinition (toText ident) + Left NoStartSchema -> throwError StartSchemaMissing + Left (DanglingTypeReference danglingRef parSchema) -> + throwError $ MissingSchemaDefinition (toText danglingRef) (toText parSchema) + Left TypeRelationIsCyclic -> throwError SelfTypingSchema + Left (ReservedDefined ident) -> + throwError $ SchemaNameReserved (toText ident) + Left (DefinedButNotUsed ident) -> + throwError $ IsolatedSchemata (toText ident) + Left (DanglingTypeRefProp danglingRef parSchema) -> + throwError $ MissingPropSchemaDefinition (toText danglingRef) (toText parSchema) + Left (MinMoreThanMax ident) -> + throwError $ MinimumLengthGreaterThanMaximum (toText ident) + Left (DuplicatePropName ident prop) -> + throwError $ + MultiplePropSchemaDefinition (toText ident) (unwrap prop) + Left (DanglingTypeRefList danglingRef parSchema) -> + throwError $ MissingListSchemaDefinition (toText danglingRef) (toText parSchema) + Left (DanglingTypeRefTuple danglingRef parSchema) -> + throwError $ MissingTupleSchemaDefinition (toText danglingRef) (toText parSchema) + Left (PropertyWithoutObject schema) -> + throwError $ PropertySpecWithoutObjectType (toText schema) + Left (ListWithoutArray schema) -> + throwError $ ListSpecWithoutArrayType (toText schema) + Left (TupleWithoutArray schema) -> + throwError $ TupleSpecWithoutArrayType (toText schema) + Left (StringValsWithoutString schema) -> + throwError $ StringSpecWithoutStringType (toText schema) + Right g -> pure . Schema $ g diff --git a/src/Data/Medea/Parser/Primitive.hs b/src/Data/Medea/Parser/Primitive.hs new file mode 100644 --- /dev/null +++ b/src/Data/Medea/Parser/Primitive.hs @@ -0,0 +1,187 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} + +module Data.Medea.Parser.Primitive + ( Identifier (..), + MedeaString (..), + Natural, + PrimTypeIdentifier (..), + ReservedIdentifier (..), + identFromReserved, + isReserved, + isStartIdent, + parseIdentifier, + parseKeyVal, + parseLine, + parseNatural, + parseReserved, + parseString, + tryPrimType, + ) +where + +import Control.Monad (replicateM_, when) +import qualified Data.ByteString as BS +import Data.Char (isControl, isDigit, isSeparator) +import Data.Hashable (Hashable (..)) +import Data.Maybe (isJust) +import Data.Medea.JSONType (JSONType (..)) +import Data.Medea.Parser.Types (MedeaParser, ParseError (..)) +import Data.Text (Text, head, pack, unpack) +import Data.Text.Encoding (encodeUtf8) +import Text.Megaparsec + ( customFailure, + manyTill, + takeWhile1P, + ) +import Text.Megaparsec.Char (char, eol) +import Text.Megaparsec.Char.Lexer (charLiteral) +import Prelude hiding (head) + +-- Identifier +newtype Identifier = Identifier {toText :: Text} + deriving newtype (Eq, Ord, Show) + +parseIdentifier :: MedeaParser Identifier +parseIdentifier = do + ident <- takeWhile1P (Just "Non-separator") (not . isSeparatorOrControl) + checkedConstruct Identifier ident + +data ReservedIdentifier + = RSchema + | RStart + | RType + | RStringValues + | RProperties + | RPropertyName + | RPropertySchema + | RAdditionalPropertiesAllowed + | RAdditionalPropertySchema + | ROptionalProperty + | RMinLength + | RMaxLength + | RElementType + | RTuple + | RArray + | RBoolean + | RNull + | RNumber + | RObject + | RString + deriving stock (Eq, Show) + +fromReserved :: ReservedIdentifier -> Text +fromReserved RSchema = "$schema" +fromReserved RStart = "$start" +fromReserved RType = "$type" +fromReserved RStringValues = "$string-values" +fromReserved RProperties = "$properties" +fromReserved RPropertyName = "$property-name" +fromReserved RPropertySchema = "$property-schema" +fromReserved RAdditionalPropertiesAllowed = "$additional-properties-allowed" +fromReserved RAdditionalPropertySchema = "$additional-property-schema" +fromReserved ROptionalProperty = "$optional-property" +fromReserved RMinLength = "$min-length" +fromReserved RMaxLength = "$max-length" +fromReserved RElementType = "$element-type" +fromReserved RTuple = "$tuple" +fromReserved RArray = "$array" +fromReserved RBoolean = "$boolean" +fromReserved RNull = "$null" +fromReserved RNumber = "$number" +fromReserved RObject = "$object" +fromReserved RString = "$string" + +identFromReserved :: ReservedIdentifier -> Identifier +identFromReserved = Identifier . fromReserved + +tryReserved :: Text -> Maybe ReservedIdentifier +tryReserved "$schema" = Just RSchema +tryReserved "$start" = Just RStart +tryReserved "$type" = Just RType +tryReserved "$string-values" = Just RStringValues +tryReserved "$properties" = Just RProperties +tryReserved "$property-name" = Just RPropertyName +tryReserved "$property-schema" = Just RPropertySchema +tryReserved "$additional-properties-allowed" = Just RAdditionalPropertiesAllowed +tryReserved "$additional-property-schema" = Just RAdditionalPropertySchema +tryReserved "$optional-property" = Just ROptionalProperty +tryReserved "$min-length" = Just RMinLength +tryReserved "$max-length" = Just RMaxLength +tryReserved "$element-type" = Just RElementType +tryReserved "$tuple" = Just RTuple +tryReserved "$array" = Just RArray +tryReserved "$boolean" = Just RBoolean +tryReserved "$null" = Just RNull +tryReserved "$number" = Just RNumber +tryReserved "$object" = Just RObject +tryReserved "$string" = Just RString +tryReserved _ = Nothing + +parseReserved :: ReservedIdentifier -> MedeaParser Identifier +parseReserved reserved = do + ident <- takeWhile1P Nothing (not . isSeparatorOrControl) + let reservedText = fromReserved reserved + when (ident /= reservedText) $ customFailure . ExpectedReservedIdentifier $ reservedText + checkedConstruct Identifier ident + +newtype PrimTypeIdentifier = PrimTypeIdentifier {typeOf :: JSONType} + deriving newtype (Eq) + +tryPrimType :: Identifier -> Maybe PrimTypeIdentifier +tryPrimType (Identifier ident) = tryReserved ident >>= reservedToPrim + +reservedToPrim :: ReservedIdentifier -> Maybe PrimTypeIdentifier +reservedToPrim RNull = Just . PrimTypeIdentifier $ JSONNull +reservedToPrim RBoolean = Just . PrimTypeIdentifier $ JSONBoolean +reservedToPrim RObject = Just . PrimTypeIdentifier $ JSONObject +reservedToPrim RArray = Just . PrimTypeIdentifier $ JSONArray +reservedToPrim RNumber = Just . PrimTypeIdentifier $ JSONNumber +reservedToPrim RString = Just . PrimTypeIdentifier $ JSONString +reservedToPrim _ = Nothing + +isReserved :: Identifier -> Bool +isReserved = isJust . tryReserved . toText + +isStartIdent :: Identifier -> Bool +isStartIdent = (== Just RStart) . tryReserved . toText + +-- Natural Number +type Natural = Word + +parseNatural :: MedeaParser Natural +parseNatural = do + digits <- takeWhile1P (Just "digits") isDigit + when (head digits == '0') + $ customFailure . LeadingZero + $ digits + pure . read . unpack $ digits + +-- String +newtype MedeaString = MedeaString {unwrap :: Text} + deriving newtype (Eq, Ord, Show, Hashable) + +parseString :: MedeaParser MedeaString +parseString = do + string <- char '"' *> manyTill charLiteral (char '"') + pure . MedeaString . pack $ string + +{-# INLINE parseLine #-} +parseLine :: Int -> MedeaParser a -> MedeaParser a +parseLine spaces p = replicateM_ spaces (char ' ') *> p <* eol + +parseKeyVal :: ReservedIdentifier -> MedeaParser a -> MedeaParser a +parseKeyVal key = (parseReserved key *> char ' ' *>) + +-- Helpers +checkedConstruct :: + (Text -> a) -> Text -> MedeaParser a +checkedConstruct f t = + if (> 32) . BS.length . encodeUtf8 $ t + then customFailure . IdentifierTooLong $ t + else pure . f $ t + +isSeparatorOrControl :: Char -> Bool +isSeparatorOrControl c = isSeparator c || isControl c diff --git a/src/Data/Medea/Parser/Spec/Array.hs b/src/Data/Medea/Parser/Spec/Array.hs new file mode 100644 --- /dev/null +++ b/src/Data/Medea/Parser/Spec/Array.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} + +module Data.Medea.Parser.Spec.Array + ( Specification (..), + defaultSpec, + parseSpecification, + ) +where + +import Control.Applicative ((<|>)) +import Control.Applicative.Permutations (runPermutation, toPermutationWithDefault) +import Data.Medea.Parser.Primitive + ( Identifier, + Natural, + ReservedIdentifier (..), + parseIdentifier, + parseKeyVal, + parseLine, + parseNatural, + parseReserved, + ) +import Data.Medea.Parser.Types (MedeaParser, ParseError (..)) +import Text.Megaparsec (MonadParsec (..), customFailure, many, try) + +data Specification = Specification + { minLength :: !(Maybe Natural), + maxLength :: !(Maybe Natural), + elementType :: !(Maybe Identifier), + tupleSpec :: !(Maybe [Identifier]) + } + deriving stock (Eq, Show) + +-- tupleSpec with an empty list indicates an empty tuple/encoding of unit +-- tupleSpec of Nothing indicates that there is no tuple spec at all + +defaultSpec :: Specification +defaultSpec = Specification Nothing Nothing Nothing Nothing + +parseSpecification :: MedeaParser Specification +parseSpecification = do + spec <- try permute + case spec of + Specification Nothing Nothing Nothing Nothing -> + -- the user must specify length, or a type, or a tuple spec + customFailure EmptyLengthArraySpec + Specification _ _ (Just _) (Just _) -> + -- the user has defined both element type and tuple. + -- this is illegal behaviour + customFailure ConflictingSpecRequirements + Specification (Just _) _ _ (Just _) -> + -- the user cannot specify length and tuples + customFailure ConflictingSpecRequirements + Specification _ (Just _) _ (Just _) -> + customFailure ConflictingSpecRequirements + _ -> pure spec + where + permute = + runPermutation $ + Specification + <$> toPermutationWithDefault Nothing (try parseMinSpec) + <*> toPermutationWithDefault Nothing (try parseMaxSpec) + <*> toPermutationWithDefault Nothing (try parseElementType) + <*> toPermutationWithDefault Nothing (try parseTupleSpec) + +parseMinSpec :: MedeaParser (Maybe Natural) +parseMinSpec = + parseLine 4 $ Just <$> parseKeyVal RMinLength parseNatural + +parseMaxSpec :: MedeaParser (Maybe Natural) +parseMaxSpec = + parseLine 4 $ Just <$> parseKeyVal RMaxLength parseNatural + +parseElementType :: MedeaParser (Maybe Identifier) +parseElementType = do + _ <- parseLine 4 $ parseReserved RElementType + element <- parseLine 8 parseIdentifier <|> customFailure EmptyArrayElements + pure $ Just element + +parseTupleSpec :: MedeaParser (Maybe [Identifier]) +parseTupleSpec = do + _ <- parseLine 4 $ parseReserved RTuple + elemList <- many $ try $ parseLine 8 parseIdentifier + pure $ Just elemList diff --git a/src/Data/Medea/Parser/Spec/Object.hs b/src/Data/Medea/Parser/Spec/Object.hs new file mode 100644 --- /dev/null +++ b/src/Data/Medea/Parser/Spec/Object.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} + +module Data.Medea.Parser.Spec.Object + ( Specification (..), + parseSpecification, + ) +where + +import Control.Monad (when) +import Data.Functor (($>)) +import Data.Maybe (isJust) +import Data.Medea.Parser.Primitive + ( Identifier, + ReservedIdentifier (..), + parseIdentifier, + parseKeyVal, + parseLine, + parseReserved, + ) +import qualified Data.Medea.Parser.Spec.Property as Property +import Data.Medea.Parser.Types (MedeaParser, ParseError (..)) +import Data.Vector (Vector) +import qualified Data.Vector as V +import Text.Megaparsec + ( MonadParsec (..), + customFailure, + many, + option, + try, + ) + +data Specification = Specification + { properties :: {-# UNPACK #-} !(Vector Property.Specification), + additionalAllowed :: !Bool, + additionalSchema :: !(Maybe Identifier) + } + deriving stock (Eq) + +parseSpecification :: MedeaParser Specification +parseSpecification = do + _ <- parseLine 4 (parseReserved RProperties) + props <- parseProperties + additionalAllowed' <- parseAdditionalAllowed + additionalSchema' <- parseAdditionalSchema + when (not additionalAllowed' && isJust additionalSchema') $ + customFailure ConflictingSpecRequirements + pure $ Specification props additionalAllowed' additionalSchema' + +parseProperties :: MedeaParser (Vector Property.Specification) +parseProperties = V.fromList <$> many (try Property.parseSpecification) + +parseAdditionalAllowed :: MedeaParser Bool +parseAdditionalAllowed = + option False . try . parseLine 8 $ + parseReserved RAdditionalPropertiesAllowed $> True + +parseAdditionalSchema :: MedeaParser (Maybe Identifier) +parseAdditionalSchema = + option Nothing . fmap Just . try . parseLine 8 $ + parseKeyVal RAdditionalPropertySchema parseIdentifier diff --git a/src/Data/Medea/Parser/Spec/Property.hs b/src/Data/Medea/Parser/Spec/Property.hs new file mode 100644 --- /dev/null +++ b/src/Data/Medea/Parser/Spec/Property.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} + +module Data.Medea.Parser.Spec.Property + ( Specification (..), + parseSpecification, + ) +where + +import Data.Functor (($>)) +import Data.Medea.Parser.Primitive + ( Identifier, + MedeaString, + ReservedIdentifier (..), + parseIdentifier, + parseKeyVal, + parseLine, + parseReserved, + parseString, + ) +import Data.Medea.Parser.Types (MedeaParser) +import Text.Megaparsec (MonadParsec (..), option, try) + +data Specification = Specification + { propName :: !MedeaString, + propSchema :: !(Maybe Identifier), + propOptional :: !Bool + } + deriving stock (Eq) + +parseSpecification :: MedeaParser Specification +parseSpecification = + Specification + <$> parsePropName + <*> parsePropSchema + <*> parsePropOptional + where + parsePropName = + parseLine 8 $ + parseKeyVal RPropertyName parseString + parsePropSchema = + option Nothing . try . parseLine 8 $ + Just <$> parseKeyVal RPropertySchema parseIdentifier + parsePropOptional = + option False . try . parseLine 8 $ + parseReserved ROptionalProperty $> True diff --git a/src/Data/Medea/Parser/Spec/Schema.hs b/src/Data/Medea/Parser/Spec/Schema.hs new file mode 100644 --- /dev/null +++ b/src/Data/Medea/Parser/Spec/Schema.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} + +module Data.Medea.Parser.Spec.Schema + ( Specification (..), + parseSpecification, + ) +where + +import Control.Applicative.Permutations + ( runPermutation, + toPermutationWithDefault, + ) +import Data.Medea.Parser.Primitive + ( Identifier, + ReservedIdentifier (..), + parseIdentifier, + parseKeyVal, + parseLine, + ) +import qualified Data.Medea.Parser.Spec.Array as Array +import qualified Data.Medea.Parser.Spec.Object as Object +import qualified Data.Medea.Parser.Spec.String as String +import qualified Data.Medea.Parser.Spec.Type as Type +import Data.Medea.Parser.Types (MedeaParser) +import Text.Megaparsec (MonadParsec (..)) + +data Specification = Specification + { name :: !Identifier, + types :: !Type.Specification, + stringVals :: !String.Specification, + array :: !Array.Specification, + object :: !(Maybe Object.Specification) + } + deriving stock (Eq) + +parseSpecification :: MedeaParser Specification +parseSpecification = do + schemaName <- parseLine 0 $ parseKeyVal RSchema parseIdentifier + runPermutation $ + Specification schemaName + <$> toPermutationWithDefault Type.defaultSpec (try Type.parseSpecification) + <*> toPermutationWithDefault String.defaultSpec (try String.parseSpecification) + <*> toPermutationWithDefault Array.defaultSpec (try Array.parseSpecification) + <*> toPermutationWithDefault Nothing (Just <$> try Object.parseSpecification) diff --git a/src/Data/Medea/Parser/Spec/Schemata.hs b/src/Data/Medea/Parser/Spec/Schemata.hs new file mode 100644 --- /dev/null +++ b/src/Data/Medea/Parser/Spec/Schemata.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE FlexibleContexts #-} + +module Data.Medea.Parser.Spec.Schemata + ( Specification (..), + parseSpecification, + ) +where + +import qualified Data.Medea.Parser.Spec.Schema as Schema +import Data.Medea.Parser.Types (MedeaParser) +import Data.Vector (Vector) +import qualified Data.Vector as V +import Text.Megaparsec (MonadParsec (..), sepBy1) +import Text.Megaparsec.Char (eol) + +newtype Specification = Specification (Vector Schema.Specification) + +parseSpecification :: MedeaParser Specification +parseSpecification = do + specs <- Schema.parseSpecification `sepBy1` eol + eof + pure . Specification . V.fromList $ specs diff --git a/src/Data/Medea/Parser/Spec/String.hs b/src/Data/Medea/Parser/Spec/String.hs new file mode 100644 --- /dev/null +++ b/src/Data/Medea/Parser/Spec/String.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Data.Medea.Parser.Spec.String + ( Specification (..), + defaultSpec, + parseSpecification, + toReducedSpec, + ) +where + +import Data.Coerce (coerce) +import Data.Medea.Parser.Primitive + ( MedeaString, + ReservedIdentifier (..), + parseLine, + parseReserved, + parseString, + unwrap, + ) +import Data.Medea.Parser.Types (MedeaParser, ParseError (..)) +import Data.Text (Text) +import Data.Vector (Vector) +import qualified Data.Vector as Vec +import Text.Megaparsec (MonadParsec (..), customFailure, many) + +newtype Specification = Specification (Vector MedeaString) + deriving newtype (Eq, Show) + +toReducedSpec :: Specification -> Vector Text +toReducedSpec spec = fmap unwrap (coerce spec :: Vector MedeaString) + +defaultSpec :: Specification +defaultSpec = Specification Vec.empty + +parseSpecification :: MedeaParser Specification +parseSpecification = do + _ <- parseLine 4 $ parseReserved RStringValues + items <- many $ try $ parseLine 8 parseString + if null items + then customFailure EmptyStringValuesSpec + else pure $ Specification $ Vec.fromList items diff --git a/src/Data/Medea/Parser/Spec/Type.hs b/src/Data/Medea/Parser/Spec/Type.hs new file mode 100644 --- /dev/null +++ b/src/Data/Medea/Parser/Spec/Type.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Data.Medea.Parser.Spec.Type + ( Specification (..), + defaultSpec, + parseSpecification, + ) +where + +import Data.Medea.Parser.Primitive + ( Identifier, + ReservedIdentifier (..), + parseIdentifier, + parseLine, + parseReserved, + ) +import Data.Medea.Parser.Types (MedeaParser) +import Data.Vector (Vector) +import qualified Data.Vector as V +import Text.Megaparsec (MonadParsec (..), some) + +newtype Specification = Specification (Vector Identifier) + deriving newtype (Eq) + +defaultSpec :: Specification +defaultSpec = Specification V.empty + +parseSpecification :: MedeaParser Specification +parseSpecification = do + _ <- parseLine 4 $ parseReserved RType + types <- some . try $ parseLine 8 parseIdentifier + pure . Specification . V.fromList $ types diff --git a/src/Data/Medea/Parser/Types.hs b/src/Data/Medea/Parser/Types.hs new file mode 100644 --- /dev/null +++ b/src/Data/Medea/Parser/Types.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE DerivingStrategies #-} + +module Data.Medea.Parser.Types (MedeaParser, ParseError (..)) where + +import Data.Text (Text) +import Text.Megaparsec (Parsec, ShowErrorComponent, showErrorComponent) + +data ParseError + = IdentifierTooLong {-# UNPACK #-} !Text + | ExpectedReservedIdentifier {-# UNPACK #-} !Text + | LeadingZero {-# UNPACK #-} !Text + | ConflictingSpecRequirements + | EmptyLengthArraySpec + | EmptyArrayElements + | EmptyStringValuesSpec + deriving stock (Eq, Ord, Show) + +instance ShowErrorComponent ParseError where + showErrorComponent = show + +type MedeaParser = Parsec ParseError Text diff --git a/src/Data/Medea/Schema.hs b/src/Data/Medea/Schema.hs new file mode 100644 --- /dev/null +++ b/src/Data/Medea/Schema.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Data.Medea.Schema (Schema (..)) where + +import Data.Map.Strict (Map) +import Data.Medea.Analysis (CompiledSchema) +import Data.Medea.Parser.Primitive (Identifier) + +-- | A compiled Medea schema. +newtype Schema = Schema + { compiledSchemata :: Map Identifier CompiledSchema + } + deriving newtype (Eq, Show) diff --git a/src/Data/Medea/ValidJSON.hs b/src/Data/Medea/ValidJSON.hs new file mode 100644 --- /dev/null +++ b/src/Data/Medea/ValidJSON.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DerivingStrategies #-} + +module Data.Medea.ValidJSON (ValidJSONF (..)) where + +import Control.DeepSeq (NFData (..)) +import Data.Aeson (Value (..)) +import Data.Data (Data) +import Data.Functor.Classes (Eq1 (..), Show1 (..)) +import Data.HashMap.Strict (HashMap) +import Data.Hashable (Hashable (..)) +import Data.Scientific (Scientific) +import Data.Text (Text) +import Data.Typeable (Typeable) +import Data.Vector (Vector) +import Data.Vector.Instances () + +data ValidJSONF a + = AnythingF !Value + | NullF + | BooleanF !Bool + | NumberF {-# UNPACK #-} !Scientific + | StringF {-# UNPACK #-} !Text + | ArrayF {-# UNPACK #-} !(Vector a) + | ObjectF !(HashMap Text a) + deriving stock (Functor, Typeable, Data) + +instance Foldable ValidJSONF where + {-# INLINE foldMap #-} + foldMap _ (AnythingF _) = mempty + foldMap _ NullF = mempty + foldMap _ (BooleanF _) = mempty + foldMap _ (NumberF _) = mempty + foldMap _ (StringF _) = mempty + foldMap f (ArrayF v) = foldMap f v + foldMap f (ObjectF hm) = foldMap f hm + +instance Traversable ValidJSONF where + {-# INLINE traverse #-} + traverse _ (AnythingF v) = pure . AnythingF $ v + traverse _ NullF = pure NullF + traverse _ (BooleanF b) = pure . BooleanF $ b + traverse _ (NumberF n) = pure . NumberF $ n + traverse _ (StringF s) = pure . StringF $ s + traverse f (ArrayF v) = ArrayF <$> traverse f v + traverse f (ObjectF hm) = ObjectF <$> traverse f hm + +instance (NFData a) => NFData (ValidJSONF a) where + {-# INLINE rnf #-} + rnf (AnythingF v) = rnf v + rnf NullF = () + rnf (BooleanF b) = rnf b + rnf (NumberF n) = rnf n + rnf (StringF s) = rnf s + rnf (ArrayF v) = rnf v + rnf (ObjectF hm) = rnf hm + +instance Eq1 ValidJSONF where + {-# INLINE liftEq #-} + liftEq _ (AnythingF v) (AnythingF v') = v == v' + liftEq _ NullF NullF = True + liftEq _ (BooleanF b) (BooleanF b') = b == b' + liftEq _ (NumberF n) (NumberF n') = n == n' + liftEq _ (StringF s) (StringF s') = s == s' + liftEq f (ArrayF v) (ArrayF v') = liftEq f v v' + liftEq f (ObjectF hm) (ObjectF hm') = liftEq f hm hm' + liftEq _ _ _ = False + +instance Show1 ValidJSONF where + liftShowsPrec _ _ prec (AnythingF v) = showsPrec prec v + liftShowsPrec _ _ prec NullF = showsPrec prec Null + liftShowsPrec _ _ prec (BooleanF b) = showsPrec prec b + liftShowsPrec _ _ prec (NumberF n) = showsPrec prec n + liftShowsPrec _ _ prec (StringF s) = showsPrec prec s + liftShowsPrec f g prec (ArrayF v) = liftShowsPrec f g prec v + liftShowsPrec f g prec (ObjectF hm) = liftShowsPrec f g prec hm + +instance (Hashable a) => Hashable (ValidJSONF a) where + {-# INLINE hashWithSalt #-} + hashWithSalt salt (AnythingF v) = hashWithSalt salt v + hashWithSalt salt NullF = hashWithSalt salt Null + hashWithSalt salt (BooleanF b) = hashWithSalt salt b + hashWithSalt salt (NumberF n) = hashWithSalt salt n + hashWithSalt salt (StringF s) = hashWithSalt salt s + hashWithSalt salt (ArrayF v) = hashWithSalt salt v + hashWithSalt salt (ObjectF hm) = hashWithSalt salt hm diff --git a/test/Data/Aeson/Arbitrary.hs b/test/Data/Aeson/Arbitrary.hs new file mode 100644 --- /dev/null +++ b/test/Data/Aeson/Arbitrary.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} + +module Data.Aeson.Arbitrary + ( ObjGenOpts(..), + arbitraryArray, + arbitraryObj, + arbitraryValue, + isArray, + isBool, + isNull, + isNumber, + isObject, + isString, + ) +where + +import Control.Monad (filterM, replicateM) +import Control.Monad.Reader (ReaderT, asks, local, runReaderT) +import Control.Monad.Trans (lift) +import Data.Aeson (Array, Object, Value (..)) +import qualified Data.HashMap.Strict as HM +import Data.Text (Text) +import qualified Data.Vector as V +import Test.QuickCheck (Arbitrary (..), Gen) +import Test.QuickCheck.Gen (choose) +import Test.QuickCheck.Instances.Scientific () +import Test.QuickCheck.Instances.Text () + +-- Takes 4 fields: +-- required properties, +-- optional properties, +-- minimum additional properties & +-- maximum additional properties. +data ObjGenOpts = ObjGenOpts [Text] [Text] Int Int + +arbitraryValue :: Gen Value +arbitraryValue = runReaderT makeRandomValue 5 -- recursion depth + +arbitraryObj :: ObjGenOpts -> Gen Object +arbitraryObj opts = runReaderT (makeRandomObject opts) 2 + +arbitraryArray :: (Int, Int) -> Gen Array +arbitraryArray range = runReaderT (makeRandomArray range) 2 + +isNull :: Value -> Bool +isNull Null = True +isNull _ = False + +isBool :: Value -> Bool +isBool (Bool _) = True +isBool _ = False + +isNumber :: Value -> Bool +isNumber (Number _) = True +isNumber _ = False + +isString :: Value -> Bool +isString (String _) = True +isString _ = False + +isArray :: Value -> Bool +isArray (Array _) = True +isArray _ = False + +isObject :: Value -> Bool +isObject (Object _) = True +isObject _ = False + +-- Helpers + +makeRandomValue :: ReaderT Word Gen Value +makeRandomValue = do + reachedMaxDepth <- asks (== 0) + choice <- lift . choose @Word $ (0, if reachedMaxDepth then 3 else 5) + case choice of + 0 -> pure Null + 1 -> Bool <$> lift arbitrary + 2 -> Number <$> lift arbitrary + 3 -> String <$> lift arbitrary + 4 -> Array <$> makeRandomArray (0, 10) + _ -> Object <$> makeRandomObject (ObjGenOpts [] [] 0 10) + +makeRandomArray :: (Int, Int) -> ReaderT Word Gen Array +makeRandomArray range = do + len <- lift . choose $ range + V.replicateM len (local dec makeRandomValue) + +makeRandomObject :: ObjGenOpts -> ReaderT Word Gen Object +makeRandomObject (ObjGenOpts props optionalProps minAdditional maxAdditional) = do + entryCount <- lift $ choose (minAdditional, maxAdditional) + genKeys <- replicateM entryCount $ lift arbitrary + someOptionalProps <- filterM (\_ -> lift arbitrary) optionalProps + let keys = genKeys ++ props ++ someOptionalProps + keyVals <- mapM (\x -> (x,) <$> local dec makeRandomValue) keys + pure . HM.fromList $ keyVals + +dec :: Word -> Word +dec = subtract 1 diff --git a/test/TestM.hs b/test/TestM.hs new file mode 100644 --- /dev/null +++ b/test/TestM.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module TestM + ( TestM (..), + isParseError, + isSchemaError, + listMedeaFiles, + runTestM, + ) +where + +import Control.Monad.Except (ExceptT, MonadError, runExceptT) +import Control.Monad.IO.Class (MonadIO) +import Data.List (sort) +import Data.Medea (LoaderError (..)) +import System.Directory (listDirectory) +import System.FilePath ((), isExtensionOf) + +newtype TestM a = TestM (ExceptT LoaderError IO a) + deriving (Functor, Applicative, Monad, MonadError LoaderError, MonadIO) + +runTestM :: TestM a -> IO (Either LoaderError a) +runTestM (TestM comp) = runExceptT comp + +isParseError :: Either LoaderError a -> Bool +isParseError (Left NotUtf8) = True +isParseError (Left IdentifierTooLong) = True +isParseError (Left (ParserError _)) = True +isParseError _ = False + +isSchemaError :: Either LoaderError a -> Bool +isSchemaError (Left StartSchemaMissing) = True +isSchemaError (Left SelfTypingSchema) = True +isSchemaError (Left (MultipleSchemaDefinition _)) = True +isSchemaError (Left (MissingSchemaDefinition _ _)) = True +isSchemaError (Left (SchemaNameReserved _)) = True +isSchemaError (Left (IsolatedSchemata _)) = True +isSchemaError (Left (MissingPropSchemaDefinition _ _)) = True +isSchemaError (Left (MinimumLengthGreaterThanMaximum _)) = True +isSchemaError (Left (MultiplePropSchemaDefinition _ _)) = True +isSchemaError (Left (MissingListSchemaDefinition _ _)) = True +isSchemaError (Left (MissingTupleSchemaDefinition _ _)) = True +isSchemaError (Left (PropertySpecWithoutObjectType _)) = True +isSchemaError (Left (ListSpecWithoutArrayType _)) = True +isSchemaError (Left (TupleSpecWithoutArrayType _)) = True +isSchemaError (Left (StringSpecWithoutStringType _)) = True +isSchemaError _ = False + +listMedeaFiles :: FilePath -> IO [FilePath] +listMedeaFiles dir = fmap (dir ) . sort . filter (isExtensionOf ".medea") <$> listDirectory dir diff --git a/test/parser/Main.hs b/test/parser/Main.hs new file mode 100644 --- /dev/null +++ b/test/parser/Main.hs @@ -0,0 +1,27 @@ +module Main where + +import Data.Foldable (traverse_) +import Data.Medea (loadSchemaFromFile) +import Test.Hspec (Spec, describe, hspec, it, runIO, shouldNotSatisfy, shouldSatisfy) +import TestM (isParseError, listMedeaFiles, runTestM) + +main :: IO () +main = do + let failDir = "./conformance/parser/fail" + passDir = "./conformance/parser/pass" + failTestFiles <- listMedeaFiles failDir + passTestFiles <- listMedeaFiles passDir + hspec . describe "Invalid parse cases" . traverse_ makeParseTestFail $ failTestFiles + hspec . describe "Valid parse cases" . traverse_ makeParseTestPass $ passTestFiles + +-- Helpers + +makeParseTestFail :: FilePath -> Spec +makeParseTestFail fp = do + result <- runIO . runTestM . loadSchemaFromFile $ fp + it ("Shouldn't parse: " ++ fp) (result `shouldSatisfy` isParseError) + +makeParseTestPass :: FilePath -> Spec +makeParseTestPass fp = do + result <- runIO . runTestM . loadSchemaFromFile $ fp + it ("Should parse: " ++ fp) (result `shouldNotSatisfy` isParseError) diff --git a/test/schema-builder/Main.hs b/test/schema-builder/Main.hs new file mode 100644 --- /dev/null +++ b/test/schema-builder/Main.hs @@ -0,0 +1,36 @@ +module Main where + +import Data.Either (isRight) +import Data.Foldable (traverse_) +import Data.Medea (loadSchemaFromFile) +import Test.Hspec + ( Spec, + describe, + hspec, + it, + runIO, + shouldSatisfy, + ) +import TestM (isSchemaError, listMedeaFiles, runTestM) + +main :: IO () +main = do + let failDir = "./conformance/schema-builder/fail" + let passDir = "./conformance/schema-builder/pass" + failFiles <- listMedeaFiles failDir + passFiles <- listMedeaFiles passDir + hspec $ do + describe "Invalid schemata cases" . traverse_ makeFailTest $ failFiles + describe "Valid schemata cases" . traverse_ makePassTest $ passFiles + +-- Helpers + +makeFailTest :: FilePath -> Spec +makeFailTest fp = do + result <- runIO . runTestM . loadSchemaFromFile $ fp + it ("Shouldn't build: " ++ fp) (result `shouldSatisfy` isSchemaError) + +makePassTest :: FilePath -> Spec +makePassTest fp = do + result <- runIO . runTestM . loadSchemaFromFile $ fp + it ("Should build: " ++ fp) (result `shouldSatisfy` isRight) diff --git a/test/validator-quickcheck/Main.hs b/test/validator-quickcheck/Main.hs new file mode 100644 --- /dev/null +++ b/test/validator-quickcheck/Main.hs @@ -0,0 +1,336 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Control.Monad.Except (runExcept) +import Data.Aeson (Array, Object, ToJSON, Value, Value (..), encode) +import Data.Aeson.Arbitrary + ( ObjGenOpts (..), + arbitraryArray, + arbitraryObj, + arbitraryValue, + isArray, + isBool, + isNull, + isNumber, + isObject, + isString, + ) +import Data.Either (isLeft, isRight) +import Data.HashMap.Strict (filterWithKey, lookup) +import Data.Medea (Schema, loadSchemaFromFile, validate) +import Data.Text (Text) +import qualified Data.Vector as V +import Test.Hspec (Spec, describe, hspec, it, parallel, runIO, shouldNotSatisfy) +import Test.Hspec.Core.Spec (SpecM) +import Test.QuickCheck ((==>), Gen, Property, arbitrary, forAll, property) +import qualified Test.QuickCheck.Gen as Gen +import TestM (isParseError, isSchemaError, runTestM) +import Prelude hiding (lookup) + +main :: IO () +main = hspec . parallel $ do + describe "Any schema" . testAny $ "any.medea" + describe "Null schema" . testSingular "null.medea" "null" $ isNull + describe "Boolean schema" . testSingular "boolean.medea" "boolean" $ isBool + describe "Number schema" . testSingular "number.medea" "number" $ isNumber + describe "String schema" . testSingular "string.medea" "string" $ isString + describe "Array schema" . testSingular "array.medea" "array" $ isArray + describe "Object schema" . testSingular "object.medea" "object" $ isObject + describe "Boolean/null schema" . testSingular "nullable-boolean.medea" "boolean/null" $ isNull .|| isBool + describe "Number/null schema" . testSingular "nullable-number.medea" "number/null" $ isNull .|| isNumber + describe "String/null schema" . testSingular "nullable-string.medea" "string/null" $ isNull .|| isString + describe "Array/null schema" . testSingular "nullable-array.medea" "array/null" $ isNull .|| isArray + describe "Object/null schema" . testSingular "nullable-object.medea" "object/null" $ isNull .|| isObject + describe "String with Values Schema" $ do + testStringVals "stringVals.medea" ["bar", "baz"] + testStringVals "stringVals2.medea" ["accountant", "barber", "bishop", "baker"] + describe "Object schema with 1 property and no additional allowed" $ do + testObject + ObjTestParams + { objTestOpts = ObjGenOpts ["foo"] [] 0 2, + objTestPath = "1-property-no-additional-1.medea", + objTestPred = hasProperty "foo" isBool, + objAdditionalPred = const False + } + testObject + ObjTestParams + { objTestOpts = ObjGenOpts ["foo"] [] 0 2, + objTestPath = "1-property-no-additional-2.medea", + objTestPred = hasProperty "foo" isNull, + objAdditionalPred = const False + } + testObject + ObjTestParams + { objTestOpts = ObjGenOpts ["foo"] [] 0 2, + objTestPath = "1-property-no-additional-3.medea", + objTestPred = hasProperty "foo" isArray, + objAdditionalPred = const False + } + describe "Object schema with 1 property and additional allowed" $ do + testObject + ObjTestParams + { objTestOpts = ObjGenOpts ["foo"] [] 0 3, + objTestPath = "1-property-additional-1.medea", + objTestPred = hasProperty "foo" isString, + objAdditionalPred = const True + } + testObject + ObjTestParams + { objTestOpts = ObjGenOpts ["foo"] [] 0 3, + objTestPath = "1-property-additional-2.medea", + objTestPred = hasProperty "foo" isNumber, + objAdditionalPred = const True + } + testObject + ObjTestParams + { objTestOpts = ObjGenOpts ["foo"] [] 0 3, + objTestPath = "1-property-additional-3.medea", + objTestPred = hasProperty "foo" isObject, + objAdditionalPred = const True + } + describe "Object schema with 3 properties and no additional allowed" $ do + testObject + ObjTestParams + { objTestOpts = ObjGenOpts ["foo", "bar", "bazz"] [] 0 1, + objTestPath = "3-property-no-additional-1.medea", + objTestPred = + hasProperty "foo" (isNumber .|| isArray) + .&& hasProperty "bazz" (isNull .|| isBool), + objAdditionalPred = const False + } + testObject + ObjTestParams + { objTestOpts = ObjGenOpts ["bar", "bazz"] ["foo"] 0 1, + objTestPath = "3-property-no-additional-2.medea", + objTestPred = + hasOptionalProperty "foo" (isNumber .|| isArray) + .&& hasProperty "bazz" (isNull .|| isBool), + objAdditionalPred = const False + } + describe "Object schema with 3 properties and additional allowed" $ do + testObject + ObjTestParams + { objTestOpts = ObjGenOpts ["foo", "bar", "bazz"] [] 0 3, + objTestPath = "3-property-additional-allowed-1.medea", + objTestPred = hasProperty "foo" isBool .&& hasProperty "bazz" isString, + objAdditionalPred = const True + } + testObject + ObjTestParams + { objTestOpts = ObjGenOpts ["bar", "bazz"] ["foo"] 0 3, + objTestPath = "3-property-additional-allowed-2.medea", + objTestPred = hasOptionalProperty "foo" isNumber .&& hasProperty "bazz" isNull, + objAdditionalPred = const True + } + describe "Object schema with additional property schema" $ do + testObject + ObjTestParams + { objTestOpts = ObjGenOpts [] [] 0 3, + objTestPath = "map-number-bool.medea", + objTestPred = const True, + objAdditionalPred = isNumber .|| isBool + } + testObject + ObjTestParams + { objTestOpts = ObjGenOpts ["foo"] [] 0 3, + objTestPath = "map-with-1-specified.medea", + objTestPred = hasProperty "foo" (isArray .|| isObject), + objAdditionalPred = isNumber .|| isBool + } + testObject + ObjTestParams + { objTestOpts = ObjGenOpts ["foo"] ["bazz"] 0 3, + objTestPath = "map-with-2-specified.medea", + objTestPred = hasProperty "foo" (isArray .|| isObject), + objAdditionalPred = isNumber .|| isBool + } + describe "Array schema with element_type only" $ do + testList + ListTestParams + { listTestOpts = (0, 3), + listTestPath = "list-1.medea", + elementPred = isNumber .|| isBool .|| isObject, + lenPred = const True + } + testList + ListTestParams + { listTestOpts = (1, 3), + listTestPath = "list-2.medea", + elementPred = isNumber .|| isBool .|| isObject, + lenPred = const True + } + describe "Array schema with length spec only" $ do + testList + ListTestParams + { listTestOpts = (1, 6), + listTestPath = "list-3.medea", + elementPred = const True, + lenPred = arrayLenGE 2 + } + testList + ListTestParams + { listTestOpts = (1, 6), + listTestPath = "list-4.medea", + elementPred = const True, + lenPred = arrayLenLE 5 + } + testList + ListTestParams + { listTestOpts = (1, 6), + listTestPath = "list-5.medea", + elementPred = const True, + lenPred = arrayLenLE 5 .&& arrayLenGE 3 + } + describe "Array schema with length and element type" $ do + testList + ListTestParams + { listTestOpts = (1, 4), + listTestPath = "list-6.medea", + elementPred = isNull .|| isBool .|| isNumber, + lenPred = arrayLenGE 2 .&& arrayLenLE 3 + } + testList + ListTestParams + { listTestOpts = (1, 4), + listTestPath = "list-7.medea", + elementPred = isNull .|| isBool .|| isNumber, + lenPred = arrayLenGE 2 .&& arrayLenLE 3 + } + describe "Array schema with tuple spec" $ do + testTuple + TupleTestParams + { tupleTestOpts = (3, 4), + tupleTestPath = "3-tuple.medea", + tuplePreds = [isNumber .|| isArray, isBool, const True] + } + testTuple + TupleTestParams + { tupleTestOpts = (1, 3), + tupleTestPath = "2-tuple.medea", + tuplePreds = [isObject .|| isNull, isString .|| isNumber] + } + +data ObjTestParams + = ObjTestParams + { objTestOpts :: ObjGenOpts, + objTestPath :: FilePath, + objTestPred :: Object -> Bool, + -- | The predice to be used on additional properties + objAdditionalPred :: Value -> Bool + } + +data ListTestParams + = ListTestParams + { listTestOpts :: (Int, Int), + listTestPath :: FilePath, + elementPred :: Value -> Bool, + lenPred :: Array -> Bool + } + +data TupleTestParams + = TupleTestParams + { tupleTestOpts :: (Int, Int), + tupleTestPath :: FilePath, + tuplePreds :: [Value -> Bool] + } + +-- Helpers + +(.||) :: (a -> Bool) -> (a -> Bool) -> (a -> Bool) +f .|| g = (||) <$> f <*> g + +(.&&) :: (a -> Bool) -> (a -> Bool) -> (a -> Bool) +f .&& g = (&&) <$> f <*> g + +testAny :: FilePath -> Spec +testAny fp = do + scm <- loadAndParse $ prependTestDir fp + it ("Should validate anything: " ++ fp) (validationSuccess arbitraryValue (const True) scm) + +testSingular :: FilePath -> String -> (Value -> Bool) -> Spec +testSingular fp name p = do + scm <- loadAndParse $ prependTestDir fp + it ("Should validate " ++ name ++ "s: " ++ fp) (validationSuccess arbitraryValue p scm) + it ("Should not validate non-" ++ name ++ "s: " ++ fp) (validationFail arbitraryValue (not . p) scm) + +testObject :: ObjTestParams -> Spec +testObject (ObjTestParams opts fp p extraPred) = do + scm <- loadAndParse $ prependTestDir fp + it ("Should validate valid objects" ++ ": " ++ fp) (validationSuccess gen p' scm) + it ("Should not validate invalid objects" ++ ": " ++ fp) (validationFail gen (not . p') scm) + where + gen = arbitraryObj opts + p' = p .&& makeMapPred opts extraPred + +testList :: ListTestParams -> Spec +testList (ListTestParams opts fp pTypes pLen) = do + scm <- loadAndParse $ prependTestDir fp + it ("Should validate valid lists" ++ ": " ++ fp) (validationSuccess gen p scm) + it ("Should not validate invalid lists" ++ ": " ++ fp) (validationFail gen (not . p) scm) + where + gen = arbitraryArray opts + p = all pTypes .&& pLen + +testTuple :: TupleTestParams -> Spec +testTuple (TupleTestParams opts fp preds) = do + scm <- loadAndParse $ prependTestDir fp + it ("Should validate valid tuples" ++ ": " ++ fp) (validationSuccess gen p scm) + it ("Should not validate invalid tuples" ++ ": " ++ fp) (validationFail gen (not . p) scm) + where + gen = arbitraryArray opts + p arr = (and . zipWith ($) preds . V.toList $ arr) && (V.length arr == length preds) + +-- "validation succeeded" property +validationSuccess :: (ToJSON a, Show a) => Gen a -> (a -> Bool) -> Schema -> Property +validationSuccess gen p scm = property $ forAll gen prop + where + prop v = p v ==> isRight . runExcept . validate scm . encode $ v + +-- "validation failed" property +validationFail :: (ToJSON a, Show a) => Gen a -> (a -> Bool) -> Schema -> Property +validationFail gen p scm = property $ forAll gen prop + where + prop v = p v ==> isLeft . runExcept . validate scm . encode $ v + +-- Returns true iff the value is an object with the given property and the +-- property-value satisfies the predicate. +hasProperty :: Text -> (Value -> Bool) -> Object -> Bool +hasProperty propName p obj = maybe False p $ lookup propName obj + +-- Like hasProperty but is also true when the given property is absent. +hasOptionalProperty :: Text -> (Value -> Bool) -> Object -> Bool +hasOptionalProperty propName p obj = maybe True p $ lookup propName obj + +makeMapPred :: ObjGenOpts -> (Value -> Bool) -> Object -> Bool +makeMapPred (ObjGenOpts props optProps _ _) p = all p . filterWithKey (\k _ -> k `notElem` specifiedProps) + where + specifiedProps = props ++ optProps + +testStringVals :: FilePath -> [String] -> Spec +testStringVals fp validStrings = do + scm <- loadAndParse $ prependTestDir fp + it ("Should validate only strings in " ++ show validStrings ++ ": " ++ fp) (validationSuccess genString p scm) + it ("Shouldn't validate strings not in " ++ show validStrings ++ "s: " ++ fp) (validationFail genString (not . p) scm) + where + genString :: Gen.Gen String + genString = Gen.oneof [Gen.elements validStrings, arbitrary] + p = (`elem` validStrings) + +loadAndParse :: FilePath -> SpecM () Schema +loadAndParse fp = do + result <- runIO . runTestM . loadSchemaFromFile $ fp + it ("Should parse: " ++ fp) (result `shouldNotSatisfy` isParseError) + it ("Should build: " ++ fp) (result `shouldNotSatisfy` isSchemaError) + case result of + Left e -> error ("This should never happen: " ++ show e) + Right scm -> pure scm + +prependTestDir :: FilePath -> FilePath +prependTestDir = ("./conformance/validation/" ++) + +arrayLenGE :: Int -> Array -> Bool +arrayLenGE len arr = V.length arr >= len + +arrayLenLE :: Int -> Array -> Bool +arrayLenLE len arr = V.length arr <= len