# HG changeset patch
# User Theodor Thornhill <theo@thornhill.no>
# Date 1638965270 -3600
#      Wed Dec 08 13:07:50 2021 +0100
# Node ID 67934022eafc61685014ba724051f9b46e645b74
# Parent  baa6bbc481d4e0acddcf167db9bda8e7c9f9af4e
Start reporting errors compliantly

Fixes: https://todo.sr.ht/~theo/gql/13
Fixes: https://todo.sr.ht/~theo/gql/25

diff --git a/example/example1.lisp b/example/example1.lisp
--- a/example/example1.lisp
+++ b/example/example1.lisp
@@ -23,7 +23,7 @@
                ("Query" . query-resolvers))))
 
       (with-schema *example-schema*
-        (let ((result (execute-request (query item) nil *variable-values* nil)))
+        (let ((result (execute (query item) nil *variable-values* nil)))
           (format nil "~a~%" (cl-json:encode-json-to-string result)))))))
 
 (defvar *server* (make-instance 'hunchentoot:easy-acceptor :port 3000))
diff --git a/example/example2.lisp b/example/example2.lisp
--- a/example/example2.lisp
+++ b/example/example2.lisp
@@ -52,8 +52,7 @@
 
 (defun example2 (query)
   (with-schema (build-schema (asdf:system-relative-pathname 'gql-tests #p"t/test-files/validation-schema.graphql"))
-    (let* ((res (gql::execute-request
-                 (build-schema query) nil (make-hash-table :test #'equal) nil)))
+    (let* ((res (gql::execute (build-schema query) nil (make-hash-table :test #'equal) nil)))
       (format t "~%~a" (cl-json:encode-json-to-string res)))))
 
 (let ((*resolvers*
diff --git a/src/execution.lisp b/src/execution.lisp
--- a/src/execution.lisp
+++ b/src/execution.lisp
@@ -106,11 +106,13 @@
   (let ((query-type (gethash "Query" *all-types*)))
     (check-type query-type object-type-definition)
     (with-slots (selection-set) query
-      (let ((results (make-hash-table :test #'equal)))
-        (setf (gethash "data" results)
-              (execute-selection-set (selections selection-set) query-type initial-value variable-values))
-        (setf (gethash "errors" results) *errors*)
-        results))))
+      (setf (gethash "data" *result*)
+            (execute-selection-set (selections selection-set) query-type initial-value variable-values))
+      (when *errors*
+        ;; TODO: This might be too strict.  It may be okay to leave some data here.
+        (setf (gethash "data" *result*) nil)
+        (setf (gethash "errors" *result*) *errors*))
+      *result*)))
 
 (declaim (ftype (function (operation-definition hash-table t) hash-table) execute-mutation))
 (defun execute-mutation (mutation variable-values initial-value)
@@ -118,11 +120,13 @@
   (let ((mutation-type (gethash "Mutation" *all-types*)))
     (check-type mutation-type object-type-definition)
     (with-slots (selection-set) mutation
-      (let ((results (make-hash-table :test #'equal)))
-        (setf (gethash "data" results)
-              (execute-selection-set (selections selection-set) mutation-type initial-value variable-values))
-        (setf (gethash "errors" results) *errors*)
-        results))))
+      (setf (gethash "data" *result*)
+            (execute-selection-set (selections selection-set) mutation-type initial-value variable-values))
+      (when *errors*
+        ;; TODO: This might be too strict.  It may be okay to leave some data here.
+        (setf (gethash "data" *result*) nil)
+        (setf (gethash "errors" *result*) *errors*))
+      *result*)))
 
 (defun subscribe (subscription variable-values initial-value)
   ;; TODO: https://spec.graphql.org/draft/#Subscribe()
@@ -307,8 +311,7 @@
 
 (defun execute-request (document operation-name variable-values initial-value)
   ;; https://spec.graphql.org/draft/#sec-Executing-Requests
-  (let* ((*errors* nil)
-         (operation (get-operation document operation-name))
+  (let* ((operation (get-operation document operation-name))
          (coerced-vars (coerce-vars operation variable-values)))
     (string-case (operation-type operation)
       ("Query"        (execute-query operation coerced-vars initial-value))
@@ -346,3 +349,12 @@
             :for selection :in (selections field-selection-set)
             :do (push selection selection-set))
     :finally (return (nreverse selection-set))))
+
+(defun execute (document operation-name variable-values initial-value)
+  (let ((*result* (make-hash-table :test #'equal))
+        (*errors* nil))
+    (validate document)
+    (if *errors*
+        (setf (gethash "errors" *result*) *errors*)
+        (execute-request document operation-name variable-values initial-value))
+    *result*))
diff --git a/src/language.lisp b/src/language.lisp
--- a/src/language.lisp
+++ b/src/language.lisp
@@ -34,8 +34,7 @@
                  (every-definition-executable-p definitions)
                  (operation-name-unique-p definitions)
                  (single-anonymous-operation-definition-p definitions)
-                 (subscription-operation-valid-p)
-                 (values *data* *errors*)))
+                 (subscription-operation-valid-p)))
   :generator (defgenerator document ()
                "~{~a~%~}" (gather-nodes (definitions node) indent-level)))
 
diff --git a/src/package.lisp b/src/package.lisp
--- a/src/package.lisp
+++ b/src/package.lisp
@@ -6,9 +6,8 @@
    #:gql
    #:build-schema
    #:generate
-   #:validate
    #:with-schema
-   #:execute-request
+   #:execute
    #:*resolvers*
    #:resolve
    #:bool
diff --git a/src/specials.lisp b/src/specials.lisp
--- a/src/specials.lisp
+++ b/src/specials.lisp
@@ -24,8 +24,8 @@
   "Hash-table containing all types from schema *SCHEMA*.
 Should be bound together with *schema* when needed.")
 
-(defvar *data* nil
-  "Data to be returned to client after validation and execution.")
+(defvar *result* nil
+  "Hash table to contain the results of an execution.")
 
 (defvar *errors* nil
   "Errors to be returned to client after validation and execution.")
diff --git a/src/utils.lisp b/src/utils.lisp
--- a/src/utils.lisp
+++ b/src/utils.lisp
@@ -66,18 +66,33 @@
           (setf (gethash (name name) node-table) node))))))
 
 (defclass* errors
-  nodes
-  message)
+  message
+  locations
+  path
+  extensions)
+
+(defclass* error-location
+  line
+  column)
 
 (defun make-error (message nodes)
-  (let ((error-nodes (if (listp nodes) nodes (list nodes))))
-    (push (make-instance 'errors
-                         :message message
-                         :nodes error-nodes)
+  (let ((node-list (if (listp nodes) nodes (list nodes))))
+    (push (make-instance
+           'errors
+           :message message
+           :locations (mapcar
+                       (lambda (node)
+                         (let ((start-token (start-token (location node))))
+                           (make-instance
+                            'error-location
+                            :line (line start-token)
+                            :column (column start-token))))
+                       node-list)
+           :path nil
+           :extensions nil)
           *errors*)))
 
 (defun name-or-alias (field)
-  ;; TODO: This one is probably no good
   (with-slots (alias name) field
     (if alias
         (name alias)
diff --git a/t/execution-tests.lisp b/t/execution-tests.lisp
--- a/t/execution-tests.lisp
+++ b/t/execution-tests.lisp
@@ -45,11 +45,11 @@
         (setf (gethash "name" dog-resolver) (lambda (arg) (declare (ignorable arg))
                                               "Bingo-bongo"))
         (setf (gethash "owner" dog-resolver) (lambda (arg) (declare (ignorable arg)) t))
-        (let* ((res (gql::execute-request (build-schema "query { dog { name } dog { owner { name } } }") nil (make-hash-table) nil))
+        (let* ((res (gql::execute (build-schema "query { dog { name } dog { owner { name } } }") nil (make-hash-table) nil))
                (data (gethash "data" res))
                (dog-res (gethash "dog" data)))
           (ok (typep res 'hash-table))
-          (ok (= (hash-table-count res) 2))
+          (ok (= (hash-table-count res) 1))
           (ok (= (hash-table-count dog-res) 2))
           (ok (gethash "name" dog-res))
           (ok (gethash "owner" dog-res))))))
@@ -68,11 +68,11 @@
         (setf (gethash "name" dog-resolver) (lambda (arg) (declare (ignorable arg))
                                               "Bingo-bongo"))
         (setf (gethash "owner" dog-resolver) (lambda (arg) (declare (ignorable arg)) t))
-        (let* ((res (gql::execute-request (build-schema "query { dog { name owner { name: nameAlias } } }") nil (make-hash-table) nil))
+        (let* ((res (gql::execute (build-schema "query { dog { name owner { name: nameAlias } } }") nil (make-hash-table) nil))
                (data (gethash "data" res))
                (dog-res (gethash "dog" data)))
           (ok (typep res 'hash-table))
-          (ok (= (hash-table-count res) 2))
+          (ok (= (hash-table-count res) 1))
           (ok (= (hash-table-count dog-res) 2))
           (ok (gethash "name" dog-res))
           (ok (gethash "owner" dog-res))))))
@@ -91,7 +91,7 @@
               (lambda (arg args) (declare (ignorable arg))
                 (if (string= (gethash "dogCommand" args) "SIT")
                     'true 'false)))
-        (let* ((res (gql::execute-request
+        (let* ((res (gql::execute
                      (build-schema "query x($sit: String) { dog { doesKnowCommand(dogCommand: $sit) } }")
                      nil
                      variable-values
@@ -140,13 +140,13 @@
               (lambda (arg) (declare (ignorable arg))
                 (make-instance 'dog :name "Bingo-bongo")))
         (setf (gethash "name" dog-resolver) (lambda (dog) (name dog)))
-        (let* ((res (gql::execute-request
+        (let* ((res (gql::execute
                      (build-schema "query { dog { name } }") nil (make-hash-table) nil))
                (data (gethash "data" res))
                (dog (gethash "dog" data))
                (name (gethash "name" dog)))
           (ok (string= name "Bingo-bongo")))
-        (let* ((res (gql::execute-request
+        (let* ((res (gql::execute
                      (build-schema "query { dog { name: bongo } }") nil (make-hash-table) nil))
                (data (gethash "data" res))
                (dog (gethash "dog" data))
@@ -177,7 +177,7 @@
                               :test #'equal)
                       'true 'false))))
 
-        (let* ((res (gql::execute-request
+        (let* ((res (gql::execute
                      (build-schema "query x($sit: String) { dog { doesKnowCommand(dogCommand: $sit) } }")
                      nil
                      variable-values
@@ -187,7 +187,7 @@
                (command (gethash "doesKnowCommand" dog)))
           (ok (string= command "true")))
         (setf (gethash "sit" variable-values) "SITT")
-        (let* ((res (gql::execute-request
+        (let* ((res (gql::execute
                      (build-schema "query x($sit: String) { dog { doesKnowCommand(dogCommand: $sit) } }")
                      nil
                      variable-values
@@ -197,7 +197,7 @@
                (command (gethash "doesKnowCommand" dog)))
           (ok (string= command "false")))
         ;; (setf (gethash "sit" variable-values) "SIT")
-        ;; (let* ((res (gql::execute-request
+        ;; (let* ((res (gql::execute
         ;;              (build-schema "query { dog { doesKnowCommand(dogCommand: \"SIT\") } }")
         ;;              nil
         ;;              variable-values
@@ -206,7 +206,7 @@
         ;;        (dog (gethash "dog" data))
         ;;        (command (gethash "doesKnowCommand" dog)))
         ;;   (ok (string= command "true")))
-        (let* ((res (gql::execute-request
+        (let* ((res (gql::execute
                      (build-schema "query { dog { doesKnowCommand(dogCommand: \"LOL\") } }")
                      nil
                      variable-values
@@ -301,13 +301,13 @@
 
       (flet ((doggo-test (query)
                (with-schema (build-schema (asdf:system-relative-pathname 'gql-tests #p"t/test-files/validation-schema.graphql"))
-                 (let* ((res (gql::execute-request (build-schema query) nil (make-hash-table :test #'equal) nil)))
+                 (let* ((res (gql::execute (build-schema query) nil (make-hash-table :test #'equal) nil)))
                    (format nil "~a" (cl-json:encode-json-to-string res))))))
 
         (ok (string=
              (doggo-test "query { dog { name owner { name pets { name nickname } } } }")
-             "{\"data\":{\"dog\":{\"name\":\"Bingo-Bongo\",\"owner\":{\"name\":\"Wingle Wangle\",\"pets\":[{\"name\":\"Bingo-Bongo\",\"nickname\":\"Hund!\"},{\"name\":\"Bango-Wango\",\"nickname\":\"Mjausig\"}]}}},\"errors\":null}"))
+             "{\"data\":{\"dog\":{\"name\":\"Bingo-Bongo\",\"owner\":{\"name\":\"Wingle Wangle\",\"pets\":[{\"name\":\"Bingo-Bongo\",\"nickname\":\"Hund!\"},{\"name\":\"Bango-Wango\",\"nickname\":\"Mjausig\"}]}}}}"))
 
         (ok (string=
              (doggo-test "query { dog: doggo { name: Bingo owner { name: Wingle pets: dogs { name nickname: thisIsFun } } } }")
-             "{\"data\":{\"doggo\":{\"Bingo\":\"Bingo-Bongo\",\"owner\":{\"Wingle\":\"Wingle Wangle\",\"dogs\":[{\"name\":\"Bingo-Bongo\",\"thisIsFun\":\"Hund!\"},{\"name\":\"Bango-Wango\",\"thisIsFun\":\"Mjausig\"}]}}},\"errors\":null}"))))))
+             "{\"data\":{\"doggo\":{\"Bingo\":\"Bingo-Bongo\",\"owner\":{\"Wingle\":\"Wingle Wangle\",\"dogs\":[{\"name\":\"Bingo-Bongo\",\"thisIsFun\":\"Hund!\"},{\"name\":\"Bango-Wango\",\"thisIsFun\":\"Mjausig\"}]}}}}"))))))
diff --git a/t/utils.lisp b/t/utils.lisp
--- a/t/utils.lisp
+++ b/t/utils.lisp
@@ -33,15 +33,14 @@
 (defun generator-test (input output)
   (ok (string-equal (generate (build-schema input)) output)))
 
-(defun validator-test (input &key no-schema)
+(defun validator-test-helper (input &key no-schema)
   (with-schema (if no-schema
                    (build-schema input)
                    (build-schema (asdf:system-relative-pathname
                                   'gql-tests
                                   #p"t/test-files/validation-schema.graphql")))
-    (setf gql::*errors* nil)
-    (setf gql::*data* nil)
-    (validate (build-schema input))))
+    (let ((gql::*errors* nil))
+      
+      (gql::validate (build-schema input))
+      (cl-json:encode-json-to-string gql::*errors*))))
 
-(defun validator-errors-p (input &key no-schema)
-  (nth-value 1 (validator-test input :no-schema no-schema)))
diff --git a/t/validation-tests.lisp b/t/validation-tests.lisp
--- a/t/validation-tests.lisp
+++ b/t/validation-tests.lisp
@@ -3,181 +3,30 @@
 (deftest validation
   (testing "Only allows ExecutableDefintition in a Document"
     ;; https://spec.graphql.org/draft/#sec-Executable-Definitions
-    (ok
-     (validator-errors-p
-      "query getDogName {
-  dog {
-    name
-    color
-  }
-}
-
-extend type Dog {
-  color: String
-}
-"))
-    (ok
-     (validator-errors-p
-      "query getDogName {
-  dog {
-    name
-    color
-  }
-}
-
-mutation dogOperation {
-  mutateDog {
-    id
-  }
-}
-
-extend type Dog {
-  color: String
-}
-"))
-    (ng
-     (validator-test
-      "query getDogName {
-  dog {
-    name
-    color
-  }
-}
-"))
-    (ng
-     (validator-test
-      "query getDogName {
-  dog {
-    name
-    color
-  }
-}
-mutation dogOperation {
-  mutateDog {
-    id
-  }
-}
-
-fragment friendFields on User {
-  id
-  name
-  profilePic(size: 50)
-}"))
-    (ng
-     (validator-test ;; multiple queries with unique names are ok
-      "query getDogName {
-  dog {
-    name
-  }
-}
-
-query getOwnerName {
-  dog {
-    owner {
-      name
-    }
-  }
-}
-"))
-    (ok
-     (validator-errors-p
-      "query getName {
-  dog {
-    name
-  }
-}
+    (ok (string=  "[{\"message\":\"Each definition must be executable.\",\"locations\":[{\"line\":1,\"column\":40}],\"path\":null,\"extensions\":null}]"
+                  (validator-test-helper
+                   "query getDogName { dog { name color } } extend type Dog { color: String }")))
+    (ok (string= "[{\"message\":\"Each definition must be executable.\",\"locations\":[{\"line\":1,\"column\":83}],\"path\":null,\"extensions\":null}]"
+                 (validator-test-helper
+                  "query getDogName { dog { name color } } mutation dogOperation { mutateDog { id } } extend type Dog { color: String }")))
+    (ok (string= "null" (validator-test-helper "query getDogName { dog { name color } }")))
+    (ok (string= "null" (validator-test-helper "query getDogName { dog { name color } } mutation dogOperation { mutateDog { id } } fragment friendFields on User { id name profilePic(size: 50) }")))
+    (ok (string= "null" (validator-test-helper "query getDogName { dog { name } } query getOwnerName { dog { owner { name } } }")))
+    (ok (string= "[{\"message\":\"Each operation must have a unique name.\",\"locations\":[{\"line\":1,\"column\":0},{\"line\":1,\"column\":31}],\"path\":null,\"extensions\":null}]"
+         (validator-test-helper "query getName { dog { name } } query getName { dog { owner { name } } } ")))
+    (ok (string= "[{\"message\":\"Each operation must have a unique name.\",\"locations\":[{\"line\":1,\"column\":0},{\"line\":1,\"column\":36}],\"path\":null,\"extensions\":null}]"
+                 (validator-test-helper "query dogOperation { dog { name } } mutation dogOperation { mutateDog { id } } ")))
+    (ok (string= "[{\"message\":\"An anonymous definition must be alone.\",\"locations\":[{\"line\":1,\"column\":0}],\"path\":null,\"extensions\":null}]"
+                 (validator-test-helper "{ dog { name } } query getName { dog { owner { name } } }"))))
+  (testing "Subscription validation"
+    (ok (string= "null" (validator-test-helper "subscription sub { newMessage { body sender } } ")))
+    (ok (string= "[{\"message\":\"A subscription must have exactly one entry.\",\"locations\":[{\"line\":1,\"column\":0}],\"path\":null,\"extensions\":null}]"
+                 (validator-test-helper "subscription sub { newMessage { body sender } disallowedSecondRootField }" :no-schema t)))
+    (ok (string= "[{\"message\":\"A subscription must have exactly one entry.\",\"locations\":[{\"line\":1,\"column\":0}],\"path\":null,\"extensions\":null}]"
+                 (validator-test-helper "subscription sub { ...multipleSubscriptions } fragment multipleSubscriptions on Subscription { newMessage { body sender } disallowedSecondRootField }" :no-schema t)))
+    (ok (string= "[{\"message\":\"Root field must not begin with \\\"__\\\"  which is reserved by GraphQL introspection.\",\"locations\":[{\"line\":1,\"column\":0}],\"path\":null,\"extensions\":null}]"
+                 (validator-test-helper "subscription sub { __typename }" :no-schema t))))
+  (testing "Each fragment’s name must be unique within a document"
+    (ok (string= "[{\"message\":\"An anonymous definition must be alone.\",\"locations\":[{\"line\":1,\"column\":0}],\"path\":null,\"extensions\":null},{\"message\":\"Each operation must have a unique name.\",\"locations\":[{\"line\":1,\"column\":27},{\"line\":1,\"column\":64}],\"path\":null,\"extensions\":null}]"
+                 (validator-test-helper "{ dog { ...fragmentOne } } fragment fragmentOne on Dog { name } fragment fragmentOne on Dog { owner { name } }")))))
 
-query getName {
-  dog {
-    owner {
-      name
-    }
-  }
-}
-"))
-    (ok
-     (validator-errors-p
-      "query dogOperation {
-  dog {
-    name
-  }
-}
-
-mutation dogOperation {
-  mutateDog {
-    id
-  }
-}
-"))
-    (ok
-     (validator-errors-p
-      "{
-  dog {
-    name
-  }
-}
-
-query getName {
-  dog {
-    owner {
-      name
-    }
-  }
-}")))
-  (testing "Subscription validation"
-    (ng
-     (validator-errors-p
-      "subscription sub {
-  newMessage {
-    body
-    sender
-  }
-}
-"))
-    (ok
-     (validator-errors-p
-      "subscription sub {
-  newMessage {
-    body
-    sender
-  }
-  disallowedSecondRootField
-}" :no-schema t))
-    (ok
-     (validator-errors-p
-      "subscription sub {
-  ...multipleSubscriptions
-}
-
-fragment multipleSubscriptions on Subscription {
-  newMessage {
-    body
-    sender
-  }
-  disallowedSecondRootField
-}" :no-schema t))
-    (ok
-     (validator-errors-p
-      "subscription sub {
-  __typename
-}" :no-schema t))
-    )
-  (testing "Each fragment’s name must be unique within a document"
-    (ok
-     (validator-errors-p
-      "{
-  dog {
-    ...fragmentOne
-  }
-}
-
-fragment fragmentOne on Dog {
-  name
-}
-
-fragment fragmentOne on Dog {
-  owner {
-    name
-  }
-}"))))
-
diff --git a/wiki/examples/example1.md b/wiki/examples/example1.md
--- a/wiki/examples/example1.md
+++ b/wiki/examples/example1.md
@@ -82,7 +82,7 @@
                ("Query" . query-resolvers))))
 
       (with-schema *example-schema*
-        (let ((result (execute-request (query item) nil *variable-values* nil)))
+        (let ((result (execute (query item) nil *variable-values* nil)))
           (format nil "~a~%" (cl-json:encode-json-to-string result)))))))
 ```
 
diff --git a/wiki/examples/example2.md b/wiki/examples/example2.md
--- a/wiki/examples/example2.md
+++ b/wiki/examples/example2.md
@@ -93,7 +93,7 @@
 ```lisp
 (defun example2 (query)
   (with-schema (build-schema (asdf:system-relative-pathname 'gql-tests #p"t/test-files/validation-schema.graphql"))
-    (let* ((res (gql::execute-request
+    (let* ((res (gql::execute
                  (build-schema query) nil (make-hash-table :test #'equal) nil)))
       (format t "~a" (cl-json:encode-json-to-string res)))))
 ```