diff options
| -rw-r--r-- | README.org | 3 | ||||
| -rw-r--r-- | kolam/graphql.scm | 190 | ||||
| -rw-r--r-- | kolam/parse.scm | 568 |
3 files changed, 761 insertions, 0 deletions
diff --git a/README.org b/README.org new file mode 100644 index 0000000..326ec08 --- /dev/null +++ b/README.org @@ -0,0 +1,3 @@ +#+TITLE: kolam + +kolam is a [[https://graphql.org/][GraphQL]] implementation for Scheme. diff --git a/kolam/graphql.scm b/kolam/graphql.scm new file mode 100644 index 0000000..676caa4 --- /dev/null +++ b/kolam/graphql.scm @@ -0,0 +1,190 @@ +;;; kolam --- GraphQL implementation +;;; Copyright © 2021 Arun Isaac <arunisaac@systemreboot.net> +;;; +;;; This file is part of kolam. +;;; +;;; kolam is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU Affero General Public License as +;;; published by the Free Software Foundation; either version 3 of the +;;; License, or (at your option) any later version. +;;; +;;; kolam is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Affero General Public License for more details. +;;; +;;; You should have received a copy of the GNU Affero General Public +;;; License along with kolam. If not, see +;;; <http://www.gnu.org/licenses/>. + +(define-module (kolam graphql) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-19) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-71) + #:use-module (ice-9 match) + #:export (graphql-evaluator + graphql-schema + define-object-type + define-scalar-type + define-enum-type + non-nullable-type + list-type + <integer> + <float> + <string> + <boolean> + <id> + <date>)) + +(define-record-type <schema> + (make-schema query mutation) + schema? + (query schema-query) + (mutation schema-mutation)) + +(define* (graphql-schema #:key query mutation) + (make-schema query mutation)) + +(define-record-type <field> + (make-field name type resolver) + field? + (name field-name) + (type delayed-field-type) + (resolver field-resolver)) + +(define field-type (compose force delayed-field-type)) + +(define-record-type <object-type> + (make-object-type identifier fields) + object-type? + (identifier object-type-identifier) + (fields object-type-fields)) + +(define-syntax-rule (define-object-type identifier (name type resolver) ...) + (define identifier + (make-object-type 'identifier + (list (make-field 'name (delay type) resolver) ...)))) + +(define-record-type <scalar-type> + (make-scalar-type identifier predicate serializer) + scalar-type? + (identifier scalar-type-identifier) + (predicate scalar-type-predicate) + (serializer scalar-type-serializer)) + +(define-syntax-rule (define-scalar-type identifier predicate serializer) + (define identifier + (make-scalar-type 'identifier predicate serializer))) + +(define-scalar-type <integer> integer? identity) +(define-scalar-type <float> + (lambda (x) + (and (real? x) + (not (rational? x)))) + identity) +(define-scalar-type <string> string? identity) +(define-scalar-type <boolean> boolean? identity) +(define-scalar-type <id> string? identity) +(define-scalar-type <date> date? (cut date->string <> "~4")) + +(define-record-type <non-nullable-type> + (non-nullable-type subtype) + non-nullable-type? + (subtype non-nullable-type-subtype)) + +(define-record-type <list-type> + (list-type subtype) + list-type? + (subtype list-type-subtype)) + +(define-record-type <enum-type> + (make-enum-type enumerators) + enum-type? + (enumerators enum-type-enumerators)) + +(define-syntax-rule (define-enum-type identifier enumerators ...) + (define identifier + (make-enum-type (list enumerators ...)))) + +(define (find-field type field) + "Find field named FIELD in TYPE." + (find (lambda (root-type-field) + (eq? (field-name root-type-field) + field)) + (object-type-fields type))) + +(define (correct-type? value type) + "Return non-#f if VALUE is of GraphQL TYPE. Else, return #f." + (cond + ((scalar-type? type) + ((scalar-type-predicate type) value)) + ((enum-type? type) + (member value + (enum-type-enumerators type))) + ((non-nullable-type? type) + (and (not (eq? value 'null)) + (correct-type? value (non-nullable-type-subtype type)))) + ((list-type? type) + (and (list? value) + (every (cut correct-type? <> (list-type-subtype type)) + value))) + ((object-type? type) #t) + (else (error "Unknown type:" type)))) + +(define (graphql-evaluator schema) + (match-lambda + (('query tree) + (eval-graphql tree (schema-query schema))) + (operation (error "Invalid GraphQL operation:" operation)))) + +(define* (eval-graphql tree parent-type #:optional parent) + (let* ((root args children (match tree + ((#(root args ...) children ...) (values root args children)) + ((root children ...) (values root '() children)) + (#(leaf args ...) (values leaf args #f)) + (leaf (values leaf '() #f)))) + ;; TODO: Check if required args are present. + (root-field (or (find-field parent-type root) + (error "Unknown field:" root))) + (root-type (field-type root-field)) + (underlying-type (if (non-nullable-type? root-type) + (non-nullable-type-subtype root-type) + root-type)) + (next-parent (apply (field-resolver root-field) + parent #f #f args))) + (unless (correct-type? next-parent root-type) + (error "Return value of resolver is of unexpected GraphQL type:" + next-parent root-type)) + (when (and (not children) + (not (or (scalar-type? underlying-type) + (enum-type? underlying-type)))) + (error "Leaf node must be scalar or enum type:" root-field underlying-type)) + (cons root + (cond + ((eq? next-parent 'null) 'null) + ;; List of non-object types + ((and (list-type? underlying-type) + (not (object-type? (list-type-subtype underlying-type)))) + (list->vector next-parent)) + ;; List of object types + ((list-type? underlying-type) + (list->vector + (map (lambda (next-parent-element) + (map (cut eval-graphql + <> + (list-type-subtype underlying-type) + next-parent-element) + children)) + next-parent))) + ;; Non-leaf node + (children + (map (cut eval-graphql <> underlying-type next-parent) + children)) + ;; Leaf node of a scalar type + ((scalar-type? underlying-type) + ((scalar-type-serializer underlying-type) next-parent)) + ;; Leaf node of enum type + ((enum-type? underlying-type) next-parent) + (else (error "eval-graphql bug: Unknown underlying-type:" underlying-type)))))) diff --git a/kolam/parse.scm b/kolam/parse.scm new file mode 100644 index 0000000..fa05148 --- /dev/null +++ b/kolam/parse.scm @@ -0,0 +1,568 @@ +;;; kolam --- GraphQL implementation +;;; Copyright © 2021 Arun Isaac <arunisaac@systemreboot.net> +;;; +;;; This file is part of kolam. +;;; +;;; kolam is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU Affero General Public License as +;;; published by the Free Software Foundation; either version 3 of the +;;; License, or (at your option) any later version. +;;; +;;; kolam is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Affero General Public License for more details. +;;; +;;; You should have received a copy of the GNU Affero General Public +;;; License along with kolam. If not, see +;;; <http://www.gnu.org/licenses/>. + +(define-module (kolam parse) + #:use-module (rnrs io ports) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-71) + #:use-module (ice-9 match) + #:use-module ((ice-9 textual-ports) #:select (unget-string)) + #:export (graphql->scm + graphql-string->scm)) + + +;;; Lexer + +;; FIXME: Error out all readers on unexpected end of input. +(define (read-name port) + (call-with-output-string + (lambda (out) + (put-char out (get-char port)) + (let loop () + (let ((c (lookahead-char port))) + (when (and (not (eof-object? c)) + (char-set-contains? (char-set-union + (char-set #\_) + (char-set-intersection char-set:letter+digit + char-set:ascii)) + c)) + (put-char out (get-char port)) + (loop))))))) + +(define (read-digit-sequence port) + (call-with-output-string + (lambda (out) + (let loop () + (let ((c (lookahead-char port))) + (when (and (not (eof-object? c)) + (char-set-contains? (char-set-intersection char-set:digit + char-set:ascii) + c)) + (put-char out (get-char port)) + (loop))))))) + +(define (read-integer-part port) + ;; FIXME: 00 is apparently not a valid int-value. + (string-append (string (get-char port)) + (read-digit-sequence port))) + +(define (read-escaped-character port) + "Read an escaped character from PORT. The port position should be +after the backslash character that initiated the escaped character." + (let ((c (get-char port))) + (string-ref + (call-with-input-string + (string-append (string #\") + (case c + ;; The forward slash needs to be escaped in + ;; GraphQL, but not in Scheme. + ((#\/) (string #\/)) + ;; Usual escape sequences + ((#\" #\\ #\b #\f #\n #\r #\t) + (string #\\ c)) + ;; Unicode character + ((#\u) + (string-append (string #\\ #\u) + (get-string-n port 4))) + (else (error "Invalid escape sequence character" c))) + (string #\")) + read) + 0))) + +(define (lookahead-string-n port count) + (let ((str (get-string-n port count))) + (unless (eof-object? str) + (unget-string port str)) + str)) + +(define (read-string port) + (get-char port) + (call-with-output-string + (lambda (out) + (let loop () + (let ((c (get-char port))) + (unless (eof-object? c) + (cond + ((char-set-contains? (char-set #\newline #\return) + c) + (error "Unexpected line terminator in string")) + ((char=? c #\\) + (put-char out (read-escaped-character port)) + (loop)) + ((not (char=? c #\")) + (put-char out c) + (loop))))))))) + +(define (string-blank? str) + "Return non-#f if STR contains only whitespace characters. Else, +return #f." + (string-every char-set:whitespace str)) + +(define (drop-right-while pred lst) + "Drop the longest suffix of LST whose elements all satisfy PRED." + (reverse (drop-while pred (reverse lst)))) + +(define (block-string-value str) + (let* ((trimmed-lines (drop-right-while string-blank? + (drop-while string-blank? + (string-split str #\newline)))) + (common-indent + (match trimmed-lines + ((first-line other-lines ...) + (fold (lambda (line result) + (if (string-blank? line) + result + (min result (string-index line + (char-set-complement char-set:whitespace))))) + (string-index first-line (char-set-complement char-set:whitespace)) + other-lines))))) + (string-join (map (lambda (line) + (if (string-blank? line) + line + (substring line common-indent))) + trimmed-lines) + "\n"))) + +(define (read-block-string port) + (get-string-n port 3) + (call-with-output-string + (lambda (out) + (let loop () + (cond + ;; End of blockstring + ((or (eof-object? (lookahead-string-n port 3)) + (string=? (lookahead-string-n port 3) + "\"\"\"")) + (get-string-n port 3)) + ;; Escaped triple quote + ((string=? (lookahead-string-n port 4) + "\\\"\"\"") + (get-string-n port 4) + (put-string out "\"\"\"") + (loop)) + (else + (put-char out (get-char port)) + (loop))))))) + +(define (make-lexer port) + (lambda () + (let loop () + (let ((c (lookahead-char port))) + (cond + ((eof-object? c) c) + ;; Ignored + ((char-set-contains? (char-set (integer->char #xFEFF) + #\tab #\space #\newline #\return #\,) + c) + (get-char port) + (loop)) + ;; Comments + ((char=? c #\#) + (get-line port) + (when (eq? (lookahead-char port) #\return) + (get-char port)) + (loop)) + ;; Punctuator + ((char-set-contains? (char-set #\! #\$ #\& #\( #\) + #\… #\: #\= #\@ #\[ #\] + #\{ #\| #\}) + c) + (cons 'punctuator (get-char port))) + ;; Name + ((char-set-contains? (char-set-union + (char-set #\_) + (char-set-intersection char-set:letter + char-set:ascii)) + c) + (cons 'name (read-name port))) + ;; Numbers + ((char-set-contains? (char-set-union + (char-set #\-) + (char-set-intersection char-set:digit + char-set:ascii)) + c) + (let ((integer-part (read-integer-part port)) + (fractional-part (case (lookahead-char port) + ((#\.) + (get-char port) + (read-digit-sequence port)) + (else #f))) + (exponential-part (case (lookahead-char port) + ((#\e #\E) + (get-char port) + (read-integer-part port)) + (else #f)))) + (cond + ((and (not fractional-part) + (not exponential-part)) + (cons 'int-value integer-part)) + (else + (cons 'float-value + (string-append integer-part + (if fractional-part + (string-append "." fractional-part) + "") + (if exponential-part + (string-append "e" exponential-part) + ""))))))) + ;; String value + ((eq? c #\") + (cons 'string-value + (if (string=? (lookahead-string-n port 3) + "\"\"\"") + (block-string-value + (read-block-string port)) + (read-string port)))) + (else (error "kolam lexer bug, unidentified token at character:" c))))))) + + +;;; Parser +;;; +;;; Every parser function (*-pattern functions) is a procedure that +;;; takes a list of tokens as an argument and returns the result of the +;;; match and the remaining tokens. The result of the match must be #f +;;; or a pair. +;;; +;;; If the match was unsuccessful, the result of the match must be +;;; #f. Else, it must be a pair, with the first element being the +;;; symbol identifying the matched object, and the second element being +;;; the object itself. + +(define-record-type <optional> + (make-optional) + optional?) + +(define %optional (make-optional)) + +(define-syntax pattern-optional + (syntax-rules () + ((_ proc pattern) + (pattern-optional-function (delay pattern) proc)) + ((_ pattern) + (pattern-optional-function (delay pattern))))) + +(define* (pattern-optional-function pattern #:optional proc) + (lambda (tokens) + (let ((matched remaining-tokens ((force pattern) tokens))) + (if matched + (values (if proc + (proc (strip-token-id matched)) + matched) + remaining-tokens) + (values (cons 'optional %optional) + tokens))))) + +(define* (many-collect pattern tokens #:optional (result '())) + (if (null? tokens) + (values (reverse result) tokens) + (let ((matched remaining-tokens (pattern tokens))) + (if matched + (many-collect pattern remaining-tokens (cons matched result)) + (values (reverse result) tokens))))) + +(define strip-token-id + (match-lambda + ((_ . token-value) token-value) + (token (error "Invalid token:" token)))) + +(define-syntax-rule (pattern-many proc pattern) + (pattern-many-function proc (delay pattern))) + +(define* (pattern-many-function proc pattern) + (lambda (tokens) + (let ((matched remaining-tokens (many-collect (force pattern) tokens))) + (values (proc (map strip-token-id matched)) + remaining-tokens)))) + +(define* (and-collect patterns tokens #:optional (result '())) + (match patterns + (() (values (reverse result) tokens)) + ((pattern remaining-patterns ...) + (let ((matched remaining-tokens (pattern tokens))) + (if matched + (and-collect remaining-patterns remaining-tokens (cons matched result)) + (values #f tokens)))))) + +(define-syntax-rule (pattern-and proc patterns ...) + (pattern-and-function proc (delay patterns) ...)) + +(define (pattern-and-function proc . patterns) + (lambda (tokens) + (let ((matched remaining-tokens (and-collect (map force patterns) + tokens))) + (if matched + (values (apply proc (map strip-token-id matched)) + remaining-tokens) + (values #f tokens))))) + +(define* (or-collect patterns tokens #:optional (result '())) + (match patterns + (() (values #f tokens)) + ((pattern remaining-patterns ...) + (let ((matched remaining-tokens (pattern tokens))) + (if matched + (values matched remaining-tokens) + (or-collect remaining-patterns tokens (cons matched result))))))) + +(define-syntax-rule (pattern-or proc patterns ...) + (pattern-or-function proc (delay patterns) ...)) + +(define (pattern-or-function proc . patterns) + (lambda (tokens) + (let ((matched remaining-tokens (or-collect (map force patterns) tokens))) + (if matched + (values (proc matched) + remaining-tokens) + (values #f tokens))))) + +(define-syntax-rule (pattern-not pattern) + (pattern-not-function (delay pattern))) + +(define (pattern-not-function pattern) + (lambda (tokens) + (let ((matched remaining-tokens ((force pattern) tokens))) + (values (and (not matched) + (cons 'negation 'null)) + tokens)))) + +(define (token-pattern token) + (lambda (tokens) + (match tokens + (((head-id . head-value) tail ...) + (if (eq? head-id token) + (values (cons head-id head-value) + tail) + (values #f tokens))) + (() (values #f tokens))))) + +(define (token-value-pattern token-id token-value) + (lambda (tokens) + (match tokens + ((head tail ...) + (if (equal? head (cons token-id token-value)) + (values head tail) + (values #f tokens))) + (() (values #f tokens))))) + +(define variable-pattern + (pattern-and (lambda (dollar name) + (cons 'variable name)) + (token-value-pattern 'punctuator #\$) + (token-pattern 'name))) + +(define alias-pattern + (pattern-and (lambda (name colon) + (cons 'alias (string->symbol name))) + (token-pattern 'name) + (token-value-pattern 'punctuator #\:))) + +(define operation-type-pattern + (pattern-or (match-lambda + (('name . value) + (cons 'operation-type (string->symbol value)))) + (token-value-pattern 'name "query") + (token-value-pattern 'name "mutation") + (token-value-pattern 'name "subscription"))) + +(define selection-set-pattern + (pattern-and (lambda (open selections close) + (cons 'selection-set selections)) + (token-value-pattern 'punctuator #\{) + (pattern-many (cut cons 'selections <>) selection-pattern) + (token-value-pattern 'punctuator #\}))) + +(define selection-pattern + (pattern-or (match-lambda + (('field . field) + (cons 'selection field))) + field-pattern + ;; TODO: Implement fragments. + ;; fragment-spread-pattern + ;; inline-fragment-pattern + )) + +(define field-pattern + (pattern-and (lambda (alias name arguments selection-set) + (let* ((name (string->symbol name)) + (arguments (if (optional? arguments) + (list) + arguments)) + (main-node + (match (if (optional? alias) + arguments + (cons alias arguments)) + (() name) + (alias-and-arguments (apply vector name alias-and-arguments))))) + (cons 'field + (if (optional? selection-set) + main-node + (cons main-node selection-set))))) + (pattern-optional alias-pattern) + (token-pattern 'name) + (pattern-optional arguments-pattern) + ;; TODO: Implement directives. + ;; (pattern-optional directives-pattern) + (pattern-optional selection-set-pattern))) + +(define arguments-pattern + (pattern-and (lambda (open arguments close) + (cons 'arguments (apply append arguments))) + (token-value-pattern 'punctuator #\() + (pattern-many (cut cons 'arguments <>) argument-pattern) + (token-value-pattern 'punctuator #\)))) + +(define argument-pattern + (pattern-and (lambda (name colon value) + (cons 'argument (list (symbol->keyword (string->symbol name)) + value))) + (token-pattern 'name) + (token-value-pattern 'punctuator #\:) + value-pattern)) + +(define boolean-value-pattern + (pattern-or (match-lambda + (('name . value) + (cons 'boolean-value value))) + (token-value-pattern 'name "true") + (token-value-pattern 'name "false"))) + +(define null-value-pattern + (pattern-or (match-lambda + (('name . "null") + (cons 'null-value "null"))) + (token-value-pattern 'name "null"))) + +(define enum-value-pattern + (pattern-and (lambda (not1 not2 name) + (cons 'enum-value name)) + (pattern-not boolean-value-pattern) + (pattern-not null-value-pattern) + (token-pattern 'name))) + +(define list-value-pattern + (pattern-or identity + (pattern-and (lambda _ + (cons 'list-value (list))) + (token-value-pattern 'punctuator #\[) + (token-value-pattern 'punctuator #\])) + (pattern-and (lambda (open values close) + (cons 'list-value values)) + (token-value-pattern 'punctuator #\[) + (pattern-many (cut cons 'values <>) value-pattern) + (token-value-pattern 'punctuator #\])))) + +(define object-value-pattern + (pattern-or identity + (pattern-and (lambda _ + (cons 'object-value (list))) + (token-value-pattern 'punctuator #\{) + (token-value-pattern 'punctuator #\})) + (pattern-and (lambda (open object-fields close) + (cons 'object-value object-fields)) + (token-value-pattern 'punctuator #\{) + (pattern-many (cut cons 'object-fields <>) object-field-pattern) + (token-value-pattern 'punctuator #\})))) + +(define object-field-pattern + (pattern-and (lambda (name colon value) + (list 'object-field name value)) + (token-pattern 'name) + (token-value-pattern 'punctuator #\:) + (token-pattern 'value))) + +(define value-pattern + (pattern-or (match-lambda + (((or 'int-value 'float-value) . value) + (cons 'value (string->number value))) + ((_ . value) + (cons 'value value))) + variable-pattern + (token-pattern 'int-value) + (token-pattern 'float-value) + (token-pattern 'string-value) + boolean-value-pattern + null-value-pattern + enum-value-pattern + list-value-pattern + object-value-pattern)) + +(define operation-definition-pattern + (pattern-or (match-lambda + (('operation-definition . operation-definition) + (cons 'operation-definition operation-definition)) + (('selection-set . selection-set) + (cons 'operation-definition + (cons 'query selection-set)))) + (pattern-and (lambda (operation-type name selection-set) + ;; TODO: Use name. + (cons 'operation-definition + (cons operation-type selection-set))) + operation-type-pattern + (pattern-optional (token-pattern 'name)) + ;; TODO: Implement variables and directives. + ;; (pattern-optional variable-definitions-pattern) + ;; (pattern-optional directives-pattern) + selection-set-pattern) + selection-set-pattern)) + +(define executable-definition-pattern + (pattern-or (match-lambda + (('operation-definition . operation-definition) + (cons 'executable-definition operation-definition))) + operation-definition-pattern + ;; TODO: Implement fragments. + ;; fragment-definition-pattern + )) + +(define executable-document-pattern + (pattern-many (lambda (executable-definitions) + (cons 'executable-document executable-definitions)) + executable-definition-pattern)) + +(define definition-pattern + (pattern-or (match-lambda + (('executable-definition . executable-definition) + (cons 'definition executable-definition))) + executable-definition-pattern)) + +(define document-pattern + (pattern-many (lambda (definitions) + (cons 'document definitions)) + definition-pattern)) + + +;;; Public interface and other functions + +(define (drain-lexer lexer) + (let ((token (lexer))) + (if (eof-object? token) + '() + (cons token (drain-lexer lexer))))) + +(define (graphql->scm port) + (let ((matched remaining-tokens (document-pattern (drain-lexer (make-lexer port))))) + (if (null? remaining-tokens) + matched + (error "Expected end of GraphQL document")))) + +(define (graphql-string->scm str) + (call-with-input-string str + graphql->scm)) |