1 (uiop:define-package
#:lw2.graphql
2 (:documentation
"Contains generic GraphQL client functionality required by lw2-viewer.")
3 (:use
#:cl
#:alexandria
#:iterate
#:lw2.macro-utils
)
4 (:import-from
#:trivial-macroexpand-all
#:macroexpand-all
)
5 (:import-from
#:trivial-cltl2
#:enclose
#:augment-environment
)
6 (:export
#:+graphql-timestamp-format
+ #:write-graphql-simple-field-list
#:graphql-query-string
* #:graphql-query-string
#:graphql-operation-string
#:graphql-mutation-string
#:timestamp-to-graphql
)
7 (:recycle
#:lw2.backend
#:lw2.login
))
9 (in-package #:lw2.graphql
)
11 (defconstant +graphql-timestamp-format
+ (if (boundp '+graphql-timestamp-format
+) (symbol-value '+graphql-timestamp-format
+)
12 (substitute-if '(:msec
3) (lambda (x) (and (listp x
) (eq (car x
) :usec
))) local-time
:+iso-8601-format
+)))
14 (defmacro declaim-grammar
(name)
15 ;; Forward declare a grammar form so it can be used before it is defined.
16 (let ((write-function (symbolicate '#:write- name
)))
17 `(eval-when (:compile-toplevel
:load-toplevel
:execute
)
18 (declaim (ftype function
,write-function
)
19 (notinline ,write-function
))
20 (pushnew ',name
*grammars
*))))
22 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
24 (defvar *grammars
* nil
)
26 (defun writer-macros (stream)
27 ;; Return the list of macro expanders that should be active to create a writer.
28 (labels ((grammar-writer-macro (grammar)
30 (macro-as-lambda grammar
(&rest args
) `(,(symbolicate '#:write- grammar
) ,@args
,stream
)))))
31 (append (macro-list-as-lambdas
32 (emit-string (&body body
)
33 `(write-string (progn ,@body
) ,stream
))
35 `(progn ,@(map 'list
(lambda (f) (gen-writer f stream
)) body
)))
36 (separated-list (type separator list
)
37 `(iter (for x in
,list
)
38 (unless (first-time-p)
39 ,(gen-writer separator stream
))
40 ,(gen-writer `(,type x
) stream
)))
41 (with-stream ((stream-binding) &body body
)
42 `(let ((,stream-binding
,stream
))
44 (iter (for grammar in
*grammars
*)
45 (collect (grammar-writer-macro grammar
))))))
47 (defun gen-writer (form stream
&optional env
)
48 ;; Convert a defgrammar form to a lisp form.
50 (string `(write-string ,form
,stream
))
54 (augment-environment env
:macro
(writer-macros stream
))))))
56 (defun writer-compiler-form (write-function args stream env whole
)
57 (if (every (lambda (x) (compiler-constantp x env
)) args
)
59 (with-output-to-string (c-stream)
60 (funcall (enclose `(lambda (c-stream)
61 (declare (notinline ,write-function
))
62 (,write-function
,@args c-stream
))
70 (defmacro defgrammar
(name args
&body body
)
71 (with-gensyms (stream)
72 (let ((write-function (symbolicate '#:write- name
)))
73 (pushnew name
*grammars
*)
74 `(eval-when (:compile-toplevel
:load-toplevel
:execute
)
75 (pushnew ',name
*grammars
*)
76 (defun ,write-function
(,@args
,stream
)
77 (declare (notinline ,write-function
))
78 ,(gen-writer (cons 'progn body
) stream
)
80 (define-compiler-macro ,write-function
(&whole whole
,@args
,stream
&environment env
)
81 (writer-compiler-form ',write-function
(list ,@args
) ,stream env whole
))))))
83 ;;; See the GraphQL spec, https://spec.graphql.org/June2018/
85 (defgrammar graphql-name
(obj)
86 (emit-string (etypecase obj
88 (symbol (json:lisp-to-camel-case
(string obj
))))))
90 (declaim-grammar graphql-simple-field-list
)
92 (defgrammar graphql-simple-field
(field)
94 (atom (graphql-name field
))
95 (list (emit (graphql-name (first field
))
96 (graphql-simple-field-list (rest field
))))))
98 (defgrammar graphql-simple-field-list
(fields)
99 (emit "{" (separated-list graphql-simple-field
"," fields
) "}"))
101 (declaim-grammar graphql-argument
)
103 (defgrammar graphql-value
(value)
105 ((member t
) (emit "true"))
106 ((member nil
) (emit "false"))
107 ((member :null
) (emit "null"))
108 ((member :undefined
) (emit "undefined"))
109 (symbol (graphql-name value
))
110 ((cons (member :list
) list
)
111 (emit "[" (separated-list graphql-value
"," (rest value
)) "]"))
113 (emit "{" (separated-list graphql-argument
"," value
) "}"))
114 (t (with-stream (stream) (json:encode-json value stream
)))))
116 (defgrammar graphql-argument
(cons)
117 (emit (graphql-name (car cons
))
119 (graphql-value (cdr cons
))))
121 (defgrammar graphql-argument-alist
(list)
123 (emit "(" (separated-list graphql-argument
"," list
) ")")))
125 (declaim-grammar graphql-field
)
127 (defgrammar graphql-combined-fields
(fields simple-fields
)
128 (when (or fields simple-fields
)
129 (emit "{" (separated-list graphql-field
"," fields
))
130 (when (and fields simple-fields
) (emit ","))
131 (emit (separated-list graphql-simple-field
"," simple-fields
) "}")))
133 (defgrammar graphql-field
(field)
134 (destructuring-bind (name &key args fields simple-fields
) field
135 (emit (graphql-name name
))
137 (graphql-argument-alist args
))
138 (graphql-combined-fields fields simple-fields
)))
140 (defgrammar graphql-field-list
(fields)
141 (emit "{" (separated-list graphql-field
"," fields
) "}"))
143 (defgrammar graphql-operation
(operation-type name variable-definitions fields simple-fields
)
144 (emit (graphql-name operation-type
) " "
146 (graphql-argument-alist variable-definitions
)
147 (graphql-combined-fields fields simple-fields
)))
149 (defgrammar graphql-simple-query
(query-type terms fields
)
150 (emit (graphql-name query-type
)
151 (graphql-argument-alist terms
)
152 (graphql-simple-field-list fields
)))
154 (defun graphql-query-string* (query-type terms fields
)
155 (with-output-to-string (stream)
156 (write-graphql-simple-query query-type terms fields stream
)))
158 (defun graphql-query-string (query-type terms fields
)
159 (with-output-to-string (stream)
160 (write-string "{" stream
)
161 (write-graphql-simple-query query-type terms fields stream
)
162 (write-string "}" stream
)))
164 (defun graphql-operation-string (operation-type query-type terms fields
)
165 (with-output-to-string (stream)
166 (write-graphql-name operation-type stream
)
167 (write-string "{" stream
)
168 (write-graphql-simple-query query-type terms fields stream
)
169 (write-string "}" stream
)))
171 (defun graphql-mutation-string (mutation-type terms fields
)
172 (format nil
"mutation ~A{~A}" mutation-type
(graphql-query-string* mutation-type terms fields
)))
174 (defun timestamp-to-graphql (timestamp)
175 (local-time:format-timestring nil timestamp
176 :format lw2.graphql
:+graphql-timestamp-format
+
177 :timezone local-time
:+utc-zone
+))