mirror of https://github.com/Chizi123/.emacs.d.git

Chizi123
2018-11-21 5ddac8bd2392ec5b64392e8750d725029bf5aa79
commit | author | age
5cb5f7 1 ;;; ghub-graphql.el --- access Github API using GrapthQL  -*- lexical-binding: t -*-
C 2
3 ;; Copyright (C) 2016-2018  Jonas Bernoulli
4
5 ;; Author: Jonas Bernoulli <jonas@bernoul.li>
6 ;; Homepage: https://github.com/magit/ghub
7
8 ;; This file is not part of GNU Emacs.
9
10 ;; This file is free software; you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation; either version 3, or (at your option)
13 ;; any later version.
14
15 ;; This file is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
18 ;; GNU General Public License for more details.
19
20 ;; For a copy of the GPL see https://www.gnu.org/licenses/gpl.txt.
21
22 ;;; Code:
23
24 (require 'dash)
25 (require 'ghub)
26 (require 'graphql)
27 (require 'treepy)
28
29 (eval-when-compile
30   (require 'subr-x))
31
32 ;;; Api
33
34 (cl-defun ghub-graphql (graphql &optional variables
35                                 &key username auth host
36                                 silent
37                                 callback errorback value extra)
38   "Make a GraphQL request using GRAPHQL and VARIABLES.
39 Return the response as a JSON-like alist.  Even if the response
40 contains `errors', do not raise an error.  GRAPHQL is a GraphQL
41 string.  VARIABLES is a JSON-like alist.  The other arguments
42 behave as for `ghub-request' (which see)."
43   (cl-assert (stringp graphql))
44   (cl-assert (not (stringp variables)))
45   (ghub-request "POST" "/graphql" nil :payload
46                 (json-encode `(("query" . ,graphql)
47                                ,@(and variables `(("variables" ,@variables)))))
48                 :silent silent
49                 :username username :auth auth :host host
50                 :callback callback :errorback errorback
51                 :extra extra :value value))
52
53 (cl-defun ghub-graphql-rate-limit (&key username auth host)
54   "Return rate limit information."
55   (let-alist (ghub-graphql
56               "query { rateLimit { limit cost remaining resetAt }}"
57               nil :username username :auth auth :host host)
58     .data.rateLimit))
59
60 (cl-defun ghub--repository-id (owner name &key username auth host)
61   "Return the id of the repository specified by OWNER, NAME and HOST."
62   (let-alist (ghub-graphql
63               "query ($owner:String!, $name:String!) {
64                  repository(owner:$owner, name:$name) { id }
65                }"
66               `((owner . ,owner)
67                 (name  . ,name))
68               :username username :auth auth :host host)
69     .data.repository.id))
70
71 ;;; Api (drafts)
72
73 (defconst ghub-fetch-repository
74   '(query
75     (repository
76      [(owner $owner String!)
77       (name  $name  String!)]
78      name
79      id
80      createdAt
81      updatedAt
82      nameWithOwner
83      description
84      (defaultBranchRef name)
85      isArchived
86      isFork
87      isLocked
88      isMirror
89      isPrivate
90      hasIssuesEnabled
91      hasWikiEnabled
92      (licenseInfo name)
93      (stargazers totalCount)
94      (watchers totalCount)
95      (assignableUsers [(:edges t)]
96                       id
97                       login
98                       name)
99      (issues         [(:edges t)
100                       (:singular issue number)
101                       (orderBy ((field . UPDATED_AT) (direction . DESC)))]
102                      number
103                      state
104                      (author login)
105                      title
106                      createdAt
107                      updatedAt
108                      closedAt
109                      locked
110                      (milestone id)
111                      body
112                      (assignees [(:edges t)]
113                                 id)
114                      (comments  [(:edges t)]
115                                 databaseId
116                                 (author login)
117                             createdAt
118                             updatedAt
119                                 body)
120                      (labels    [(:edges t)]
121                                 id))
122      (labels         [(:edges t)
123                       (:singular label id)]
124                      id
125                      name
126                      color
127                      description)
128      (pullRequests   [(:edges t)
129                       (:singular pullRequest number)
130                       (orderBy ((field . UPDATED_AT) (direction . DESC)))]
131                      number
132                      state
133                      (author login)
134                      title
135                      createdAt
136                      updatedAt
137                      closedAt
138                      mergedAt
139                      locked
140                      maintainerCanModify
141                      isCrossRepository
142                      (milestone id)
143                      body
144                      (baseRef name
145                               (repository nameWithOwner))
146                      (headRef name
147                               (repository (owner login)
148                                           nameWithOwner))
149                      (assignees [(:edges t)]
150                                 id)
151                      (comments  [(:edges t)]
152                                 databaseId
153                                 (author login)
154                                 createdAt
155                             updatedAt
156                             body)
157                      (labels    [(:edges t)]
158                                 id)))))
159
160 (cl-defun ghub-fetch-repository (owner name callback
161                                        &optional until
162                                        &key username auth host forge)
163   "Asynchronously fetch forge data about the specified repository.
164 Once all data has been collected, CALLBACK is called with the
165 data as the only argument."
166   (ghub--graphql-vacuum ghub-fetch-repository
167                         `((owner . ,owner)
168                           (name  . ,name))
169                         callback until
170                         :narrow   '(repository)
171                         :username username
172                         :auth     auth
173                         :host     host
174                         :forge    forge))
175
176 (cl-defun ghub-fetch-issue (owner name number callback
177                                   &optional until
178                                   &key username auth host forge)
179   "Asynchronously fetch forge data about the specified issue.
180 Once all data has been collected, CALLBACK is called with the
181 data as the only argument."
182   (ghub--graphql-vacuum (ghub--graphql-prepare-query
183                          ghub-fetch-repository
184                          `(repository issues (issue . ,number)))
185                         `((owner . ,owner)
186                           (name  . ,name))
187                         callback until
188                         :narrow   '(repository issue)
189                         :username username
190                         :auth     auth
191                         :host     host
192                         :forge    forge))
193
194 (cl-defun ghub-fetch-pullreq (owner name number callback
195                                     &optional until
196                                     &key username auth host forge)
197   "Asynchronously fetch forge data about the specified pull-request.
198 Once all data has been collected, CALLBACK is called with the
199 data as the only argument."
200   (ghub--graphql-vacuum (ghub--graphql-prepare-query
201                          ghub-fetch-repository
202                          `(repository pullRequests (pullRequest . ,number)))
203                         `((owner . ,owner)
204                           (name  . ,name))
205                         callback until
206                         :narrow   '(repository pullRequest)
207                         :username username
208                         :auth     auth
209                         :host     host
210                         :forge    forge))
211
212 ;;; Internal
213
214 (cl-defstruct (ghub--graphql-req
215                (:include ghub--req)
216                (:constructor ghub--make-graphql-req)
217                (:copier nil))
218   (query     nil :read-only t)
219   (variables nil :read-only t)
220   (until     nil :read-only t)
221   (pages     0   :read-only nil))
222
223 (cl-defun ghub--graphql-vacuum (query variables callback
224                                       &optional until
225                                       &key narrow username auth host forge)
226   "Make a GraphQL request using QUERY and VARIABLES.
227 See Info node `(ghub)GraphQL Support'."
228   (unless host
229     (setq host (ghub--host forge)))
230   (unless (or username (stringp auth) (eq auth 'none))
231     (setq username (ghub--username host forge)))
232   (ghub--graphql-retrieve
233    (ghub--make-graphql-req
234     :url       (url-generic-parse-url (concat "https://" host "/graphql"))
235     :method    "POST"
236     :headers   (ghub--headers nil host auth username forge)
237     :handler   'ghub--graphql-handle-response
238     :query     query
239     :variables variables
240     :until     until
241     :callback  (if narrow
242                    (lambda (data)
243                      (let ((path narrow) key)
244                        (while (setq key (pop path))
245                          (setq data (cdr (assq key data)))))
246                      (funcall callback data))
247                  callback))))
248
249 (cl-defun ghub--graphql-retrieve (req &optional lineage cursor)
250   (let ((p (cl-incf (ghub--graphql-req-pages req))))
251     (when (> p 1)
252       (message "Fetching page %s..." p)))
253   (ghub--retrieve
254    (let ((json-false nil))
255      (ghub--encode-payload
256       `((query     . ,(ghub--graphql-encode
257                        (ghub--graphql-prepare-query
258                         (ghub--graphql-req-query req)
259                         lineage cursor)))
260         (variables . ,(ghub--graphql-req-variables req)))))
261    req))
262
263 (defun ghub--graphql-prepare-query (query &optional lineage cursor)
264   (when lineage
265     (setq query (ghub--graphql-narrow-query query lineage cursor)))
266   (let ((loc (ghub--alist-zip query))
267         variables)
268     (cl-block nil
269       (while t
270         (let ((node (treepy-node loc)))
271           (when (vectorp node)
272             (let ((alist (cl-coerce node 'list))
273                   vars)
274               (when (assq :edges alist)
275                 (push (list 'first 100) vars)
276                 (setq loc  (treepy-up loc))
277                 (setq node (treepy-node loc))
278                 (setq loc  (treepy-replace
279                             loc `(,(car  node)
280                                   ,(cadr node)
281                                   (pageInfo endCursor hasNextPage)
282                                   (edges (node ,@(cddr node))))))
283                 (setq loc  (treepy-down loc))
284                 (setq loc  (treepy-next loc)))
285               (dolist (elt alist)
286                 (cond ((keywordp (car elt)))
287                       ((= (length elt) 3)
288                        (push (list (nth 0 elt)
289                                    (nth 1 elt)) vars)
290                        (push (list (nth 1 elt)
291                                    (nth 2 elt)) variables))
292                       ((= (length elt) 2)
293                        (push elt vars))))
294               (setq loc (treepy-replace loc (cl-coerce vars 'vector))))))
295         (if (treepy-end-p loc)
296             (let ((node (copy-sequence (treepy-node loc))))
297               (when variables
298                 (push (cl-coerce variables 'vector)
299                       (cdr node)))
300               (cl-return node))
301           (setq loc (treepy-next loc)))))))
302
303 (defun ghub--graphql-handle-response (status req)
304   (let ((buffer (current-buffer)))
305     (unwind-protect
306         (progn
307           (set-buffer-multibyte t)
308           (let* ((headers (ghub--handle-response-headers status req))
309                  (payload (ghub--handle-response-payload req))
310                  (payload (ghub--handle-response-error status payload req))
311                  (err     (plist-get status :error))
312                  (errors  (cdr (assq 'errors payload)))
313                  (errors  (and errors
314                                (cons 'ghub-graphql-error errors)))
315                  (data    (assq 'data payload))
316                  (value   (ghub--req-value req)))
317             (setf (ghub--req-value req) value)
318             (if (or err errors)
319                 (if-let ((errorback (ghub--req-errorback req)))
320                     (funcall errorback (or err errors) headers status req)
321                   (ghub--signal-error (or err errors)))
322               (ghub--graphql-walk-response value data req))))
323       (when (buffer-live-p buffer)
324         (kill-buffer buffer)))))
325
326 (defun ghub--graphql-walk-response (loc data req)
327   (if (not loc)
328       (setf (ghub--req-value req)
329             (setq loc (ghub--alist-zip data)))
330     (setq data (ghub--graphql-narrow-data data (ghub--graphql-lineage loc)))
331     (setf (alist-get 'edges data)
332           (append (alist-get 'edges (treepy-node loc))
333                   (or (alist-get 'edges data)
334                       (error "BUG: Expected new nodes"))))
335     (setq loc (treepy-replace loc data)))
336   (cl-block nil
337     (while t
338       (when (eq (car-safe (treepy-node loc)) 'edges)
339         (setq loc (treepy-up loc))
340         (pcase-let ((`(,key . ,val) (treepy-node loc)))
341           (let-alist val
342             (let* ((cursor (and .pageInfo.hasNextPage
343                                 .pageInfo.endCursor))
344                    (until (cdr (assq (intern (format "%s-until" key))
345                                      (ghub--graphql-req-until req))))
346                    (nodes (mapcar #'cdar .edges))
347                    (nodes (if until
348                               (--take-while
349                                (or (string> (cdr (assq 'updatedAt it)) until)
350                                    (setq cursor nil))
351                                nodes)
352                             nodes)))
353               (if cursor
354                   (progn
355                     (setf (ghub--req-value req) loc)
356                     (ghub--graphql-retrieve req
357                                             (ghub--graphql-lineage loc)
358                                             cursor)
359                     (cl-return))
360                 (setq loc (treepy-replace loc (cons key nodes))))))))
361       (if (not (treepy-end-p loc))
362           (setq loc (treepy-next loc))
363         (funcall (ghub--req-callback req)
364                  (treepy-root loc))
365         (cl-return)))))
366
367 (defun ghub--graphql-lineage (loc)
368   (let (lineage)
369     (while (treepy-up loc)
370       (push (car (treepy-node loc)) lineage)
371       (setq loc (treepy-up loc)))
372     lineage))
373
374 (defun ghub--graphql-narrow-data (data lineage)
375   (let (key)
376     (while (setq key (pop lineage))
377       (if (consp (car lineage))
378           (progn (pop lineage)
379                  (setf data (cadr data)))
380         (setq data (assq key (cdr data))))))
381   data)
382
383 (defun ghub--graphql-narrow-query (query lineage cursor)
384   (if (consp (car lineage))
385       (let* ((child  (cddr query))
386              (alist  (cl-coerce (cadr query) 'list))
387              (single (cdr (assq :singular alist))))
388         `(,(car single)
389           ,(vector (list (cadr single) (cdr (car lineage))))
390           ,@(if (cdr lineage)
391                (ghub--graphql-narrow-query child (cdr lineage) cursor)
392              child)))
393     (let* ((child  (or (assq (car lineage) (cdr query))
394                        (cl-find-if (lambda (c)
395                                      (and (listp c)
396                                           (vectorp (cadr c))
397                                           (eq (cadr (assq :singular
398                                                           (cl-coerce (cadr c)
399                                                                      'list)))
400                                               (car lineage))))
401                                    (cdr query))))
402            (object (car query))
403            (args   (and (vectorp (cadr query))
404                         (cadr query))))
405       `(,object
406         ,@(and args (list args))
407         ,(cond ((cdr lineage)
408                 (ghub--graphql-narrow-query child (cdr lineage) cursor))
409                (cursor
410                 `(,(car child)
411                   ,(vconcat `((after ,cursor))
412                             (cadr child))
413                   ,@(cddr child)))
414                (t
415                 child))))))
416
417 (defun ghub--graphql-encode (g)
418   (if (symbolp g)
419       (symbol-name g)
420     (let* ((object (car g))
421            (args   (and (vectorp (cadr g))
422                         (cl-coerce (cadr g) 'list)))
423            (fields (if args (cddr g) (cdr g))))
424        (concat
425         (graphql--encode-object object)
426         (and args
427              (format " (\n%s)"
428                      (mapconcat (pcase-lambda (`(,key ,val))
429                                   (graphql--encode-argument key val))
430                                 args ",\n")))
431         (and fields
432              (format " {\n%s\n}"
433                      (mapconcat #'ghub--graphql-encode fields "\n")))))))
434
435 (defun ghub--alist-zip (root)
436   (let ((branchp (lambda (elt) (and (listp elt) (listp (cdr elt)))))
437         (make-node (lambda (_ children) children)))
438     (treepy-zipper branchp #'identity make-node root)))
439
440 ;;; _
441 (provide 'ghub-graphql)
442 ;;; ghub-graphql.el ends here