# HG changeset patch # User Theodor Thornhill # Date 1639685125 -3600 # Thu Dec 16 21:05:25 2021 +0100 # Node ID ab97e91a22ee7ccbe293c77a05f2e9e5e3e1ac1e # Parent 19e576a569c51d6d83f653a4dd648e59db64f476 Add crazy type functions Bad idea? Probably diff --git a/example/example1.lisp b/example/example1.lisp --- a/example/example1.lisp +++ b/example/example1.lisp @@ -8,30 +8,29 @@ (defparameter *fields* (list - (gql::field :name "name" - :type (make-instance 'gql::named-type :name (make-instance 'gql::name :name "String")) + (field :name "name" + :type *string* :resolver (constantly "Theodor Thornhill")) - (gql::field :name "age" - :type (make-instance 'gql::named-type :name (make-instance 'gql::name :name "Int")) + (field :name "age" + :type *int* :resolver (constantly 31)))) +(defparameter *query* + (gql::object :name "Query" :fields *fields*)) + + (defvar *example-schema* - (build-schema `(,(gql::object :name "Query" :fields *fields*)))) + (make-schema :query *query*)) (defvar *variable-values* (make-hash-table :test #'equal)) (hunchentoot:define-easy-handler (home :uri "/home") (item) (setf (hunchentoot:content-type*) "text/plain") (when item - (with-schema *example-schema* - (let ((result (execute (build-schema (format nil "{ __type(name: Query) { name } }")) - nil - *variable-values* nil))) - (format nil "~a~%" (cl-json:encode-json-to-string result)))))) + (with-context (:schema *example-schema* + :document (build-document "{ __type(name: Query) { name } }")) + (format nil "~a~%" (cl-json:encode-json-to-string (execute)))))) (defvar *server* (make-instance 'hunchentoot:easy-acceptor :port 3000)) -(defun query (item) - (build-schema (format nil "query { __type(name: Query) { name } }" item))) - ;; Eval this when you want to run the app (hunchentoot:start *server*) diff --git a/example/example2.lisp b/example/example2.lisp --- a/example/example2.lisp +++ b/example/example2.lisp @@ -63,11 +63,6 @@ :type (gql::list-type (gql::non-null-type (gql::named "Pet"))))))) -;; (defun example2 (query) -;; (with-schema (build-schema (asdf:system-relative-pathname 'gql-tests #p"t/test-files/validation-schema.graphql")) -;; (let* ((res (gql::execute (build-schema query) nil (make-hash-table :test #'equal) nil))) -;; (format t "~%~a" (cl-json:encode-json-to-string res))))) - (defun example2 (query) (with-context (:schema (gql::make-schema :query *query* :types (list *dog* *human*)) :document (build-document query)) @@ -75,7 +70,8 @@ (format t "~%~a" (cl-json:encode-json-to-string res))))) ;; (example2 "{ __schema { types { name ofType { name } } } }") -(example2 "{ __type(name: \"Dog\") { name fields { name type { name } } } }") +(example2 "{ __schema { queryType { name } } }") +;; (example2 "{ __type(name: \"Dog\") { name fields { name type { name } } } }") ;; (example2 "query { dog { name owner { name pets { name } } } }") ;; (example2 "query { dog { name owner { name } } }") ;; (example2 "query { dog { name owner: wingle { name pets: dogs { name } } } }") diff --git a/gql.asd b/gql.asd --- a/gql.asd +++ b/gql.asd @@ -13,6 +13,7 @@ (:file "utils") (:file "lexer") (:file "language") + (:file "types") (:file "schema") (:file "introspection") (:file "conditions") diff --git a/src/execution.lisp b/src/execution.lisp --- a/src/execution.lisp +++ b/src/execution.lisp @@ -59,19 +59,17 @@ (defun get-operation (document &optional operation-name) ;; TODO: https://spec.graphql.org/draft/#GetOperation() - (cond - ((null operation-name) - (let ((operation - (remove-if-not (lambda (x) (typep x 'operation-definition)) - (definitions document)))) - (if (= 1 (length operation)) - (car operation) - (gql-error "Need to raise a request error: https://spec.graphql.org/draft/#GetOperation()")))) - (t - (let ((operation - (gethash operation-name (get-types 'operation-definition document)))) - (if operation operation - (gql-error "Need to raise a request error: https://spec.graphql.org/draft/#GetOperation()")))))) + (if (null operation-name) + (let ((operation + (remove-if-not (lambda (x) (typep x 'operation-definition)) + (definitions document)))) + (if (= 1 (length operation)) + (car operation) + (gql-error "Need to raise a request error: https://spec.graphql.org/draft/#GetOperation()"))) + (let ((operation + (gethash operation-name (get-types 'operation-definition document)))) + (if operation operation + (gql-error "Need to raise a request error: https://spec.graphql.org/draft/#GetOperation()"))))) (defun input-type-p (type) ;; TODO: https://spec.graphql.org/draft/#IsInputType() diff --git a/src/introspection.lisp b/src/introspection.lisp --- a/src/introspection.lisp +++ b/src/introspection.lisp @@ -5,21 +5,22 @@ :description "A GraphQL Schema defines the capabilities of a GraphQL server." :fields `(,(field :name "description" :description "A description of the current schema." - :type (named "String") + :type *string* :resolver (lambda () (description (schema *context*)))) ,(field :name "types" :description "A list of all types supported by this server." - :type (non-null-type (list-type (non-null-type (named "__Type")))) + :type ([!]! "__Type") :resolver (lambda () (let ((types nil)) - (maphash (lambda (k v) - (unless (uiop:string-prefix-p "__" k) - (push v types))) - (type-map (schema *context*))) + (with-slots (type-map) (schema *context*) + (maphash (lambda (k v) + (unless (uiop:string-prefix-p "__" k) + (push v types))) + type-map)) types))) ,(field :name "queryType" :description "The type that query operations will be rooted at." - :type (non-null-type (named "__Type")) + :type (! "__Type") :resolver (lambda () (query-type (schema *context*)))) ,(field :name "mutationType" :description "If this server supports mutation, the type that mutation operations will be rooted at." @@ -30,7 +31,7 @@ :type (named "__Type") :resolver (lambda () (subscription-type (schema *context*)))) ,(field :name "directives" - :type (non-null-type (list-type (non-null-type "__Directive"))) + :type ([!]! "__Directive") :resolver (lambda () (directives (schema *context*))))))) (defvar *__type* @@ -38,123 +39,126 @@ :fields `(,(field :name "kind" :type (non-null-type "__TypeKind")) ,(field :name "name" - :type (named "String") + :type *string* :resolver (lambda () (name (object-value (execution-context *context*))))) ,(field :name "description" - :type (named "String") + :type *string* :resolver (lambda () (description (object-value (execution-context *context*))))) ,(field :name "fields" - :type (list-type (non-null-type (named "__Field"))) + :type ([!] "__Field") :resolver (lambda () - (let ((fields nil)) - (maphash (lambda (k v) (declare (ignore k)) - (push v fields)) - (fields (object-value (execution-context *context*)))) - fields))) + (with-slots (fields) (object-value (execution-context *context*)) + (let ((result nil)) + (maphash (lambda (k v) (declare (ignore k)) + (push v fields)) + fields) + result)))) ,(field :name "interfaces" - :type (list-type (non-null-type (named "__Type")))) + :type ([!] "__Type")) ,(field :name "possibleTypes" - :type (list-type (non-null-type (named "__Type")))) + :type ([!] "__Type")) ,(field :name "enumValues" - :type (list-type (non-null-type (named "__EnumValue")))) + :type ([!] "__EnumValue")) ,(field :name "inputFields" - :type (list-type (non-null-type (named "__InputValue")))) + :type ([!] "__InputValue")) ,(field :name "ofType" :type (named "__Type") :resolver (lambda () *__type*)) ,(field :name "specifiedByUrl" - :type (named "String") + :type *string* :resolver (lambda () "Hello"))))) (defvar *__type-kind* (enum :name "__TypeKind" :description "An enum describing what kind of type a given `__Type` is" - :enum-values `(,(enum-val :enum-value "SCALAR") - ,(enum-val :enum-value "OBJECT") - ,(enum-val :enum-value "INTERFACE") - ,(enum-val :enum-value "UNION") - ,(enum-val :enum-value "ENUM") - ,(enum-val :enum-value "INPUT_OBJECT") - ,(enum-val :enum-value "LIST") - ,(enum-val :enum-value "NON_NULL")))) + :enum-values `(,(enum-val :enum-value (make-name "SCALAR")) + ,(enum-val :enum-value (make-name "OBJECT")) + ,(enum-val :enum-value (make-name "INTERFACE")) + ,(enum-val :enum-value (make-name "UNION")) + ,(enum-val :enum-value (make-name "ENUM")) + ,(enum-val :enum-value (make-name "INPUT_OBJECT")) + ,(enum-val :enum-value (make-name "LIST")) + ,(enum-val :enum-value (make-name "NON_NULL"))))) (defvar *__field* (object :name "__Field" :description "Object and Interface types are described by a list of Fields, each of which has a name, potentially a list of arguments, and a return type." :fields `(,(field :name "name" - :type (non-null-type (named "String")) + :type (! *string*) :resolver (lambda () (name (object-value (execution-context *context*))))) ,(field :name "description" - :type (named "String")) + :type *string*) ,(field :name "args" - :type (non-null-type (list-type (non-null-type (named "__InputValue"))))) + :type ([!]! "__InputValue")) ,(field :name "type" - :type (non-null-type (named "__Type")) - :resolver (lambda () (ty (object-value (execution-context *context*))))) + :type (! "__Type") + :resolver (lambda () + (with-slots (object-value) (execution-context *context*) + (ty object-value)))) ,(field :name "isDeprecated" - :type (non-null-type (named "Boolean"))) + :type (! *boolean*)) ,(field :name "deprecationReason" - :type (named "String"))))) + :type *string*)))) (defvar *__input-value* (object :name "__InputValue" :fields `(,(field :name "name" - :type (non-null-type (named "String"))) + :type (! *string*)) ,(field :name "description" - :type (named "String")) + :type *string*) ,(field :name "type" - :type (non-null-type (named "Type"))) + :type (! "Type")) ,(field :name "defaultValue" - :type (named "String"))))) + :type *string*)))) (defvar *__enum-value* (object :name "__EnumValue" :fields `(,(field :name "name" - :type (non-null-type (named "String"))) + :type (! *string*)) ,(field :name "description" - :type (named "String")) + :type *string*) ,(field :name "isDeprecated" - :type (non-null-type (named "Boolean"))) + :type (! *boolean*)) ,(field :name "deprecationReason" - :type (named "String"))))) + :type *string*)))) (defvar *__directive* (object :name "__Directive" :fields `(,(field :name "name" - :type (non-null-type (named "String"))) + :type (! *string*)) ,(field :name "description" - :type (named "String")) + :type *string*) ,(field :name "location" - :type (non-null-type (list-type (non-null-type (named "__DirectiveLocation"))))) + :type ([!]! "__DirectiveLocation")) ,(field :name "args" - :type (non-null-type (named "Boolean")))))) + :type (! *boolean*))))) (defvar *__directive-location* (enum :name "__DirectiveLocation" - :enum-values `(,(enum-val :enum-value "QUERY") - ,(enum-val :enum-value "MUTATION") - ,(enum-val :enum-value "SUBSCRIPTION") - ,(enum-val :enum-value "FIELD") - ,(enum-val :enum-value "FRAGMENT_DEFINITION") - ,(enum-val :enum-value "FRAGMENT_SPREAD") - ,(enum-val :enum-value "INLINE_FRAGMENT") - ,(enum-val :enum-value "SCHEMA") - ,(enum-val :enum-value "SCALAR") - ,(enum-val :enum-value "OBJECT") - ,(enum-val :enum-value "FIELD_DEFINITION") - ,(enum-val :enum-value "ARGUMENT_DEFINITION") - ,(enum-val :enum-value "INTERFACE") - ,(enum-val :enum-value "UNION") - ,(enum-val :enum-value "ENUM") - ,(enum-val :enum-value "ENUM_VALUE") - ,(enum-val :enum-value "INPUT_OBJECT") - ,(enum-val :enum-value "INPUT_FIELD_DEFINITION")))) + :enum-values `(,(enum-val :enum-value (make-name "QUERY")) + ,(enum-val :enum-value (make-name "MUTATION")) + ,(enum-val :enum-value (make-name "SUBSCRIPTION")) + ,(enum-val :enum-value (make-name "FIELD")) + ,(enum-val :enum-value (make-name "FRAGMENT_DEFINITION")) + ,(enum-val :enum-value (make-name "FRAGMENT_SPREAD")) + ,(enum-val :enum-value (make-name "INLINE_FRAGMENT")) + ,(enum-val :enum-value (make-name "SCHEMA")) + ,(enum-val :enum-value (make-name "SCALAR")) + ,(enum-val :enum-value (make-name "OBJECT")) + ,(enum-val :enum-value (make-name "FIELD_DEFINITION")) + ,(enum-val :enum-value (make-name "ARGUMENT_DEFINITION")) + ,(enum-val :enum-value (make-name "INTERFACE")) + ,(enum-val :enum-value (make-name "UNION")) + ,(enum-val :enum-value (make-name "ENUM")) + ,(enum-val :enum-value (make-name "ENUM_VALUE")) + ,(enum-val :enum-value (make-name "INPUT_OBJECT")) + ,(enum-val :enum-value (make-name "INPUT_FIELD_DEFINITION"))))) (defvar *__schema-field-definition* (field :description "Request the schema information." :name "__schema" :args nil - :type (non-null-type (named "__Schema")) + :type (! "__Schema") :resolver (lambda () (schema *context*)))) (defvar *__type-field-definition* @@ -163,16 +167,16 @@ :args `(,(make-instance 'input-value-definition :name (make-name "name") :description nil - :ty (non-null-type (named "String")))) + :ty (! "String"))) :type (named "__Type") :resolver (lambda () - (let* ((args (arg-values (execution-context *context*))) - (name (gethash "name" args))) - (gethash name (type-map (schema *context*))))))) + (with-slots (schema execution-context) *context* + (let* ((name (gethash "name" (arg-values execution-context)))) + (gethash name (type-map schema))))))) (defvar *__typename-field-definition* (field :description "The name of the current Object type at runtime." :name "__typename" :args nil - :type (non-null-type (named "String")) + :type (! "String") :resolver (lambda () (name (object-type (execution-context *context*)))))) diff --git a/src/package.lisp b/src/package.lisp --- a/src/package.lisp +++ b/src/package.lisp @@ -6,6 +6,7 @@ #:gql #:build-schema #:build-document + #:make-schema #:generate #:with-context #:execute @@ -14,4 +15,23 @@ #:true #:false #:gql-object - #:make-resolvers)) + #:make-name + #:named + #:list-type + #:non-null-type + #:field + #:object + #:interface + #:enum + #:enum-val + #:set-resolver + + #:*int* + #:*float* + #:*string* + #:*boolean* + #:*id* + #:! + #:[] + #:[!] + #:[!]!)) diff --git a/src/schema.lisp b/src/schema.lisp --- a/src/schema.lisp +++ b/src/schema.lisp @@ -102,7 +102,7 @@ (enum-type-definition (when (listp (enum-values object-type)) (dolist (enum-val (enum-values object-type)) - (setf (gethash (enum-value enum-val) table) enum-val)) + (setf (gethash (name (enum-value enum-val)) table) enum-val)) (setf (enum-values object-type) table))) (union-type-definition (when (listp (union-members object-type)) diff --git a/src/specials.lisp b/src/specials.lisp --- a/src/specials.lisp +++ b/src/specials.lisp @@ -43,29 +43,3 @@ (arg-values :initarg :arg-values :accessor arg-values))) (defvar *execution-context* nil) - -(defun built-in-scalar-p (scalar) - (member scalar '("Int" "Float" "String" "Boolean" "ID") :test #'string=)) - -(deftype built-in-scalar () - '(and string (satisfies built-in-scalar-p))) - -(deftype wrapper-type () - '(member non-null-type list-type)) - -(deftype input-types () - '(member - scalar-type-definition - input-object-type-definition - enum-type-definition)) - -(deftype output-types () - '(member - scalar-type-definition - object-type-definition - enum-type-definition - interface-type-definition - union-type-definition)) - -(deftype bool () - '(member true false)) diff --git a/src/types.lisp b/src/types.lisp new file mode 100644 --- /dev/null +++ b/src/types.lisp @@ -0,0 +1,111 @@ +(in-package #:gql) + +(defun built-in-scalar-p (scalar) + (member scalar '("Int" "Float" "String" "Boolean" "ID") :test #'string=)) + +(deftype built-in-scalar () + '(and string (satisfies built-in-scalar-p))) + +(deftype wrapper-type () + '(member non-null-type list-type)) + +(deftype input-types () + '(member + scalar-type-definition + input-object-type-definition + enum-type-definition)) + +(deftype output-types () + '(member + scalar-type-definition + object-type-definition + enum-type-definition + interface-type-definition + union-type-definition)) + +(deftype bool () + '(member true false)) + +(defun make-name (type) + (check-type type string) + (make-instance 'name :name type :kind 'name)) + +(defun named (type) + (check-type type string) + (make-instance 'named-type + :kind 'named-type + :name (make-name type))) + +(defun list-type (type) + (make-instance 'list-type + :ty type + :kind 'list-type)) + +(defun non-null-type (type) + (make-instance 'non-null-type + :ty type + :kind 'non-null-type)) + +(defun maybe-named (type) + (if (stringp type) (named type) type)) + +(defun ! (type) + (non-null-type (maybe-named type))) + +(defun [] (type) + (list-type (maybe-named type))) + +(defun [!] (type) + ([] (! type))) + +(defun [!]! (type) + (! ([!] type))) + +(defvar *int* (named "Int")) +(defvar *float* (named "Float")) +(defvar *string* (named "String")) +(defvar *boolean* (named "Boolean")) +(defvar *id* (named "ID")) + +(defun field (&key name type resolver description args) + (make-instance 'field-definition + :kind 'field-definition + :description description + :args args + :ty type ;; TODO: Make sure we can use type instead of ty + :name (make-name name) + :resolver resolver)) + +(defun object (&key name fields interfaces description) + (make-instance 'object-type-definition + :kind 'object-type-definition + :description description + :name (make-name name) + :fields fields + :interfaces interfaces)) + +(defun interface (&key name fields directives description) + (make-instance 'interface-type-definition + :kind 'interface-type-definition + :description description + :name (make-name name) + :fields fields + :directives directives)) + +(defun enum (&key name enum-values description) + (make-instance 'enum-type-definition + :kind 'enum-type-definition + :enum-values enum-values + :description description + :name (make-name name))) + +(defun enum-val (&key enum-value) + (make-instance 'enum-value-definition + :kind 'enum-value + :enum-value enum-value)) + +(defun set-resolver (type-name field-name fn) + (let ((field-definition + (with-slots (type-map) (schema *context*) + (gethash field-name (fields (gethash type-name type-map )))))) + (setf (resolver field-definition) fn))) diff --git a/src/utils.lisp b/src/utils.lisp --- a/src/utils.lisp +++ b/src/utils.lisp @@ -124,77 +124,3 @@ :accessor resolver :initform nil ;;(gql-error "Need to supply resolver for gql types") ))) - -(defmacro make-resolvers (&body body) - `(let ((ht (make-hash-table :test #'equal))) - ,@(mapcar - (lambda (resolver) - `(setf (gethash ,(car resolver) ht) ,(cdr resolver))) - body) - ht)) - -;;; Type system things - -(defun make-name (type) - (check-type type string) - (make-instance 'name :name type :kind 'name)) - -(defun named (type) - (check-type type string) - (make-instance 'named-type - :kind 'named-type - :name (make-name type))) - -(defun list-type (type) - ;; TODO: Not done. What type goes here? - (make-instance 'list-type - :ty type - :kind 'list-type)) - -(defun non-null-type (type) - (make-instance 'non-null-type - :ty type - :kind 'non-null-type)) - -(defun field (&key name type resolver description args) - (make-instance 'field-definition - :kind 'field-definition - :description description - :args args - :ty type ;; TODO: Make sure we can use type instead of ty - :name (make-name name) - :resolver resolver)) - -(defun object (&key name fields interfaces description) - (make-instance 'object-type-definition - :kind 'object-type-definition - :description description - :name (make-name name) - :fields fields - :interfaces interfaces)) - -(defun interface (&key name fields directives description) - (make-instance 'interface-type-definition - :kind 'interface-type-definition - :description description - :name (make-name name) - :fields fields - :directives directives)) - -(defun enum (&key name enum-values description) - (make-instance 'enum-type-definition - :kind 'enum-type-definition - :enum-values enum-values - :description description - :name (make-name name))) - -(defun enum-val (&key enum-value) - (make-instance 'enum-value-definition - :kind 'enum-value - :enum-value enum-value)) - -(defun set-resolver (type-name field-name fn) - (declare (optimize (debug 3))) - (let ((field-definition - (gethash field-name (fields (gethash type-name (type-map (schema *context*))))))) - (setf (resolver field-definition) fn)))