| 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 | |
