diff options
Diffstat (limited to 'emacs/.emacs.d/elpa/ghub-20180924.713/ghub-graphql.el')
| -rw-r--r-- | emacs/.emacs.d/elpa/ghub-20180924.713/ghub-graphql.el | 440 |
1 files changed, 440 insertions, 0 deletions
diff --git a/emacs/.emacs.d/elpa/ghub-20180924.713/ghub-graphql.el b/emacs/.emacs.d/elpa/ghub-20180924.713/ghub-graphql.el new file mode 100644 index 0000000..44a3181 --- /dev/null +++ b/emacs/.emacs.d/elpa/ghub-20180924.713/ghub-graphql.el @@ -0,0 +1,440 @@ +;;; ghub-graphql.el --- access Github API using GrapthQL -*- lexical-binding: t -*- + +;; Copyright (C) 2016-2018 Jonas Bernoulli + +;; Author: Jonas Bernoulli <jonas@bernoul.li> +;; Homepage: https://github.com/magit/ghub + +;; This file is not part of GNU Emacs. + +;; This file is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. + +;; This file 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 General Public License for more details. + +;; For a copy of the GPL see https://www.gnu.org/licenses/gpl.txt. + +;;; Code: + +(require 'dash) +(require 'ghub) +(require 'graphql) +(require 'subr-x) +(require 'treepy) + +;;; Api + +(cl-defun ghub-graphql (graphql &optional variables + &key username auth host + silent + callback errorback value extra) + "Make a GraphQL request using GRAPHQL and VARIABLES. +Return the response as a JSON-like alist. Even if the response +contains `errors', do not raise an error. GRAPHQL is a GraphQL +string. VARIABLES is a JSON-like alist. The other arguments +behave as for `ghub-request' (which see)." + (cl-assert (stringp graphql)) + (cl-assert (not (stringp variables))) + (ghub-request "POST" "/graphql" nil :payload + (json-encode `(("query" . ,graphql) + ,@(and variables `(("variables" ,@variables))))) + :silent silent + :username username :auth auth :host host + :callback callback :errorback errorback + :extra extra :value value)) + +(cl-defun ghub-graphql-rate-limit (&key username auth host) + "Return rate limit information." + (let-alist (ghub-graphql + "query { rateLimit { limit cost remaining resetAt }}" + nil :username username :auth auth :host host) + .data.rateLimit)) + +(cl-defun ghub--repository-id (owner name &key username auth host) + "Return the id of the repository specified by OWNER, NAME and HOST." + (let-alist (ghub-graphql + "query ($owner:String!, $name:String!) { + repository(owner:$owner, name:$name) { id } + }" + `((owner . ,owner) + (name . ,name)) + :username username :auth auth :host host) + .data.repository.id)) + +;;; Api (drafts) + +(defconst ghub-fetch-repository + '(query + (repository + [(owner $owner String!) + (name $name String!)] + name + id + createdAt + updatedAt + nameWithOwner + description + (defaultBranchRef name) + isArchived + isFork + isLocked + isMirror + isPrivate + hasIssuesEnabled + hasWikiEnabled + (licenseInfo name) + (stargazers totalCount) + (watchers totalCount) + (assignableUsers [(:edges t)] + id + login + name) + (issues [(:edges t) + (:singular issue number) + (orderBy ((field . UPDATED_AT) (direction . DESC)))] + number + state + (author login) + title + createdAt + updatedAt + closedAt + locked + (milestone id) + body + (assignees [(:edges t)] + id) + (comments [(:edges t)] + databaseId + (author login) + createdAt + updatedAt + body) + (labels [(:edges t)] + id)) + (labels [(:edges t) + (:singular label id)] + id + name + color + description) + (pullRequests [(:edges t) + (:singular pullRequest number) + (orderBy ((field . UPDATED_AT) (direction . DESC)))] + number + state + (author login) + title + createdAt + updatedAt + closedAt + mergedAt + locked + maintainerCanModify + isCrossRepository + (milestone id) + body + (baseRef name + (repository nameWithOwner)) + (headRef name + (repository (owner login) + nameWithOwner)) + (assignees [(:edges t)] + id) + (comments [(:edges t)] + databaseId + (author login) + createdAt + updatedAt + body) + (labels [(:edges t)] + id))))) + +(cl-defun ghub-fetch-repository (owner name callback + &optional until + &key username auth host forge) + "Asynchronously fetch forge data about the specified repository. +Once all data has been collected, CALLBACK is called with the +data as the only argument." + (ghub--graphql-vacuum ghub-fetch-repository + `((owner . ,owner) + (name . ,name)) + callback until + :narrow '(repository) + :username username + :auth auth + :host host + :forge forge)) + +(cl-defun ghub-fetch-issue (owner name number callback + &optional until + &key username auth host forge) + "Asynchronously fetch forge data about the specified issue. +Once all data has been collected, CALLBACK is called with the +data as the only argument." + (ghub--graphql-vacuum (ghub--graphql-prepare-query + ghub-fetch-repository + `(repository issues (issue . ,number))) + `((owner . ,owner) + (name . ,name)) + callback until + :narrow '(repository issue) + :username username + :auth auth + :host host + :forge forge)) + +(cl-defun ghub-fetch-pullreq (owner name number callback + &optional until + &key username auth host forge) + "Asynchronously fetch forge data about the specified pull-request. +Once all data has been collected, CALLBACK is called with the +data as the only argument." + (ghub--graphql-vacuum (ghub--graphql-prepare-query + ghub-fetch-repository + `(repository pullRequests (pullRequest . ,number))) + `((owner . ,owner) + (name . ,name)) + callback until + :narrow '(repository pullRequest) + :username username + :auth auth + :host host + :forge forge)) + +;;; Internal + +(cl-defstruct (ghub--graphql-req + (:include ghub--req) + (:constructor ghub--make-graphql-req) + (:copier nil)) + (query nil :read-only t) + (variables nil :read-only t) + (until nil :read-only t) + (pages 0 :read-only nil)) + +(cl-defun ghub--graphql-vacuum (query variables callback + &optional until + &key narrow username auth host forge) + "Make a GraphQL request using QUERY and VARIABLES. +See Info node `(ghub)GraphQL Support'." + (unless host + (setq host (ghub--host forge))) + (unless (or username (stringp auth) (eq auth 'none)) + (setq username (ghub--username host forge))) + (ghub--graphql-retrieve + (ghub--make-graphql-req + :url (url-generic-parse-url (concat "https://" host "/graphql")) + :method "POST" + :headers (ghub--headers nil host auth username forge) + :handler 'ghub--graphql-handle-response + :query query + :variables variables + :until until + :callback (if narrow + (lambda (data) + (let ((path narrow) key) + (while (setq key (pop path)) + (setq data (cdr (assq key data))))) + (funcall callback data)) + callback)))) + +(cl-defun ghub--graphql-retrieve (req &optional lineage cursor) + (let ((p (cl-incf (ghub--graphql-req-pages req)))) + (when (> p 1) + (message "Fetching page %s..." p))) + (ghub--retrieve + (let ((json-false nil)) + (ghub--encode-payload + `((query . ,(ghub--graphql-encode + (ghub--graphql-prepare-query + (ghub--graphql-req-query req) + lineage cursor))) + (variables . ,(ghub--graphql-req-variables req))))) + req)) + +(defun ghub--graphql-prepare-query (query &optional lineage cursor) + (when lineage + (setq query (ghub--graphql-narrow-query query lineage cursor))) + (let ((loc (ghub--alist-zip query)) + variables) + (cl-block nil + (while t + (let ((node (treepy-node loc))) + (when (vectorp node) + (let ((alist (cl-coerce node 'list)) + vars) + (when (assq :edges alist) + (push (list 'first 100) vars) + (setq loc (treepy-up loc)) + (setq node (treepy-node loc)) + (setq loc (treepy-replace + loc `(,(car node) + ,(cadr node) + (pageInfo endCursor hasNextPage) + (edges (node ,@(cddr node)))))) + (setq loc (treepy-down loc)) + (setq loc (treepy-next loc))) + (dolist (elt alist) + (cond ((keywordp (car elt))) + ((= (length elt) 3) + (push (list (nth 0 elt) + (nth 1 elt)) vars) + (push (list (nth 1 elt) + (nth 2 elt)) variables)) + ((= (length elt) 2) + (push elt vars)))) + (setq loc (treepy-replace loc (cl-coerce vars 'vector)))))) + (if (treepy-end-p loc) + (let ((node (copy-sequence (treepy-node loc)))) + (when variables + (push (cl-coerce variables 'vector) + (cdr node))) + (cl-return node)) + (setq loc (treepy-next loc))))))) + +(defun ghub--graphql-handle-response (status req) + (let ((buffer (current-buffer))) + (unwind-protect + (progn + (set-buffer-multibyte t) + (let* ((headers (ghub--handle-response-headers status req)) + (payload (ghub--handle-response-payload req)) + (payload (ghub--handle-response-error status payload req)) + (err (plist-get status :error)) + (errors (cdr (assq 'errors payload))) + (errors (and errors + (cons 'ghub-graphql-error errors))) + (data (assq 'data payload)) + (value (ghub--req-value req))) + (setf (ghub--req-value req) value) + (if (or err errors) + (if-let ((errorback (ghub--req-errorback req))) + (funcall errorback (or err errors) headers status req) + (ghub--signal-error (or err errors))) + (ghub--graphql-walk-response value data req)))) + (when (buffer-live-p buffer) + (kill-buffer buffer))))) + +(defun ghub--graphql-walk-response (loc data req) + (if (not loc) + (setf (ghub--req-value req) + (setq loc (ghub--alist-zip data))) + (setq data (ghub--graphql-narrow-data data (ghub--graphql-lineage loc))) + (setf (alist-get 'edges data) + (append (alist-get 'edges (treepy-node loc)) + (or (alist-get 'edges data) + (error "BUG: Expected new nodes")))) + (setq loc (treepy-replace loc data))) + (cl-block nil + (while t + (when (eq (car-safe (treepy-node loc)) 'edges) + (setq loc (treepy-up loc)) + (pcase-let ((`(,key . ,val) (treepy-node loc))) + (let-alist val + (let* ((cursor (and .pageInfo.hasNextPage + .pageInfo.endCursor)) + (until (cdr (assq (intern (format "%s-until" key)) + (ghub--graphql-req-until req)))) + (nodes (mapcar #'cdar .edges)) + (nodes (if until + (--take-while + (or (string> (cdr (assq 'updatedAt it)) until) + (setq cursor nil)) + nodes) + nodes))) + (if cursor + (progn + (setf (ghub--req-value req) loc) + (ghub--graphql-retrieve req + (ghub--graphql-lineage loc) + cursor) + (cl-return)) + (setq loc (treepy-replace loc (cons key nodes)))))))) + (if (not (treepy-end-p loc)) + (setq loc (treepy-next loc)) + (funcall (ghub--req-callback req) + (treepy-root loc)) + (cl-return))))) + +(defun ghub--graphql-lineage (loc) + (let (lineage) + (while (treepy-up loc) + (push (car (treepy-node loc)) lineage) + (setq loc (treepy-up loc))) + lineage)) + +(defun ghub--graphql-narrow-data (data lineage) + (let (key) + (while (setq key (pop lineage)) + (if (consp (car lineage)) + (progn (pop lineage) + (setf data (cadr data))) + (setq data (assq key (cdr data)))))) + data) + +(defun ghub--graphql-narrow-query (query lineage cursor) + (if (consp (car lineage)) + (let* ((child (cddr query)) + (alist (cl-coerce (cadr query) 'list)) + (single (cdr (assq :singular alist)))) + `(,(car single) + ,(vector (list (cadr single) (cdr (car lineage)))) + ,@(if (cdr lineage) + (ghub--graphql-narrow-query child (cdr lineage) cursor) + child))) + (let* ((child (or (assq (car lineage) (cdr query)) + (cl-find-if (lambda (c) + (and (listp c) + (vectorp (cadr c)) + (eq (cadr (assq :singular + (cl-coerce (cadr c) + 'list))) + (car lineage)))) + (cdr query)))) + (object (car query)) + (args (and (vectorp (cadr query)) + (cadr query)))) + `(,object + ,@(and args (list args)) + ,(cond ((cdr lineage) + (ghub--graphql-narrow-query child (cdr lineage) cursor)) + (cursor + `(,(car child) + ,(vconcat `((after ,cursor)) + (cadr child)) + ,@(cddr child))) + (t + child)))))) + +(defun ghub--graphql-encode (g) + (if (symbolp g) + (symbol-name g) + (let* ((object (car g)) + (args (and (vectorp (cadr g)) + (cl-coerce (cadr g) 'list))) + (fields (if args (cddr g) (cdr g)))) + (concat + (graphql--encode-object object) + (and args + (format " (\n%s)" + (mapconcat (pcase-lambda (`(,key ,val)) + (graphql--encode-argument key val)) + args ",\n"))) + (and fields + (format " {\n%s\n}" + (mapconcat #'ghub--graphql-encode fields "\n"))))))) + +(defun ghub--alist-zip (root) + (let ((branchp (lambda (elt) (and (listp elt) (listp (cdr elt))))) + (make-node (lambda (_ children) children))) + (treepy-zipper branchp #'identity make-node root))) + +;;; _ +(provide 'ghub-graphql) +;;; ghub-graphql.el ends here |