schema.clj

; Copyright (c) 2017-present Walmart, Inc.
;
; Licensed under the Apache License, Version 2.0 (the "License")
; you may not use this file except in compliance with the License.
; You may obtain a copy of the License at
;
;     http://www.apache.org/licenses/LICENSE-2.0
;
; Unless required by applicable law or agreed to in writing, software
; distributed under the License is distributed on an "AS IS" BASIS,
; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
; See the License for the specific language governing permissions and
; limitations under the License.

(ns com.walmartlabs.lacinia.parser.schema
  "Parse a Schema Definition Language document into a Lacinia input schema."
  {:added "0.22.0"}
  (:require
    #_ [io.pedestal.log :as log]
    [com.walmartlabs.lacinia.internal-utils :refer [remove-vals keepv q qualified-name]]
    [com.walmartlabs.lacinia.parser.common :as common]
    [com.walmartlabs.lacinia.util :refer [inject-descriptions]]
    [com.walmartlabs.lacinia.schema :as schema]
    [clojure.spec.alpha :as s]
    [clojure.string :as str])
  (:import
    (clj_antlr ParseError)))

;; When using Clojure 1.8, the dependency on clojure-future-spec must be included,
;; and this code will trigger
(when (-> *clojure-version* :minor (< 9))
  (require '[clojure.future :refer [simple-keyword?]]))

(def ^:private grammar
  (common/compile-grammar "com/walmartlabs/lacinia/schema.g4"))

(defn ^:private tag
  "Returns a map of the nested productions in a production.
  Nested productions are elements after the first; the key is the
  first element in each nested production.

  Note that this should only be used in cases where none of the productions repeat."
  [prod]
  (reduce (fn [m p]
            (assoc m (first p) p))
          {}
          (rest prod)))

(defn is-extension?
  [v]
  (get (meta v) :extension false))

(defn ^:private merge-type-extension
  [k v org]
  (doseq [property (keys (get org :fields {}))]
    (when (contains? (get v :fields {}) property)
      (let [locations (keepv meta [org v])]
        (throw (ex-info (format "Field %s already defined in the existing schema. It cannot also be defined in this type extension."
                                (q (qualified-name k property)))
                        (cond-> {:key k}
                                (seq locations) (assoc :locations locations)))))))
  (reduce merge
          {}
          [{:fields (merge (get org :fields) (get v :fields))}
           (some->> (into (get org :implements []) (get v :implements []))
                    (distinct)
                    (vec)
                    (#(if (not-empty %) % nil))
                    (assoc {} :implements))
           ; TODO check and/or remove duplicate directives
           (some->> (into (get org :directives []) (get v :directives []))
                    (#(if (not-empty %) % nil))
                    (assoc {} :directives))
           (some->> [(get org :description) (get v :description)]
                    (remove nil?)
                    (str/join " ")
                    (#(if (not-empty %) % nil))
                    (assoc {} :description))]))

(defn ^:private assoc-check
  [m content k v]
  (cond (and (not (contains? m k))
             (is-extension? v))
        (let [locations (keepv meta [(get m k) v])]
          (throw (ex-info (format "Cannot extend type %s because it does not exist in the existing schema."
                                  (q k))
                          (cond-> {:key k}
                                  (seq locations) (assoc :locations locations)))))

        (not (contains? m k))
        (assoc m k v)

        (is-extension? v)
        (update m k (partial merge-type-extension k v))

        (contains? m k)
        (let [locations (keepv meta [(get m k) v])]
          (throw (ex-info (format "Conflicting %s: %s."
                                  content
                                  (q k))
                          (cond-> {:key k}
                                  (seq locations) (assoc :locations locations)))))))

(defn ^:private checked-map
  "Given a seq of key/value tuples, assembles a map, checking that keys do not conflict
  (throwing an exception if they do).

  content describes what is being built, and is used for exception messages."
  [content kvs]
  (reduce (fn [m [k v]]
            (assoc-check m content k v))
          {}
          kvs))

(defn ^:private attach-field-fns
  "Attaches a map of either resolvers or subscription streamers"
  [schema fn-k fn-map]
  {:pre [(#{:resolve :stream} fn-k)]}
  (reduce-kv (fn [schema' type fields]
               (reduce-kv (fn [schema'' field f]
                            (assoc-in schema'' [:objects type :fields field fn-k] f))
                          schema'
                          fields))
             schema
             fn-map))

(defn ^:private attach-scalars
  [schema scalars]
  (if (seq scalars)
    (update schema :scalars
            (fn [s]
              (reduce-kv (fn [s' scalar-name scalar-value]
                           (update s' scalar-name merge scalar-value))
                         s
                         scalars)))
    schema))

;; This is very similar to the code for parsing a query, and includes a bit of duplication.
;; Perhaps at some point we can merge it all into a single, unified grammar.

(defmulti ^:private xform
  "Transform an Antlr production into a result.

  Antlr productions are recursive lists; the first element is a type
  (from the grammar), and the rest of the list are nested productions.

  Meta data on the production is the location (line, column) of the production."
  first
  ;; When debugging/developing, this is incredibly useful:
  #_(fn [prod]
      (log/trace :dispatch prod)
      (first prod))
  :default ::default)

(defn ^:private xform-second
  [prod]
  (-> prod second xform))

(defn ^:private apply-description
  [parsed descripion-prod]
  (cond-> parsed
    descripion-prod (assoc :description (xform descripion-prod))))

(defn ^:private apply-directives
  [element directiveList]
  (if directiveList
    (assoc element :directives (xform directiveList))
    element))

(defmethod xform :schemaDef
  [prod]
  (let [sub-prods (drop 2 prod)
        directiveList (when (= :directiveList (-> sub-prods first first))
                        (first sub-prods))
        remaining-prods (if directiveList
                          (rest sub-prods)
                          sub-prods)]
    [[:roots] (-> (checked-map "schema entry" (map xform remaining-prods))
                  ;; Temporary location until patch-schema-directives is invoked
                  (apply-directives directiveList))]))

(defn ^:private patch-schema-directives
  [schema]
  (if-let [directives (get-in schema [:roots :directives])]
    (-> schema
        (assoc :directives directives)
        (update :roots dissoc :directives))
    schema))

(defmethod xform :operationTypeDef
  [prod]
  (xform (second prod)))

(defmethod xform :queryOperationDef
  [prod]
  (let [[_ _ type-prod] prod]
    [:query (xform type-prod)]))

(defmethod xform :mutationOperationDef
  [prod]
  (let [[_ _ type-prod] prod]
    [:mutation (xform type-prod)]))

(defmethod xform :subscriptionOperationDef
  [prod]
  (let [[_ _ type-prod] prod]
    [:subscription (xform type-prod)]))

(defmethod xform :typeName
  [prod]
  (let [name-k (xform-second prod)]
    ;; By convention, these type names for built-in types are represented as
    ;; symbols, not keywords.
    (if (#{:Boolean :String :Int :Float :ID} name-k)
      (-> name-k name symbol)
      name-k)))

(defmethod xform :name
  [prod]
  (-> prod second keyword))

(defmethod xform :anyName
  [prod]
  (xform-second prod))

(defmethod xform :nameTokens
  [prod]
  (xform (list :name (-> prod second second))))

(defmethod xform :description
  [prod]
  (xform-second prod))

(defmethod xform :typeDef
  [prod]
  (let [{:keys [anyName implementationDef fieldDefs description directiveList]
         :or   {fieldDefs (list :fieldDefs)}} (tag prod)]
    [[:objects (xform anyName)]
     (-> {:fields (xform fieldDefs)}
         (common/copy-meta anyName)
         (apply-description description)
         (apply-directives directiveList)
         (cond-> implementationDef (assoc :implements (xform implementationDef))))]))

(defmethod xform :typeExtDef
  [prod]
  (let [{:keys [anyName implementationDef fieldDefs description directiveList]
         :or   {fieldDefs (list :fieldDefs)}} (tag prod)]
    (with-meta [[:objects (xform anyName)]
                (-> {:fields (xform fieldDefs)}
                    (common/copy-meta anyName)
                    (common/add-meta {:extension true})
                    (apply-description description)
                    (apply-directives directiveList)
                    (cond-> implementationDef (assoc :implements (xform implementationDef))))]
               {:extension true})))

(defmethod xform :directiveDef
  [prod]
  (let [{:keys [anyName argList directiveLocationList description]} (tag prod)]
    [[:directive-defs (xform anyName)]
     (-> {:locations (xform directiveLocationList)}
         (common/copy-meta anyName)
         (apply-description description)
         (cond->
           argList (assoc :args (xform argList))))]))

(defmethod xform :directiveLocationList
  [prod]
  (->> prod
       rest
       (filter #(-> % first (= :directiveLocation)))
       (map xform)
       set))

(defn ^:private directive-name->keyword
  [s]
  (-> s
      str/lower-case
      (str/replace "_" "-")
      keyword))

(defmethod xform :directiveLocation
  [prod]
  (-> prod
      second
      second
      second
      directive-name->keyword))

(defmethod xform :directiveList
  [prod]
  (mapv xform (rest prod)))

(defmethod xform :directive
  [prod]
  (let [{:keys [anyName directiveArgList]} (tag prod)]
    (-> {:directive-type (xform anyName)}
        (common/copy-meta anyName)
        (cond->
          directiveArgList (assoc :directive-args (xform directiveArgList))))))

(defmethod xform :directiveArgList
  [prod]
  (checked-map "directive argument"
               (->> prod
                    rest
                    (map xform))))

(defmethod xform :directiveArg
  [prod]
  (let [[_ k v] prod]
    [(xform k) (xform v)]))

(defmethod xform :fieldDefs
  [prod]
  (checked-map "field" (map xform (rest prod))))

(defmethod xform :fieldDef
  [prod]
  (let [{:keys [anyName typeSpec argList description directiveList]} (tag prod)]
    [(xform anyName)
     (-> {:type (xform typeSpec)}
         (common/copy-meta anyName)
         (apply-description description)
         (apply-directives directiveList)
         (cond->
           argList (assoc :args (xform argList))))]))

(defmethod xform :argList
  [prod]
  (checked-map "field argument" (map xform (rest prod))))

(defmethod xform :argument
  [prod]
  (let [{:keys [anyName typeSpec defaultValue description directiveList]} (tag prod)]
    [(xform anyName)
     (-> {:type (xform typeSpec)}
         (common/copy-meta anyName)
         (apply-description description)
         (apply-directives directiveList)
         (cond-> defaultValue (assoc :default-value (xform-second defaultValue))))]))

(defmethod xform :value
  [prod]
  (xform-second prod))

(defmethod xform :enumValue
  [prod]
  (xform-second prod))

(defmethod xform :booleanvalue
  [prod]
  (Boolean/valueOf ^String (second prod)))

(defmethod xform :intvalue
  [prod]
  (Integer/parseInt ^String (second prod)))

(defmethod xform :floatvalue
  [prod]
  (Float/parseFloat ^String (second prod)))

(defmethod xform :implementationDef
  [prod]
  (->> prod
       rest
       (filter #(-> % first (= :name)))
       (mapv xform)))

(defmethod xform :typeSpec
  [prod]
  (let [[_ type required] prod
        base-type (-> type xform)]
    (if (some? required)
      (list 'non-null base-type)
      base-type)))

(defmethod xform :listType
  [prod]
  (list 'list (xform-second prod)))

(defmethod xform :interfaceDef
  [prod]
  (let [{:keys [anyName fieldDefs description directiveList]
         :or   {fieldDefs (list :fieldDefs)}} (tag prod)]
    [[:interfaces (xform anyName)]
     (-> {:fields (xform fieldDefs)}
         (common/copy-meta anyName)
         (apply-description description)
         (apply-directives directiveList))]))

(defmethod xform :unionDef
  [prod]
  (let [{:keys [description anyName unionTypes directiveList]} (tag prod)]
    [[:unions (xform anyName)]
     (-> {:members (xform unionTypes)}
         (common/copy-meta anyName)
         (apply-description description)
         (apply-directives directiveList))]))

(defmethod xform :unionTypes
  [prod]
  (->> prod
       rest
       (filter #(-> % first (= :anyName)))
       (mapv xform)))

(defmethod xform :enumDef
  [prod]
  (let [{:keys [description anyName enumValueDefs directiveList]} (tag prod)]
    [[:enums (xform anyName)]
     (-> {:values (xform enumValueDefs)}
         (common/copy-meta anyName)
         (apply-description description)
         (apply-directives directiveList))]))

(defmethod xform :enumValueDefs
  [prod]
  (mapv xform (rest prod)))

(defmethod xform :enumValueDef
  [prod]
  (let [{:keys [description nameTokens directiveList]} (tag prod)]
    (-> {:enum-value (xform nameTokens)}
        (common/copy-meta nameTokens)
        (apply-description description)
        (apply-directives directiveList))))

(defmethod xform :inputTypeDef
  [prod]
  (let [{:keys [anyName fieldDefs description directiveList]
         :or   {fieldDefs (list :fieldDefs)}} (tag prod)]
    [[:input-objects (xform anyName)]
     (-> {:fields (xform fieldDefs)}
         (common/copy-meta anyName)
         (apply-description description)
         (apply-directives directiveList))]))

(defmethod xform :scalarDef
  [prod]
  (let [{:keys [anyName description directiveList]} (tag prod)]
    [[:scalars (xform anyName)]
     (-> {}
         (common/copy-meta anyName)
         (apply-description description)
         (apply-directives directiveList))]))

(defmethod xform :objectValue
  [prod]
  (-> (mapv xform (rest prod))
      (as-> % (checked-map "object key" %))
      (common/copy-meta prod)))

(defmethod xform :objectField
  [prod]
  (let [[_ name value] prod]
    [(xform name)
     (xform value)]))

(defmethod xform :stringvalue
  [prod]
  (-> prod second common/stringvalue->String))

(defmethod xform :blockstringvalue
  [prod]
  (-> prod second common/blockstringvalue->String))

(defmethod xform :arrayValue
  [prod]
  (common/copy-meta (mapv xform (rest prod)) prod))

(defn ^:private xform-schema
  "Given an ANTLR parse tree, returns a Lacinia schema."
  [antlr-tree resolvers scalars streamers documentation]
  (let [schema (->> antlr-tree
                    rest
                    (map xform)
                    (sort-by (fn [x] (if (is-extension? x) 1 0)))
                    (reduce (fn [schema [path value]]
                              (let [path' (butlast path)
                                    k (last path)]
                                ;; Generally, the path is two values (a category such
                                ;; as :objects, and a key within), but there's also
                                ;; [:root] (for the schema production).
                                (if-not (seq path')
                                  (assoc schema k value)
                                  (update-in schema path'
                                             assoc-check
                                             (-> path' last name) k value))))
                            {}))]
    (-> schema
        (attach-field-fns :resolve resolvers)
        (attach-field-fns :stream streamers)
        ;; TODO: This should inject stuff into the scalar, not replace it, right?
        (attach-scalars scalars)
        (inject-descriptions documentation)
        patch-schema-directives)))

(defn parse-schema
  "Given a GraphQL schema string, parses it and returns a Lacinia EDN
  schema. Defers validation of the schema to the downstream schema
  validator.

  Directives may be declared and used, but validation of directives is
  also deferred downstream.

  `attach` should be a map consisting of the following keys:

  `:resolvers` is expected to be a map of:
  {:type-name {:field-name resolver-fn}}

  `:scalars` is expected to be a map of:
  {:scalar-name {:parse parse-spec
                 :serialize serialize-spec}}

  A scalar map may also include a :description.

  The provided scalar maps are merged into the scalars parsed from the document.

  `:streamers` is expected to be a map of:
  {:type-name {:subscription-field-name stream-fn}}

  `:documentation` is expected to be a map of:
  {:type-name doc-str
   :type-name/field-name doc-str
   :type-name/field-name.arg-name doc-str}"
  [schema-string attach]
  (when-let [ed (s/explain-data ::parse-schema-args [schema-string attach])]
    (throw (ex-info (str "Arguments to parse-schema do not conform to spec:\n" (with-out-str (s/explain-out ed)))
                    ed)))

  (let [{:keys [resolvers scalars streamers documentation]} attach]
    (xform-schema (try
                    (common/antlr-parse grammar schema-string)
                    (catch ParseError e
                      (let [failures (common/parse-failures e)]
                        (throw (ex-info "Failed to parse GraphQL schema."
                                        {:errors failures})))))
                  resolvers
                  scalars
                  streamers
                  documentation)))

(s/def ::field-fn (s/map-of simple-keyword? (s/or :function ::schema/function-or-var
                                                  :keyword simple-keyword?)))
(s/def ::fn-map (s/map-of simple-keyword? ::field-fn))
(s/def ::parse ::schema/parse-or-serialize-fn)
(s/def ::serialize ::schema/parse-or-serialize-fn)
(s/def ::scalar-def (s/keys :req-un [::parse ::serialize]
                            :opt-un [::description]))
(s/def ::description string?)

(s/def ::documentation (s/map-of keyword? string?))
(s/def ::scalars (s/map-of simple-keyword? ::scalar-def))
(s/def ::resolvers ::fn-map)
(s/def ::streamers ::fn-map)

(s/def ::parse-schema-args (s/cat :schema-string string?
                                  :attachments (s/keys :opt-un [::resolvers
                                                                ::streamers
                                                                ::scalars
                                                                ::documentation])))