|
354 | 354 | ;; Here we'd prefer a version of ::fields where :resolve was not defined. |
355 | 355 | (s/def ::interface (s/keys :opt-un [::description |
356 | 356 | ::directives |
357 | | - ::fields])) |
| 357 | + ::fields |
| 358 | + ::implements])) |
358 | 359 | ;; A list of keyword identifying objects that are part of a union. |
359 | 360 | (s/def ::members (s/and (s/coll-of ::type-name) |
360 | 361 | seq)) |
|
688 | 689 | [i-type f-type] |
689 | 690 | (contains? (:implements f-type) (:type-name i-type))) |
690 | 691 |
|
| 692 | +(defmethod check-compatible [:interface :interface] |
| 693 | + [i-type f-type] |
| 694 | + ;; An interface field type is compatible with an implementing-interface field type if |
| 695 | + ;; the implementing interface (f-type) declares that it implements the constraining |
| 696 | + ;; interface (i-type). |
| 697 | + (contains? (:implements f-type) (:type-name i-type))) |
| 698 | + |
691 | 699 | ;; That's as far as the spec goes, but one could imagine additonal rules |
692 | 700 | ;; such as a union-vs-union (the field union must be a subset of the interface union), |
693 | 701 | ;; or interface-union (all members of the union must implement the interface). |
|
1558 | 1566 | map->Type |
1559 | 1567 | compile-directives))) |
1560 | 1568 |
|
| 1569 | +(defn ^:private expand-implements |
| 1570 | + "Returns the transitive closure of implements for a type. Walks up the interface |
| 1571 | + hierarchy so that e.g. if B implements A, and C implements B, C's :implements |
| 1572 | + includes both :B and :A." |
| 1573 | + [schema type-name] |
| 1574 | + (loop [result #{} |
| 1575 | + queue (vec (:implements (get schema type-name)))] |
| 1576 | + (if (empty? queue) |
| 1577 | + result |
| 1578 | + (let [iface-name (first queue) |
| 1579 | + remaining (rest queue) |
| 1580 | + iface (get schema iface-name)] |
| 1581 | + (recur (conj result iface-name) |
| 1582 | + (into (vec remaining) |
| 1583 | + (remove result (:implements iface)))))))) |
| 1584 | + |
1561 | 1585 | (defmethod compile-type :interface |
1562 | 1586 | [interface schema] |
1563 | | - (->> interface |
1564 | | - map->Interface |
1565 | | - compile-directives |
1566 | | - (compile-fields schema))) |
| 1587 | + (let [interface-name (:type-name interface) |
| 1588 | + implements (->> interface :implements (map as-keyword) set)] |
| 1589 | + (doseq [iface-name implements |
| 1590 | + :let [type (get schema iface-name)]] |
| 1591 | + (when (= iface-name interface-name) |
| 1592 | + (throw (ex-info (format "Interface %s cannot implement itself." |
| 1593 | + (q iface-name)) |
| 1594 | + {:interface interface-name}))) |
| 1595 | + (when-not type |
| 1596 | + (throw (ex-info (format "Interface %s implements interface %s, which does not exist." |
| 1597 | + (q interface-name) |
| 1598 | + (q iface-name)) |
| 1599 | + {:interface interface-name |
| 1600 | + :schema-types (type-map schema)}))) |
| 1601 | + (when-not (= :interface (:category type)) |
| 1602 | + (throw (ex-info (format "Interface %s implements type %s, which is not an interface." |
| 1603 | + (q interface-name) |
| 1604 | + (q iface-name)) |
| 1605 | + {:interface interface-name |
| 1606 | + :schema-types (type-map schema)})))) |
| 1607 | + (->> interface |
| 1608 | + map->Interface |
| 1609 | + compile-directives |
| 1610 | + (compile-fields schema) |
| 1611 | + (#(if (seq implements) |
| 1612 | + (assoc % :implements implements) |
| 1613 | + %))))) |
1567 | 1614 |
|
1568 | 1615 | (defn ^:private extract-type-name |
1569 | 1616 | "Navigates a type map down to the root kind and returns the type name." |
|
1722 | 1769 | ;; Validate argument directives |
1723 | 1770 | (validate-directives-in-def schema arg-def :argument-definition))))) |
1724 | 1771 |
|
| 1772 | +(defn ^:private all-implemented-interfaces |
| 1773 | + "Returns the transitive set of interface names implemented by the given type (by type-name keyword). |
| 1774 | + Walks up the interface hierarchy via :implements on each compiled interface definition." |
| 1775 | + [schema type-name] |
| 1776 | + (loop [result #{} |
| 1777 | + queue (vec (:implements (get schema type-name)))] |
| 1778 | + (if (empty? queue) |
| 1779 | + result |
| 1780 | + (let [iface-name (first queue) |
| 1781 | + remaining (subvec (vec queue) 1)] |
| 1782 | + (if (result iface-name) |
| 1783 | + (recur result remaining) |
| 1784 | + (recur (conj result iface-name) |
| 1785 | + (into remaining |
| 1786 | + (remove result (:implements (get schema iface-name)))))))))) |
| 1787 | + |
1725 | 1788 | (defn ^:private prepare-and-validate-interfaces |
1726 | 1789 | "Invoked after compilation to add a :members set identifying which concrete types implement |
1727 | | - the interface. Peforms final verification of types in fields and field arguments." |
| 1790 | + the interface. Performs final verification of types in fields and field arguments. |
| 1791 | + Also validates that interfaces implementing other interfaces declare all required fields." |
1728 | 1792 | [schema] |
1729 | | - (let [objects (types-with-category schema :object)] |
1730 | | - (map-types schema :interface |
1731 | | - (fn [interface] |
1732 | | - (verify-fields-and-args schema interface) |
1733 | | - (validate-directives-in-def schema interface :interface) |
1734 | | - (let [interface-name (:type-name interface) |
1735 | | - implementors (->> objects |
1736 | | - (filter #(-> % :implements interface-name)) |
1737 | | - (map :type-name) |
1738 | | - set) |
1739 | | - fields' (->> interface |
1740 | | - :fields |
1741 | | - (map-vals #(assoc % :type-name interface-name)) |
1742 | | - (map-vals apply-deprecated-directive))] |
1743 | | - (-> interface |
1744 | | - (assoc :members implementors |
1745 | | - :fields fields') |
1746 | | - (dissoc :resolve))))))) |
| 1793 | + (let [objects (types-with-category schema :object) |
| 1794 | + interfaces (types-with-category schema :interface) |
| 1795 | + ;; Detect cycles in the interface implements graph before doing anything else. |
| 1796 | + _ (doseq [interface interfaces |
| 1797 | + :let [interface-name (:type-name interface) |
| 1798 | + transitive (all-implemented-interfaces schema interface-name)]] |
| 1799 | + (when (transitive interface-name) |
| 1800 | + (throw (ex-info (format "Interface %s is part of a circular implements chain." |
| 1801 | + (q interface-name)) |
| 1802 | + {:interface interface-name})))) |
| 1803 | + ;; Expand each object's :implements set to include transitively-inherited interfaces. |
| 1804 | + ;; This is needed so check-compatible [:interface :object] works when an object only |
| 1805 | + ;; directly lists a sub-interface but not its parent interfaces. |
| 1806 | + schema' (reduce (fn [s obj] |
| 1807 | + (let [transitive (all-implemented-interfaces s (:type-name obj)) |
| 1808 | + expanded (into (:implements obj #{}) transitive)] |
| 1809 | + (if (= expanded (:implements obj)) |
| 1810 | + s |
| 1811 | + (update s (:type-name obj) assoc :implements expanded)))) |
| 1812 | + schema |
| 1813 | + objects)] |
| 1814 | + ;; Validate that each interface implementing another interface declares all required fields. |
| 1815 | + (doseq [interface interfaces |
| 1816 | + :let [interface-name (:type-name interface)] |
| 1817 | + parent-name (:implements interface) |
| 1818 | + :let [parent (get schema parent-name)] |
| 1819 | + [field-name parent-field] (:fields parent) |
| 1820 | + :let [iface-field (get-nested interface [:fields field-name])]] |
| 1821 | + (when-not iface-field |
| 1822 | + (throw (ex-info "Missing interface field in interface definition." |
| 1823 | + {:interface interface-name |
| 1824 | + :field-name field-name |
| 1825 | + :parent-interface-name parent-name}))) |
| 1826 | + (when-not (is-assignable? schema parent-field iface-field) |
| 1827 | + (throw (ex-info "Interface field is not compatible with implemented interface field type." |
| 1828 | + {:parent-interface-name parent-name |
| 1829 | + :field-name (:qualified-name iface-field)})))) |
| 1830 | + (let [objects' (types-with-category schema' :object)] |
| 1831 | + (map-types schema' :interface |
| 1832 | + (fn [interface] |
| 1833 | + (verify-fields-and-args schema' interface) |
| 1834 | + (validate-directives-in-def schema' interface :interface) |
| 1835 | + (let [interface-name (:type-name interface) |
| 1836 | + ;; Use objects' (with expanded :implements) to catch transitive membership. |
| 1837 | + implementors (->> objects' |
| 1838 | + (filter #(-> % :implements interface-name)) |
| 1839 | + (map :type-name) |
| 1840 | + set) |
| 1841 | + fields' (->> interface |
| 1842 | + :fields |
| 1843 | + (map-vals #(assoc % :type-name interface-name)) |
| 1844 | + (map-vals apply-deprecated-directive))] |
| 1845 | + (-> interface |
| 1846 | + (assoc :members implementors |
| 1847 | + :fields fields') |
| 1848 | + (dissoc :resolve)))))))) |
1747 | 1849 |
|
1748 | 1850 | (defn ^:private update-fields-in-object |
1749 | 1851 | [object-def f] |
|
0 commit comments