path: root/configs/shared/emacs/.emacs.d/elpa/ghub-20180911.1858/ghub-graphql.el

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