;;; ghub-graphql.el --- access Github API using GrapthQL  -*- lexical-binding: t -*-

;; Copyright (C) 2016-2021  Jonas Bernoulli

;; Author: Jonas Bernoulli <jonas@bernoul.li>
;; Homepage: https://github.com/magit/ghub
;; Keywords: tools
;; SPDX-License-Identifier: GPL-3.0-or-later

;; 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 'ghub)
(require 'gsexp)
(require 'treepy)

(eval-when-compile
  (require 'subr-x))

;;; Api

(cl-defun ghub-graphql (graphql &optional variables
                                &key username auth host
                                headers 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)))))
                :headers headers :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-sparse
  '(query
    (repository
     [(owner $owner String!)
      (name  $name  String!)]
     name
     id
     createdAt
     updatedAt
     nameWithOwner
     (parent nameWithOwner)
     description
     homepageUrl
     (defaultBranchRef name)
     isArchived
     isFork
     isLocked
     isMirror
     isPrivate
     hasIssuesEnabled
     hasWikiEnabled
     (licenseInfo name)
     (stargazers totalCount)
     (watchers totalCount))))

(defconst ghub-fetch-repository
  `(query
    (repository
     ,@(cdr (cadr ghub-fetch-repository-sparse))
     (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)
     (milestones     [(:edges t)
                      (:singular milestone id)]
                     id
                     number
                     title
                     createdAt
                     updatedAt
                     dueOn
                     closedAt
                     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))
                     baseRefOid
                     (headRef name
                              (repository (owner login)
                                          nameWithOwner))
                     headRefOid
                     (assignees [(:edges t)]
                                id)
                     (reviewRequests [(:edges t)]
                                     (requestedReviewer "... on User { id }\n"))
                     (comments  [(:edges t)]
                                databaseId
                                (author login)
                                createdAt
                                updatedAt
                                body)
                     (labels    [(:edges t)]
                                id)))))

(defconst ghub-fetch-repository-review-threads
  '(query
    (repository
     [(owner $owner String!)
      (name  $name  String!)]
     (pullRequests   [(:edges t)
                      (:singular pullRequest number)
                      (orderBy ((field UPDATED_AT) (direction DESC)))]
                     number
                     baseRefOid
                     headRefOid
                     (reviewThreads [(:edges t)]
                                    id
                                    line
                                    originalLine
                                    diffSide
                                    (resolvedBy login)
                                    (comments [(:edges t)]
                                              id
                                              databaseId
                                              (author login)
                                              createdAt
                                              updatedAt
                                              body
                                              (replyTo databaseId)
                                              (originalCommit oid)
                                              path))))))

(cl-defun ghub-fetch-repository (owner name callback
                                       &optional until
                                       &key username auth host forge
                                       headers errorback sparse)
  "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 (if sparse
                            ghub-fetch-repository-sparse
                          ghub-fetch-repository)
                        `((owner . ,owner)
                          (name  . ,name))
                        callback until
                        :narrow   '(repository)
                        :username username
                        :auth     auth
                        :host     host
                        :forge    forge
                        :headers  headers
                        :errorback errorback))

(cl-defun ghub-fetch-issue (owner name number callback
                                  &optional until
                                  &key username auth host forge
                                  headers errorback)
  "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
                        :headers  headers
                        :errorback errorback))

(cl-defun ghub-fetch-pullreq (owner name number callback
                                    &optional until
                                    &key username auth host forge
                                    headers errorback)
  "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
                        :headers  headers
                        :errorback errorback))

(cl-defun ghub-fetch-review-threads (owner name number callback
                                           &optional until
                                           &key username auth host forge
                                           headers errorback)
  "Asynchronously fetch forge data about the review threads from a 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-review-threads
                         `(repository pullRequests (pullRequest . ,number)))
                        `((owner . ,owner)
                          (name  . ,name))
                        callback until
                        :narrow   '(repository pullRequest)
                        :username username
                        :auth     auth
                        :host     host
                        :forge    forge
                        :headers  headers
                        :errorback errorback))

;;; Internal

(cl-defstruct (ghub--graphql-req
               (:include ghub--req)
               (:constructor ghub--make-graphql-req)
               (:copier nil))
  (query     nil :read-only t)
  (query-str nil :read-only nil)
  (variables nil :read-only t)
  (until     nil :read-only t)
  (buffer    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
                                      headers errorback)
  "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
                (format "https://%s/graphql"
                        (if (string-suffix-p "/v3" host)
                            (substring host 0 -3)
                          host)))
    :method    "POST"
    :headers   (ghub--headers headers host auth username forge)
    :handler   'ghub--graphql-handle-response
    :query     query
    :variables variables
    :until     until
    :buffer    (current-buffer)
    :callback  (let ((buf (current-buffer)))
                 (if narrow
                     (lambda (data)
                       (let ((path narrow) key)
                         (while (setq key (pop path))
                           (setq data (cdr (assq key data)))))
                       (ghub--graphql-set-mode-line buf nil)
                       (funcall callback data))
                   (lambda (data)
                     (ghub--graphql-set-mode-line buf nil)
                     (funcall callback data))))
    :errorback errorback)))

(cl-defun ghub--graphql-retrieve (req &optional lineage cursor)
  (let ((p (cl-incf (ghub--graphql-req-pages req))))
    (when (> p 1)
      (ghub--graphql-set-mode-line req "Fetching page %s" p)))
  (setf (ghub--graphql-req-query-str req)
        (gsexp-encode
         (ghub--graphql-prepare-query
          (ghub--graphql-req-query req)
          lineage cursor)))
  (ghub--retrieve
   (let ((json-false nil))
     (ghub--encode-payload
      `((query     . ,(ghub--graphql-req-query-str req))
        (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 (cadr (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 (vconcat (nreverse vars)))))))
        (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))))
            (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 req (assq 'data payload)))))
      (when (buffer-live-p buffer)
        (kill-buffer buffer)))))

(defun ghub--graphql-walk-response (req data)
  (let* ((loc (ghub--req-value req))
         (loc (if (not 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"))))
                (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
                                (seq-take-while
                                 (lambda (node)
                                   (or (string> (cdr (assq 'updatedAt node))
                                                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))
                       ;; Alias
                       (cl-find-if (lambda (c)
                                     (eq (car-safe (car-safe c))
                                         (car lineage)))
                                   query)
                       ;; Edges
                       (cl-find-if (lambda (c)
                                     (and (listp c)
                                          (vectorp (cadr c))
                                          (eq (cadr (assq :singular
                                                          (cl-coerce (cadr c)
                                                                     'list)))
                                              (car lineage))))
                                   (cdr query))
                       (error "BUG: Failed to narrow 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--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)))

(defun ghub--graphql-set-mode-line (buf string &rest args)
  (when (ghub--graphql-req-p buf)
    (setq buf (ghub--graphql-req-buffer buf)))
  (when (buffer-live-p buf)
    (with-current-buffer buf
      (setq mode-line-process
            (and string (concat " " (apply #'format string args))))
      (force-mode-line-update t))))

;;; _
(provide 'ghub-graphql)
;;; ghub-graphql.el ends here