src/graphql.lisp

   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))
   8
   9 (in-package #:lw2.graphql)
  10
  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+)))
  13
  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*))))
  21
  22 (eval-when (:compile-toplevel :load-toplevel :execute)
  23
  24   (defvar *grammars* nil)
  25
  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)
  29                (list 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))
  34                (emit (&body body)
  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))
  43                     ,@body)))
  44               (iter (for grammar in *grammars*)
  45                     (collect (grammar-writer-macro grammar))))))
  46
  47   (defun gen-writer (form stream &optional env)
  48     ;; Convert a defgrammar form to a lisp form.
  49     (etypecase form
  50       (string `(write-string ,form ,stream))
  51       (list
  52        (macroexpand-all
  53         form
  54         (augment-environment env :macro (writer-macros stream))))))
  55
  56   (defun writer-compiler-form (write-function args stream env whole)
  57     (if (every (lambda (x) (compiler-constantp x env)) args)
  58         (let ((out-string
  59                (with-output-to-string (c-stream)
  60                  (funcall (enclose `(lambda (c-stream)
  61                                       (declare (notinline ,write-function))
  62                                       (,write-function ,@args c-stream))
  63                                    env)
  64                           c-stream))))
  65           `(write-string
  66             ,out-string
  67             ,stream))
  68         whole)))
  69
  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)
  79            nil)
  80          (define-compiler-macro ,write-function (&whole whole ,@args ,stream &environment env)
  81            (writer-compiler-form ',write-function (list ,@args) ,stream env whole))))))
  82
  83 ;;; See the GraphQL spec, https://spec.graphql.org/June2018/
  84
  85 (defgrammar graphql-name (obj)
  86   (emit-string (etypecase obj
  87                  (string obj)
  88                  (symbol (json:lisp-to-camel-case (string obj))))))
  89
  90 (declaim-grammar graphql-simple-field-list)
  91
  92 (defgrammar graphql-simple-field (field)
  93   (typecase field
  94     (atom (graphql-name field))
  95     (list (emit (graphql-name (first field))
  96                 (graphql-simple-field-list (rest field))))))
  97
  98 (defgrammar graphql-simple-field-list (fields)
  99   (emit "{" (separated-list graphql-simple-field "," fields) "}"))
 100
 101 (declaim-grammar graphql-argument)
 102
 103 (defgrammar graphql-value (value)
 104   (typecase 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)) "]"))
 112               ((cons list list)
 113                (emit "{" (separated-list graphql-argument "," value) "}"))
 114               (t (with-stream (stream) (json:encode-json value stream)))))
 115
 116 (defgrammar graphql-argument (cons)
 117   (emit (graphql-name (car cons))
 118         ":"
 119         (graphql-value (cdr cons))))
 120
 121 (defgrammar graphql-argument-alist (list)
 122   (when list
 123     (emit "(" (separated-list graphql-argument "," list) ")")))
 124
 125 (declaim-grammar graphql-field)
 126
 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) "}")))
 132
 133 (defgrammar graphql-field (field)
 134   (destructuring-bind (name &key args fields simple-fields) field
 135     (emit (graphql-name name))
 136     (when args
 137       (graphql-argument-alist args))
 138     (graphql-combined-fields fields simple-fields)))
 139
 140 (defgrammar graphql-field-list (fields)
 141   (emit "{" (separated-list graphql-field "," fields) "}"))
 142
 143 (defgrammar graphql-operation (operation-type name variable-definitions fields simple-fields)
 144   (emit (graphql-name operation-type) " "
 145         (graphql-name name)
 146         (graphql-argument-alist variable-definitions)
 147         (graphql-combined-fields fields simple-fields)))
 148
 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)))
 153
 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)))
 157
 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)))
 163
 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)))
 170
 171 (defun graphql-mutation-string (mutation-type terms fields)
 172   (format nil "mutation ~A{~A}" mutation-type (graphql-query-string* mutation-type terms fields)))
 173
 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+))