diff options
Diffstat (limited to 'configs/shared/emacs/.emacs.d/elpa/ghub-20180911.1858/ghub-graphql.el')
| -rw-r--r-- | configs/shared/emacs/.emacs.d/elpa/ghub-20180911.1858/ghub-graphql.el | 428 |
1 files changed, 0 insertions, 428 deletions
diff --git a/configs/shared/emacs/.emacs.d/elpa/ghub-20180911.1858/ghub-graphql.el b/configs/shared/emacs/.emacs.d/elpa/ghub-20180911.1858/ghub-graphql.el deleted file mode 100644 index b73329f410e5..000000000000 --- a/configs/shared/emacs/.emacs.d/elpa/ghub-20180911.1858/ghub-graphql.el +++ /dev/null @@ -1,428 +0,0 @@ -;;; 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) - (issues [(:edges t) - (:singular issue number) - (orderBy ((field . UPDATED_AT) (direction . DESC)))] - number - state - (author login) - title - createdAt - updatedAt - closedAt - locked - (milestone id) - body - (comments [(:edges t)] - databaseId - (author login) - createdAt - updatedAt - body)) - (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)) - (comments [(:edges t)] - databaseId - (author login) - createdAt - updatedAt - body))))) - -(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 |