packages feed

medea (empty) → 1.0.0

raw patch · 25 files changed

+3164/−0 lines, 25 filesdep +QuickCheckdep +aesondep +algebraic-graphs

Dependencies added: QuickCheck, aeson, algebraic-graphs, base, bytestring, containers, deepseq, directory, filepath, free, hashable, hspec, hspec-core, medea, megaparsec, microlens-ghc, mtl, nonempty-containers, parser-combinators, quickcheck-instances, scientific, text, unordered-containers, vector, vector-instances

Files

+ CHANGELOG.md view
@@ -0,0 +1,3 @@+# 1.0.0++- Initial release
+ README.md view
@@ -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
+ SPEC.md view
@@ -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
+ TUTORIAL.md view
@@ -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.
+ medea.cabal view
@@ -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
+ src/Data/Medea.hs view
@@ -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
+ src/Data/Medea/Analysis.hs view
@@ -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)
+ src/Data/Medea/JSONType.hs view
@@ -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
+ src/Data/Medea/Loader.hs view
@@ -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
+ src/Data/Medea/Parser/Primitive.hs view
@@ -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
+ src/Data/Medea/Parser/Spec/Array.hs view
@@ -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
+ src/Data/Medea/Parser/Spec/Object.hs view
@@ -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
+ src/Data/Medea/Parser/Spec/Property.hs view
@@ -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
+ src/Data/Medea/Parser/Spec/Schema.hs view
@@ -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)
+ src/Data/Medea/Parser/Spec/Schemata.hs view
@@ -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
+ src/Data/Medea/Parser/Spec/String.hs view
@@ -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
+ src/Data/Medea/Parser/Spec/Type.hs view
@@ -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
+ src/Data/Medea/Parser/Types.hs view
@@ -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
+ src/Data/Medea/Schema.hs view
@@ -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)
+ src/Data/Medea/ValidJSON.hs view
@@ -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
+ test/Data/Aeson/Arbitrary.hs view
@@ -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
+ test/TestM.hs view
@@ -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
+ test/parser/Main.hs view
@@ -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)
+ test/schema-builder/Main.hs view
@@ -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)
+ test/validator-quickcheck/Main.hs view
@@ -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