diff options
Diffstat (limited to 'configs/shared/emacs/.emacs.d/elpa/ghub-20180911.1858/ghub.el')
| -rw-r--r-- | configs/shared/emacs/.emacs.d/elpa/ghub-20180911.1858/ghub.el | 912 |
1 files changed, 912 insertions, 0 deletions
diff --git a/configs/shared/emacs/.emacs.d/elpa/ghub-20180911.1858/ghub.el b/configs/shared/emacs/.emacs.d/elpa/ghub-20180911.1858/ghub.el new file mode 100644 index 000000000000..6d9ce8275576 --- /dev/null +++ b/configs/shared/emacs/.emacs.d/elpa/ghub-20180911.1858/ghub.el @@ -0,0 +1,912 @@ +;;; ghub.el --- minuscule client libraries for Git forge APIs -*- lexical-binding: t -*- + +;; Copyright (C) 2016-2018 Jonas Bernoulli + +;; Author: Jonas Bernoulli <jonas@bernoul.li> +;; Homepage: https://github.com/magit/ghub +;; Keywords: tools + +;; 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. + +;;; Commentary: + +;; Ghub provides basic support for using the APIs of various Git forges +;; from Emacs packages. Originally it only supported the Github REST +;; API, but now it also supports the Github GraphQL API as well as the +;; REST APIs of Gitlab, Gitea, Gogs and Bitbucket. + +;; Ghub abstracts access to API resources using only a handful of basic +;; functions such as `ghub-get'. These are convenience wrappers around +;; `ghub-request'. Additional forge-specific wrappers like `glab-put', +;; `gtea-put', `gogs-post' and `buck-delete' are also available. Ghub +;; does not provide any resource-specific functions, with the exception +;; of `FORGE-repository-id'. + +;; When accessing Github, then Ghub handles the creation and storage of +;; access tokens using a setup wizard to make it easier for users to get +;; started. The tokens for other forges have to be created manually. + +;; Ghub is intentionally limited to only provide these two essential +;; features — basic request functions and guided setup — to avoid being +;; too opinionated, which would hinder wide adoption. It is assumed that +;; wide adoption would make life easier for users and maintainers alike, +;; because then all packages that talk to forge APIs could be configured +;; the same way. + +;; Please consult the manual (info "ghub") for more information. + +;;; Code: + +(require 'auth-source) +(require 'cl-lib) +(require 'json) +(require 'let-alist) +(require 'url) +(require 'url-auth) +(require 'url-http) + +(eval-when-compile (require 'subr-x)) + +(defvar url-callback-arguments) +(defvar url-http-end-of-headers) +(defvar url-http-extra-headers) +(defvar url-http-response-status) + +;;; Settings + +(defconst ghub-default-host "api.github.com" + "The default host that is used if `ghub.host' is not set.") + +(defvar ghub-github-token-scopes '(repo) + "The Github API scopes that your private tools need. + +The token that is created based on the value of this variable +is used when `ghub-request' (or one of its wrappers) is called +without providing a value for AUTH. Packages should always +identify themselves using that argument, but when you use Ghub +directly in private tools, then that is not necessary and the +request is made on behalf of the `ghub' package itself, aka on +behalf of some private tool. + +By default the only requested scope is `repo' because that is +sufficient as well as required for most common uses. This and +other scopes are documented at URL `https://magit.vc/goto/2e586d36'. + +If your private tools need other scopes, then you have to add +them here *before* creating the token. Alternatively you can +edit the scopes of an existing token using the web interface +at URL `https://github.com/settings/tokens'.") + +(defvar ghub-override-system-name nil + "If non-nil, the string used to identify the local machine. +If this is nil, then the value returned by `system-name' is +used instead.") + +;;; Request +;;;; Object + +(cl-defstruct (ghub--req + (:constructor ghub--make-req) + (:copier nil)) + (url nil :read-only nil) + (forge nil :read-only t) + (silent nil :read-only t) + (method nil :read-only t) + (headers nil :read-only t) + (handler nil :read-only t) + (unpaginate nil :read-only nil) + (noerror nil :read-only t) + (reader nil :read-only t) + (callback nil :read-only t) + (errorback nil :read-only t) + (value nil :read-only nil) + (extra nil :read-only nil)) + +(defalias 'ghub-req-extra 'ghub--req-extra) + +;;;; API + +(define-error 'ghub-error "Ghub/Url Error" 'error) +(define-error 'ghub-http-error "HTTP Error" 'ghub-error) + +(defvar ghub-response-headers nil + "The headers returned in response to the last request. +`ghub-request' returns the response body and stores the +response headers in this variable.") + +(cl-defun ghub-head (resource &optional params + &key query payload headers + silent unpaginate noerror reader + username auth host + callback errorback extra) + "Make a `HEAD' request for RESOURCE, with optional query PARAMS. +Like calling `ghub-request' (which see) with \"HEAD\" as METHOD." + (ghub-request "HEAD" resource params + :query query :payload payload :headers headers + :silent silent :unpaginate unpaginate + :noerror noerror :reader reader + :username username :auth auth :host host + :callback callback :errorback errorback :extra extra)) + +(cl-defun ghub-get (resource &optional params + &key query payload headers + silent unpaginate noerror reader + username auth host + callback errorback extra) + "Make a `GET' request for RESOURCE, with optional query PARAMS. +Like calling `ghub-request' (which see) with \"GET\" as METHOD." + (ghub-request "GET" resource params + :query query :payload payload :headers headers + :silent silent :unpaginate unpaginate + :noerror noerror :reader reader + :username username :auth auth :host host + :callback callback :errorback errorback :extra extra)) + +(cl-defun ghub-put (resource &optional params + &key query payload headers + silent unpaginate noerror reader + username auth host + callback errorback extra) + "Make a `PUT' request for RESOURCE, with optional payload PARAMS. +Like calling `ghub-request' (which see) with \"PUT\" as METHOD." + (ghub-request "PUT" resource params + :query query :payload payload :headers headers + :silent silent :unpaginate unpaginate + :noerror noerror :reader reader + :username username :auth auth :host host + :callback callback :errorback errorback :extra extra)) + +(cl-defun ghub-post (resource &optional params + &key query payload headers + silent unpaginate noerror reader + username auth host + callback errorback extra) + "Make a `POST' request for RESOURCE, with optional payload PARAMS. +Like calling `ghub-request' (which see) with \"POST\" as METHOD." + (ghub-request "POST" resource params + :query query :payload payload :headers headers + :silent silent :unpaginate unpaginate + :noerror noerror :reader reader + :username username :auth auth :host host + :callback callback :errorback errorback :extra extra)) + +(cl-defun ghub-patch (resource &optional params + &key query payload headers + silent unpaginate noerror reader + username auth host + callback errorback extra) + "Make a `PATCH' request for RESOURCE, with optional payload PARAMS. +Like calling `ghub-request' (which see) with \"PATCH\" as METHOD." + (ghub-request "PATCH" resource params + :query query :payload payload :headers headers + :silent silent :unpaginate unpaginate + :noerror noerror :reader reader + :username username :auth auth :host host + :callback callback :errorback errorback :extra extra)) + +(cl-defun ghub-delete (resource &optional params + &key query payload headers + silent unpaginate noerror reader + username auth host + callback errorback extra) + "Make a `DELETE' request for RESOURCE, with optional payload PARAMS. +Like calling `ghub-request' (which see) with \"DELETE\" as METHOD." + (ghub-request "DELETE" resource params + :query query :payload payload :headers headers + :silent silent :unpaginate unpaginate + :noerror noerror :reader reader + :username username :auth auth :host host + :callback callback :errorback errorback :extra extra)) + +(cl-defun ghub-request (method resource &optional params + &key query payload headers + silent unpaginate noerror reader + username auth host forge + callback errorback value extra) + "Make a request for RESOURCE and return the response body. + +Also place the response header in `ghub-response-headers'. + +METHOD is the HTTP method, given as a string. +RESOURCE is the resource to access, given as a string beginning + with a slash. + +PARAMS, QUERY, PAYLOAD and HEADERS are alists used to specify + data. The Github API documentation is vague on how data has + to be transmitted and for a particular resource usually just + talks about \"parameters\". Generally speaking when the METHOD + is \"HEAD\" or \"GET\", then they have to be transmitted as a + query, otherwise as a payload. +Use PARAMS to automatically transmit like QUERY or PAYLOAD would + depending on METHOD. +Use QUERY to explicitly transmit data as a query. +Use PAYLOAD to explicitly transmit data as a payload. + Instead of an alist, PAYLOAD may also be a string, in which + case it gets encoded as UTF-8 but is otherwise transmitted as-is. +Use HEADERS for those rare resources that require that the data + is transmitted as headers instead of as a query or payload. + When that is the case, then the API documentation usually + mentions it explicitly. + +If SILENT is non-nil, then don't message progress reports and + the like. + +If UNPAGINATE is t, then make as many requests as necessary to + get all values. If UNPAGINATE is a natural number, then get + at most that many pages. For any other non-nil value raise + an error. +If NOERROR is non-nil, then do not raise an error if the request + fails and return nil instead. If NOERROR is `return', then + return the error payload instead of nil. +If READER is non-nil, then it is used to read and return from the + response buffer. The default is `ghub--read-json-payload'. + For the very few resources that do not return JSON, you might + want to use `ghub--decode-payload'. + +If USERNAME is non-nil, then make a request on behalf of that + user. It is better to specify the user using the Git variable + `github.user' for \"api.github.com\", or `github.HOST.user' if + connecting to a Github Enterprise instance. + +Each package that uses `ghub' should use its own token. If AUTH + is nil, then the generic `ghub' token is used instead. This + is only acceptable for personal utilities. A packages that + is distributed to other users should always use this argument + to identify itself, using a symbol matching its name. + + Package authors who find this inconvenient should write a + wrapper around this function and possibly for the + method-specific functions as well. + + Some symbols have a special meaning. `none' means to make an + unauthorized request. `basic' means to make a password based + request. If the value is a string, then it is assumed to be + a valid token. `basic' and an explicit token string are only + intended for internal and debugging uses. + + If AUTH is a package symbol, then the scopes are specified + using the variable `AUTH-github-token-scopes'. It is an error + if that is not specified. See `ghub-github-token-scopes' for + an example. + +If HOST is non-nil, then connect to that Github instance. This + defaults to \"api.github.com\". When a repository is connected + to a Github Enterprise instance, then it is better to specify + that using the Git variable `github.host' instead of using this + argument. + +If FORGE is `gitlab', then connect to Gitlab.com or, depending + on HOST, to another Gitlab instance. This is only intended for + internal use. Instead of using this argument you should use + function `glab-request' and other `glab-*' functions. + +If CALLBACK and/or ERRORBACK is non-nil, then make one or more + asynchronous requests and call CALLBACK or ERRORBACK when + finished. If an error occurred, then call ERRORBACK, or if + that is nil, then CALLBACK. When no error occurred then call + CALLBACK. When making asynchronous requests, then no errors + are signaled, regardless of the value of NOERROR. + +Both callbacks are called with four arguments. + 1. For CALLBACK, the combined value of the retrieved pages. + For ERRORBACK, the error that occured when retrieving the + last page. + 2. The headers of the last page as an alist. + 3. Status information provided by `url-retrieve'. Its `:error' + property holds the same information as ERRORBACK's first + argument. + 4. A `ghub--req' struct, which can be passed to `ghub-continue' + (which see) to retrieve the next page, if any." + (cl-assert (or (booleanp unpaginate) (natnump unpaginate))) + (unless (string-prefix-p "/" resource) + (setq resource (concat "/" resource))) + (unless host + (setq host (ghub--host forge))) + (unless (or username (stringp auth) (eq auth 'none)) + (setq username (ghub--username host forge))) + (cond ((not params)) + ((member method '("GET" "HEAD")) + (when query + (error "PARAMS and QUERY are mutually exclusive for METHOD %S" + method)) + (setq query params)) + (t + (when payload + (error "PARAMS and PAYLOAD are mutually exclusive for METHOD %S" + method)) + (setq payload params))) + (when (or callback errorback) + (setq noerror t)) + (ghub--retrieve + (ghub--encode-payload payload) + (ghub--make-req + :url (url-generic-parse-url + (concat "https://" host resource + (and query (concat "?" (ghub--url-encode-params query))))) + :forge forge + :silent silent + ;; Encode in case caller used (symbol-name 'GET). #35 + :method (encode-coding-string method 'utf-8) + :headers (ghub--headers headers host auth username forge) + :handler 'ghub--handle-response + :unpaginate unpaginate + :noerror noerror + :reader reader + :callback callback + :errorback errorback + :value value + :extra extra))) + +(defun ghub-continue (req) + "If there is a next page, then retrieve that. + +This function is only intended to be called from callbacks. If +there is a next page, then retrieve that and return the buffer +that the result will be loaded into, or t if the process has +already completed. If there is no next page, then return nil. + +Callbacks are called with four arguments (see `ghub-request'). +The forth argument is a `ghub--req' struct, intended to be passed +to this function. A callback may use the struct's `extra' slot +to pass additional information to the callback that will be +called after the next request has finished. Use the function +`ghub-req-extra' to get and set the value of this slot." + (and (assq 'next (ghub-response-link-relations req)) + (or (ghub--retrieve nil req) t))) + +(cl-defun ghub-wait (resource &optional duration &key username auth host) + "Busy-wait up to DURATION seconds for RESOURCE to become available. + +DURATION specifies how many seconds to wait at most. It defaults +to 64 seconds. The first attempt is made immediately, the second +after two seconds, and each subsequent attempt is made after +waiting as long again as we already waited between all preceding +attempts combined. + +See `ghub-request' for information about the other arguments." + (unless duration + (setq duration 64)) + (with-local-quit + (let ((total 0)) + (while (not (ghub-get resource nil + :noerror t + :username username + :auth auth + :host host)) + (message "Waited (%3ss of %ss) for %s..." total duration resource) + (if (= total duration) + (error "Github is taking too long to create %s" resource) + (if (> total 0) + (let ((wait (min total (- duration total)))) + (sit-for wait) + (cl-incf total wait)) + (sit-for (setq total 2)))))))) + +(defun ghub-response-link-relations (req &optional headers payload) + "Return an alist of link relations in HEADERS. +If optional HEADERS is nil, then return those that were +previously stored in the variable `ghub-response-headers'. + +When accessing a Bitbucket instance then the link relations +are in PAYLOAD instead of HEADERS, making their API merely +RESTish and forcing this function to append those relations +to the value of `ghub-response-headers', for later use when +this function is called with nil for PAYLOAD." + (if (eq (ghub--req-forge req) 'bitbucket) + (if payload + (let* ((page (cl-mapcan (lambda (key) + (when-let ((elt (assq key payload))) + (list elt))) + '(size page pagelen next previous))) + (headers (cons (cons 'link-alist page) headers))) + (if (and req (or (ghub--req-callback req) + (ghub--req-errorback req))) + (setq-local ghub-response-headers headers) + (setq-default ghub-response-headers headers)) + page) + (cdr (assq 'link-alist ghub-response-headers))) + (when-let ((rels (cdr (assoc "Link" (or headers ghub-response-headers))))) + (mapcar (lambda (elt) + (pcase-let ((`(,url ,rel) (split-string elt "; "))) + (cons (intern (substring rel 5 -1)) + (substring url 1 -1)))) + (split-string rels ", "))))) + +;;;; Internal + +(cl-defun ghub--retrieve (payload req) + (let ((url-request-extra-headers + (let ((headers (ghub--req-headers req))) + (if (functionp headers) (funcall headers) headers))) + (url-request-method (ghub--req-method req)) + (url-request-data payload) + (url-show-status nil) + (url (ghub--req-url req)) + (handler (ghub--req-handler req)) + (silent (ghub--req-silent req))) + (if (or (ghub--req-callback req) + (ghub--req-errorback req)) + (url-retrieve url handler (list req) silent) + ;; When this function has already been called, then it is a + ;; no-op. Otherwise it sets `url-registered-auth-schemes' among + ;; other things. If we didn't ensure that it has been run, then + ;; `url-retrieve-synchronously' would do it, which would cause + ;; the value that we let-bind below to be overwritten, and the + ;; "default" value to be lost outside the let-binding. + (url-do-setup) + (with-current-buffer + (let ((url-registered-auth-schemes + '(("basic" ghub--basic-auth-errorback . 10)))) + (url-retrieve-synchronously url silent)) + (funcall handler (car url-callback-arguments) req))))) + +(defun ghub--handle-response (status req) + (let ((buffer (current-buffer))) + (unwind-protect + (progn + (set-buffer-multibyte t) + (let* ((unpaginate (ghub--req-unpaginate req)) + (headers (ghub--handle-response-headers status req)) + (payload (ghub--handle-response-payload req)) + (payload (ghub--handle-response-error status payload req)) + (value (ghub--handle-response-value payload req)) + (next (cdr (assq 'next (ghub-response-link-relations + req headers payload))))) + (when (numberp unpaginate) + (cl-decf unpaginate)) + (setf (ghub--req-url req) + (url-generic-parse-url next)) + (setf (ghub--req-unpaginate req) unpaginate) + (or (and next + unpaginate + (or (eq unpaginate t) + (> unpaginate 0)) + (ghub-continue req)) + (let ((callback (ghub--req-callback req)) + (errorback (ghub--req-errorback req)) + (err (plist-get status :error))) + (cond ((and err errorback) + (funcall errorback err headers status req)) + (callback + (funcall callback value headers status req)) + (t value)))))) + (when (buffer-live-p buffer) + (kill-buffer buffer))))) + +(defun ghub--handle-response-headers (status req) + (goto-char (point-min)) + (forward-line 1) + (let (headers) + (while (re-search-forward "^\\([^:]*\\): \\(.+\\)" + url-http-end-of-headers t) + (push (cons (match-string 1) + (match-string 2)) + headers)) + (setq headers (nreverse headers)) + (unless url-http-end-of-headers + (error "BUG: missing headers %s" (plist-get status :error))) + (goto-char (1+ url-http-end-of-headers)) + (if (and req (or (ghub--req-callback req) + (ghub--req-errorback req))) + (setq-local ghub-response-headers headers) + (setq-default ghub-response-headers headers)) + headers)) + +(defun ghub--handle-response-error (status payload req) + (let ((noerror (ghub--req-noerror req)) + (err (plist-get status :error))) + (if err + (if noerror + (if (eq noerror 'return) + payload + (setcdr (last err) (list payload)) + nil) + (ghub--signal-error err payload)) + payload))) + +(defun ghub--signal-error (err &optional payload) + (pcase-let ((`(,symb . ,data) err)) + (if (eq symb 'error) + (if (eq (car-safe data) 'http) + (signal 'ghub-http-error + (let ((code (car (cdr-safe data)))) + (list code + (nth 2 (assq code url-http-codes)) + payload))) + (signal 'ghub-error data)) + (signal symb data)))) + +(defun ghub--handle-response-value (payload req) + (setf (ghub--req-value req) + (nconc (ghub--req-value req) + (if-let ((nested (and (eq (ghub--req-forge req) 'bitbucket) + (assq 'values payload)))) + (cdr nested) + payload)))) + +(defun ghub--handle-response-payload (req) + (funcall (or (ghub--req-reader req) + 'ghub--read-json-payload) + url-http-response-status)) + +(defun ghub--read-json-payload (_status) + (let ((raw (ghub--decode-payload))) + (and raw + (condition-case nil + (let ((json-object-type 'alist) + (json-array-type 'list) + (json-key-type 'symbol) + (json-false nil) + (json-null nil)) + (json-read-from-string raw)) + (json-readtable-error + `((message + . ,(if (looking-at "<!DOCTYPE html>") + (if (re-search-forward + "<p>\\(?:<strong>\\)?\\([^<]+\\)" nil t) + (match-string 1) + "error description missing") + (string-trim (buffer-substring (point) (point-max))))) + (documentation_url + . "https://github.com/magit/ghub/wiki/Github-Errors"))))))) + +(defun ghub--decode-payload (&optional _status) + (and (not (eobp)) + (decode-coding-string + (buffer-substring-no-properties (point) (point-max)) + 'utf-8))) + +(defun ghub--encode-payload (payload) + (and payload + (progn + (unless (stringp payload) + (setq payload (json-encode-list payload))) + (encode-coding-string payload 'utf-8)))) + +(defun ghub--url-encode-params (params) + (mapconcat (lambda (param) + (pcase-let ((`(,key . ,val) param)) + (concat (url-hexify-string (symbol-name key)) "=" + (if (integerp val) + (number-to-string val) + (url-hexify-string val))))) + params "&")) + +;;; Authentication +;;;; API + +;;;###autoload +(defun ghub-create-token (host username package scopes) + "Create, store and return a new token. + +HOST is the Github instance, usually \"api.github.com\". +USERNAME is the name of a user on that instance. +PACKAGE is the package that will use the token. +SCOPES are the scopes the token is given access to." + (interactive + (pcase-let ((`(,host ,username ,package) + (ghub--read-triplet))) + (list host username package + (split-string + (read-string + "Scopes (separated by commas): " + (mapconcat #'symbol-name + (symbol-value + (intern (format "%s-github-token-scopes" package))) + ",")) + "," t "[\s\t]+")))) + (let ((user (ghub--ident username package))) + (cl-destructuring-bind (save token) + (ghub--auth-source-get (list :save-function :secret) + :create t :host host :user user + :secret + (cdr (assq 'token + (ghub-post + "/authorizations" + `((scopes . ,scopes) + (note . ,(ghub--ident-github package))) + :username username :auth 'basic :host host)))) + ;; Build-in back-ends return a function that does the actual + ;; saving, while for some third-party back-ends ":create t" + ;; is enough. + (when (functionp save) + (funcall save)) + ;; If the Auth-Source cache contains the information that there + ;; is no value, then setting the value does not invalidate that + ;; now incorrect information. + (auth-source-forget (list :host host :user user)) + token))) + +;;;###autoload +(defun ghub-token-scopes (host username package) + "Return and echo the scopes of the specified token. +This is intended for debugging purposes only. The user +has to provide several values including their password." + (interactive (ghub--read-triplet)) + (let ((scopes + (cdr (assq 'scopes (ghub--get-token-plist host username package))))) + (when (called-interactively-p 'any) + ;; Also show the input values to make it easy for package + ;; authors to verify that the user has done it correctly. + (message "Scopes for %s@%s: %S" + (ghub--ident username package) + host scopes)) + scopes)) + +;;;###autoload +(defun ghub-clear-caches () + "Clear all caches that might negatively affect Ghub. + +If a library that is used by Ghub caches incorrect information +such as a mistyped password, then that can prevent Ghub from +asking the user for the correct information again. + +Set `url-http-real-basic-auth-storage' to nil +and call `auth-source-forget+'." + (interactive) + (setq url-http-real-basic-auth-storage nil) + (auth-source-forget+)) + +;;;; Internal + +(defun ghub--headers (headers host auth username forge) + (push (cons "Content-Type" "application/json") headers) + (if (eq auth 'none) + headers + (unless (or username (stringp auth)) + (setq username (ghub--username host forge))) + (lambda () + (if (eq auth 'basic) + (cons (cons "Authorization" (ghub--basic-auth host username)) + headers) + (cons (ghub--auth host auth username forge) headers))))) + +(defun ghub--auth (host auth &optional username forge) + (unless username + (setq username (ghub--username host))) + (if (eq auth 'basic) + (cl-ecase forge + ((nil github gitea gogs bitbucket) + (cons "Authorization" (ghub--basic-auth host username))) + (gitlab + (error "Gitlab does not support basic authentication"))) + (cons (cl-ecase forge + ((nil github gitea gogs bitbucket) + "Authorization") + (gitlab + "Private-Token")) + (concat + (and (not (eq forge 'gitlab)) "token ") + (encode-coding-string + (cl-typecase auth + (string auth) + (null (ghub--token host username 'ghub nil forge)) + (symbol (ghub--token host username auth nil forge)) + (t (signal 'wrong-type-argument + `((or stringp symbolp) ,auth)))) + 'utf-8))))) + +(defun ghub--basic-auth (host username) + (let ((url (url-generic-parse-url (concat "https://" host)))) + (setf (url-user url) username) + (url-basic-auth url t))) + +(defun ghub--basic-auth-errorback (url &optional prompt _overwrite _realm _args) + ;; This gets called twice. Do nothing the first time, + ;; when PROMPT is nil. See `url-get-authentication'. + (when prompt + (if (assoc "X-GitHub-OTP" (ghub--handle-response-headers nil nil)) + (progn + (setq url-http-extra-headers + `(("Content-Type" . "application/json") + ("X-GitHub-OTP" . ,(ghub--read-2fa-code)) + ;; Without "Content-Type" and "Authorization". + ;; The latter gets re-added from the return value. + ,@(cddr url-http-extra-headers))) + ;; Return the cached values, they are correct. + (url-basic-auth url nil nil nil)) + ;; Remove the invalid cached values and fail, which + ;; is better than the invalid values sticking around. + (setq url-http-real-basic-auth-storage + (cl-delete (format "%s:%d" (url-host url) (url-port url)) + url-http-real-basic-auth-storage + :test #'equal :key #'car)) + nil))) + +(defun ghub--token (host username package &optional nocreate forge) + (let* ((user (ghub--ident username package)) + (token + (or (car (ghub--auth-source-get (list :secret) + :host host :user user)) + (progn + ;; Auth-Source caches the information that there is no + ;; value, but in our case that is a situation that needs + ;; fixing so we want to keep trying by invalidating that + ;; information. + ;; The (:max 1) is needed and has to be placed at the + ;; end for Emacs releases before 26.1. See #24, #64. + (auth-source-forget (list :host host :user user :max 1)) + (and (not nocreate) + (cl-ecase forge + ((nil github) + (ghub--confirm-create-token host username package)) + ((gitlab gitea gogs bitbucket) + (error "Required %s token (%S for %S) does not exist. +See https://magit.vc/manual/ghub/Support-for-Other-Forges.html for instructions." + (capitalize (symbol-name forge)) + user host)))))))) + (if (functionp token) (funcall token) token))) + +(defun ghub--host (&optional forge) + (cl-ecase forge + ((nil github) + (or (ignore-errors (car (process-lines "git" "config" "github.host"))) + ghub-default-host)) + (gitlab + (or (ignore-errors (car (process-lines "git" "config" "gitlab.host"))) + (bound-and-true-p glab-default-host))) + (gitea + (or (ignore-errors (car (process-lines "git" "config" "gitea.host"))) + (bound-and-true-p gtea-default-host))) + (gogs + (or (ignore-errors (car (process-lines "git" "config" "gogs.host"))) + (bound-and-true-p gogs-default-host))) + (bitbucket + (or (ignore-errors (car (process-lines "git" "config" "bitbucket.host"))) + (bound-and-true-p buck-default-host))))) + +(defun ghub--username (host &optional forge) + (let ((var (cond ((equal host ghub-default-host) + "github.user") + ((equal host (bound-and-true-p glab-default-host)) + "gitlab.user") + ((equal host (bound-and-true-p buck-default-host)) + "bitbucket.user") + ((eq forge 'github) (format "github.%s.user" host)) + ((eq forge 'gitlab) (format "gitlab.%s.user" host)) + ((eq forge 'bitbucket) (format "bitbucket.%s.user" host)) + ((eq forge 'gitea) (format "gitea.%s.user" host)) + ((eq forge 'gogs) (format "gogs.%s.user" host))))) + (condition-case nil + (car (process-lines "git" "config" var)) + (error + (let ((user (read-string + (format "Git variable `%s' is unset. Set to: " var)))) + (or (and user (progn (call-process "git" nil nil nil + "config" "--global" var user) + user)) + (user-error "Abort"))))))) + +(defun ghub--ident (username package) + (format "%s^%s" username package)) + +(defun ghub--ident-github (package) + (format "Emacs package %s @ %s" + package + (or ghub-override-system-name (system-name)))) + +(defun ghub--package-scopes (package) + (let ((var (intern (format "%s-github-token-scopes" package)))) + (if (boundp var) + (symbol-value var) + (error "%s fails to define %s" package var)))) + +(defun ghub--confirm-create-token (host username package) + (let* ((ident (ghub--ident-github package)) + (scopes (ghub--package-scopes package)) + (max-mini-window-height 40)) + (if (let ((message-log-max nil)) + (yes-or-no-p + (format + "Such a Github API token is not available: + + Host: %s + User: %s + Package: %s + + Scopes requested in `%s-github-token-scopes':\n%s + Store on Github as:\n %S + Store locally according to option `auth-sources':\n %S +%s +If in doubt, then abort and first view the section of the Ghub +documentation called \"Manually Creating and Storing a Token\". + +Otherwise confirm and then provide your Github username and +password at the next two prompts. Depending on the backend +you might have to provide a passphrase and confirm that you +really want to save the token. + +Create and store such a token? " + host username package package + (mapconcat (lambda (scope) (format " %s" scope)) scopes "\n") + ident auth-sources + (if (and (stringp (car auth-sources)) + (not (string-suffix-p ".gpg" (car auth-sources)))) + (format " +WARNING: The token will be stored unencrypted in %S. + If you don't want that, you have to abort and customize + the `auth-sources' option.\n" (car auth-sources)) + "")))) + (progn + (when (ghub--get-token-id host username package) + (if (yes-or-no-p + (format + "A token named %S\nalready exists on Github. Replace it?" + ident)) + (ghub--delete-token host username package) + (user-error "Abort"))) + (ghub-create-token host username package scopes)) + (user-error "Abort")))) + +(defun ghub--get-token-id (host username package) + (let ((ident (ghub--ident-github package))) + (cl-some (lambda (x) + (let-alist x + (and (equal .app.name ident) .id))) + (ghub-get "/authorizations" + '((per_page . 100)) + :unpaginate t + :username username :auth 'basic :host host)))) + +(defun ghub--get-token-plist (host username package) + (ghub-get (format "/authorizations/%s" + (ghub--get-token-id host username package)) + nil :username username :auth 'basic :host host)) + +(defun ghub--delete-token (host username package) + (ghub-delete (format "/authorizations/%s" + (ghub--get-token-id host username package)) + nil :username username :auth 'basic :host host)) + +(defun ghub--read-triplet () + (let ((host (read-string "Host: " (ghub--host)))) + (list host + (read-string "Username: " (ghub--username host)) + (intern (read-string "Package: " "ghub"))))) + +(defvar ghub--2fa-cache nil) + +(defun ghub--read-2fa-code () + (let ((code (read-number "Two-factor authentication code: " + (and ghub--2fa-cache + (< (float-time (time-subtract + (current-time) + (cdr ghub--2fa-cache))) + 25) + (car ghub--2fa-cache))))) + (setq ghub--2fa-cache (cons code (current-time))) + (number-to-string code))) + +(defun ghub--auth-source-get (keys &rest spec) + (declare (indent 1)) + (let ((plist (car (apply #'auth-source-search + (append spec (list :max 1)))))) + (mapcar (lambda (k) + (plist-get plist k)) + keys))) + +(advice-add 'auth-source-netrc-parse-next-interesting :around + 'auth-source-netrc-parse-next-interesting@save-match-data) +(defun auth-source-netrc-parse-next-interesting@save-match-data (fn) + "Save match-data for the benefit of caller `auth-source-netrc-parse-one'. +Without wrapping this function in `save-match-data' the caller +won't see the secret from a line that is followed by a commented +line." + (save-match-data (funcall fn))) + +;;; _ +(provide 'ghub) +(require 'ghub-graphql) +;;; ghub.el ends here |