~theo/gql

a11b92d786eda4cc4e53b4959c67c52315e6c8f3 — Theodor Thornhill 8 months ago b85b5c7
Start reporting errors compliantly

Fixes: https://todo.sr.ht/~theo/gql/13
Fixes: https://todo.sr.ht/~theo/gql/25
M example/example1.lisp => example/example1.lisp +1 -1
@@ 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))

M example/example2.lisp => example/example2.lisp +1 -2
@@ 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*

M src/execution.lisp => src/execution.lisp +24 -12
@@ 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*))

M src/language.lisp => src/language.lisp +1 -2
@@ 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)))


M src/package.lisp => src/package.lisp +1 -2
@@ 6,9 6,8 @@
   #:gql
   #:build-schema
   #:generate
   #:validate
   #:with-schema
   #:execute-request
   #:execute
   #:*resolvers*
   #:resolve
   #:bool

M src/specials.lisp => src/specials.lisp +2 -2
@@ 24,8 24,8 @@ ensure we have initialized the schema.")
  "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.")

M src/utils.lisp => src/utils.lisp +22 -7
@@ 66,18 66,33 @@ documents."
          (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)

M t/execution-tests.lisp => t/execution-tests.lisp +14 -14
@@ 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\"}]}}}}"))))))

M t/utils.lisp => t/utils.lisp +5 -6
@@ 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)))

M t/validation-tests.lisp => t/validation-tests.lisp +24 -175
@@ 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
  }
}

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
    }
  }
}")))
    (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"
    (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))
    )
    (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
     (validator-errors-p
      "{
  dog {
    ...fragmentOne
  }
}

fragment fragmentOne on Dog {
  name
}

fragment fragmentOne on Dog {
  owner {
    name
  }
}"))))
    (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 } }")))))


M wiki/examples/example1.md => wiki/examples/example1.md +1 -1
@@ 82,7 82,7 @@ The last few things is running a server and defining an easy handler:
               ("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)))))))
```


M wiki/examples/example2.md => wiki/examples/example2.md +1 -1
@@ 93,7 93,7 @@ queries simple.  Our function looks like this:
```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)))))
```