blob: 99105d71014b24913d604ce0037e5b3d100409f5 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
|
;;; kolam --- GraphQL implementation
;;; Copyright © 2021, 2022 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>
<datetime>))
(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 <datetime> 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)
(or (eq? value 'null)
((scalar-type-predicate type) value)))
((enum-type? type)
(member value
(cons 'null (enum-type-enumerators type))))
((non-nullable-type? type)
(and (not (eq? value 'null))
(correct-type? value (non-nullable-type-subtype type))))
((list-type? type)
(or (eq? value 'null)
(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 (tree->root+alias+args+children tree)
(let ((root children (match tree
((root children ...) (values root children))
(leaf (values leaf #f)))))
(match root
(#((? symbol? root) (? symbol? alias) args ...)
(values root alias args children))
(#((? symbol? root) args ...)
(values root #f args children))
(root (values root #f '() children)))))
(define (resolvable-type? type)
"Return non-#f if TYPE is fully resolvable, that is, it is composed
of scalar types, enum types, or lists thereof."
(if (list-type? type)
(resolvable-type? (list-type-subtype type))
(or (scalar-type? type)
(enum-type? type))))
(define* (eval-graphql tree parent-type #:optional parent)
(let* ((root alias args children (tree->root+alias+args+children tree))
;; 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 (resolvable-type? underlying-type)))
(error "Leaf node must be a scalar type, an enum type, or lists thereof:"
root-field underlying-type))
(cons (or alias 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))))))
|
